basis/io/sockets/secure/unix/unix.factor

   1 ! Copyright (C) 2007, 2011, Slava Pestov, Elie CHAFTARI.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators destructors io.backend.unix
   4 io.files io.sockets.private io.sockets.secure
   5 io.sockets.secure.openssl io.timeouts kernel math openssl
   6 openssl.libssl system ;
   7 FROM: io.ports => shutdown ;
   8 IN: io.sockets.secure.unix
   9
  10 M: openssl ssl-supported? t ;
  11 M: openssl ssl-certificate-verification-supported? t ;
  12
  13 M: ssl-handle handle-fd file>> handle-fd ;
  14
  15 M: unix socket-handle fd>> ;
  16
  17 M: secure ((client)) ( addrspec -- handle )
  18     addrspec>> ((client)) <ssl-socket> ;
  19
  20 M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
  21
  22 M: secure (get-local-address) addrspec>> (get-local-address) ;
  23
  24 M: secure establish-connection ( client-out remote -- )
  25     addrspec>> [ establish-connection ] [ secure-connection ] 2bi ;
  26
  27 M: secure (server) addrspec>> (server) ;
  28
  29 M: secure (accept)
  30     [
  31         addrspec>> (accept) [ |dispose <ssl-socket> ] dip
  32     ] with-destructors ;
  33
  34 : check-shutdown-response ( handle r -- event )
  35     ! We don't do two-step shutdown here because I couldn't
  36     ! figure out how to do it with non-blocking BIOs. Also, it
  37     ! seems that SSL_shutdown always returns 0 -- this sounds
  38     ! like a bug
  39     over handle>> over SSL_get_error
  40     {
  41         { SSL_ERROR_NONE [ 2drop f ] }
  42         { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
  43         { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
  44         { SSL_ERROR_SYSCALL [ [ drop f ] [ nip syscall-error ] if-zero ] }
  45         { SSL_ERROR_SSL [ (ssl-error) ] }
  46     } case ;
  47
  48 : (shutdown) ( handle -- )
  49     dup dup handle>> SSL_shutdown check-shutdown-response
  50     [ dupd wait-for-fd (shutdown) ] [ drop ] if* ;
  51
  52 M: ssl-handle shutdown
  53     dup connected>> [
  54         f >>connected [ (shutdown) ] with-timeout
  55     ] [ drop ] if ;
  56
  57 M: unix non-ssl-socket? ( obj -- ? ) fd? ;