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

   1 ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors unix byte-arrays kernel sequences
   4 namespaces math math.order combinators init alien alien.c-types
   5 alien.strings libc continuations destructors openssl
   6 openssl.libcrypto openssl.libssl io io.files io.ports
   7 io.backend.unix io.sockets.unix io.encodings.ascii io.buffers
   8 io.sockets io.sockets.secure io.sockets.secure.openssl
   9 io.timeouts system summary fry ;
  10 FROM: io.ports => shutdown ;
  11 IN: io.sockets.secure.unix
  12
  13 M: ssl-handle handle-fd file>> handle-fd ;
  14
  15 : syscall-error ( r -- * )
  16     ERR_get_error dup zero? [
  17         drop
  18         {
  19             { -1 [ errno ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
  20             { 0 [ premature-close ] }
  21         } case
  22     ] [ nip (ssl-error) ] if ;
  23
  24 : check-accept-response ( handle r -- event )
  25     over handle>> over SSL_get_error
  26     {
  27         { SSL_ERROR_NONE [ 2drop f ] }
  28         { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
  29         { SSL_ERROR_WANT_ACCEPT [ 2drop +input+ ] }
  30         { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
  31         { SSL_ERROR_SYSCALL [ syscall-error ] }
  32         { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] }
  33         { SSL_ERROR_SSL [ (ssl-error) ] }
  34     } case ;
  35
  36 : do-ssl-accept ( ssl-handle -- )
  37     dup dup handle>> SSL_accept check-accept-response dup
  38     [ [ dup file>> ] dip wait-for-fd do-ssl-accept ] [ 2drop ] if ;
  39
  40 : maybe-handshake ( ssl-handle -- )
  41     dup connected>> [ drop ] [
  42         t >>connected
  43         [ do-ssl-accept ] with-timeout
  44     ] if ;
  45
  46 : check-response ( port r -- port r n )
  47     over handle>> handle>> over SSL_get_error ; inline
  48
  49 ! Input ports
  50 : check-read-response ( port r -- event )
  51     check-response
  52     {
  53         { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] }
  54         { SSL_ERROR_ZERO_RETURN [ 2drop f ] }
  55         { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
  56         { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
  57         { SSL_ERROR_SYSCALL [ syscall-error ] }
  58         { SSL_ERROR_SSL [ (ssl-error) ] }
  59     } case ;
  60
  61 M: ssl-handle refill
  62     dup maybe-handshake
  63     handle>> ! ssl
  64     over buffer>>
  65     [ buffer-end ] ! buf
  66     [ buffer-capacity ] bi ! len
  67     SSL_read
  68     check-read-response ;
  69
  70 ! Output ports
  71 : check-write-response ( port r -- event )
  72     check-response
  73     {
  74         { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] }
  75         { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
  76         { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
  77         { SSL_ERROR_SYSCALL [ syscall-error ] }
  78         { SSL_ERROR_SSL [ (ssl-error) ] }
  79     } case ;
  80
  81 M: ssl-handle drain
  82     dup maybe-handshake
  83     handle>> ! ssl
  84     over buffer>>
  85     [ buffer@ ] ! buf
  86     [ buffer-length ] bi ! len
  87     SSL_write
  88     check-write-response ;
  89
  90 M: ssl-handle cancel-operation
  91     file>> cancel-operation ;
  92
  93 M: ssl-handle timeout
  94     drop secure-socket-timeout get ;
  95
  96 ! Client sockets
  97 : <ssl-socket> ( fd -- ssl )
  98     [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
  99     [ handle>> swap dup SSL_set_bio ] keep ;
 100
 101 M: secure ((client)) ( addrspec -- handle )
 102     addrspec>> ((client)) <ssl-socket> ;
 103
 104 M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
 105
 106 M: secure (get-local-address) addrspec>> (get-local-address) ;
 107
 108 : check-connect-response ( ssl-handle r -- event )
 109     over handle>> over SSL_get_error
 110     {
 111         { SSL_ERROR_NONE [ 2drop f ] }
 112         { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
 113         { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
 114         { SSL_ERROR_SYSCALL [ syscall-error ] }
 115         { SSL_ERROR_SSL [ (ssl-error) ] }
 116     } case ;
 117
 118 : do-ssl-connect ( ssl-handle -- )
 119     dup dup handle>> SSL_connect check-connect-response dup
 120     [ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ;
 121
 122 : resume-session ( ssl-handle ssl-session -- )
 123     [ [ handle>> ] dip SSL_set_session ssl-error ]
 124     [ drop do-ssl-connect ]
 125     2bi ;
 126
 127 : begin-session ( ssl-handle addrspec -- )
 128     [ drop do-ssl-connect ]
 129     [ [ handle>> SSL_get1_session ] dip save-session ]
 130     2bi ;
 131
 132 : secure-connection ( client-out addrspec -- )
 133     [ handle>> ] dip
 134     [
 135         '[
 136             _ dup get-session
 137             [ resume-session ] [ begin-session ] ?if
 138         ] with-timeout
 139     ] [ drop t >>connected drop ] 2bi ;
 140
 141 M: secure establish-connection ( client-out remote -- )
 142     addrspec>> [ establish-connection ] [ secure-connection ] 2bi ;
 143
 144 M: secure (server) addrspec>> (server) ;
 145
 146 M: secure (accept)
 147     [
 148         addrspec>> (accept) [ |dispose <ssl-socket> ] dip
 149     ] with-destructors ;
 150
 151 : check-shutdown-response ( handle r -- event )
 152     #! We don't do two-step shutdown here because I couldn't
 153     #! figure out how to do it with non-blocking BIOs. Also, it
 154     #! seems that SSL_shutdown always returns 0 -- this sounds
 155     #! like a bug
 156     over handle>> over SSL_get_error
 157     {
 158         { SSL_ERROR_NONE [ 2drop f ] }
 159         { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
 160         { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
 161         { SSL_ERROR_SYSCALL [ dup zero? [ 2drop f ] [ syscall-error ] if ] }
 162         { SSL_ERROR_SSL [ (ssl-error) ] }
 163     } case ;
 164
 165 : (shutdown) ( handle -- )
 166     dup dup handle>> SSL_shutdown check-shutdown-response
 167     dup [ dupd wait-for-fd (shutdown) ] [ 2drop ] if ;
 168
 169 M: ssl-handle shutdown
 170     dup connected>> [
 171         f >>connected [ (shutdown) ] with-timeout
 172     ] [ drop ] if ;
 173
 174 : check-buffer ( port -- port )
 175     dup buffer>> buffer-empty? [ upgrade-buffers-full ] unless ;
 176
 177 : input/output-ports ( -- input output )
 178     input-stream output-stream
 179     [ get underlying-port check-buffer ] bi@
 180     2dup [ handle>> ] bi@ eq? [ upgrade-on-non-socket ] unless ;
 181
 182 : make-input/output-secure ( input output -- )
 183     dup handle>> fd? [ upgrade-on-non-socket ] unless
 184     [ <ssl-socket> ] change-handle
 185     handle>> >>handle drop ;
 186
 187 : (send-secure-handshake) ( output -- )
 188     remote-address get [ upgrade-on-non-socket ] unless*
 189     secure-connection ;
 190
 191 M: openssl send-secure-handshake
 192     input/output-ports
 193     [ make-input/output-secure ] keep
 194     [ (send-secure-handshake) ] keep
 195     remote-address get dup inet? [
 196         host>> swap handle>> check-certificate
 197     ] [ 2drop ] if ;
 198
 199 M: openssl accept-secure-handshake
 200     input/output-ports
 201     make-input/output-secure ;