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