basis/io/unix/sockets/secure/secure.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 debugger sequences namespaces math
   4 math.order combinators init alien alien.c-types alien.strings libc
   5 continuations destructors
   6 openssl openssl.libcrypto openssl.libssl
   7 io.files io.ports io.unix.backend io.unix.sockets
   8 io.encodings.ascii io.buffers io.sockets io.sockets.secure
   9 io.timeouts system summary ;
  10 IN: io.unix.sockets.secure
  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     ] [
  22         nip (ssl-error)
  23     ] if ;
  24
  25 : check-accept-response ( handle r -- event )
  26     over handle>> over SSL_get_error
  27     {
  28         { SSL_ERROR_NONE [ 2drop f ] }
  29         { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
  30         { SSL_ERROR_WANT_ACCEPT [ 2drop +input+ ] }
  31         { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
  32         { SSL_ERROR_SYSCALL [ syscall-error ] }
  33         { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] }
  34         { SSL_ERROR_SSL [ (ssl-error) ] }
  35     } case ;
  36
  37 : do-ssl-accept ( ssl-handle -- )
  38     dup dup handle>> SSL_accept check-accept-response dup
  39     [ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ;
  40
  41 : maybe-handshake ( ssl-handle -- )
  42     dup connected>> [ drop ] [
  43         t >>connected
  44         [ do-ssl-accept ] with-timeout
  45     ] if ;
  46
  47 : check-response ( port r -- port r n )
  48     over handle>> handle>> over SSL_get_error ; inline
  49
  50 ! Input ports
  51 : check-read-response ( port r -- event )
  52     check-response
  53     {
  54         { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] }
  55         { SSL_ERROR_ZERO_RETURN [ 2drop f ] }
  56         { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
  57         { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
  58         { SSL_ERROR_SYSCALL [ syscall-error ] }
  59         { SSL_ERROR_SSL [ (ssl-error) ] }
  60     } case ;
  61
  62 M: ssl-handle refill
  63     dup maybe-handshake
  64     handle>> ! ssl
  65     over buffer>>
  66     [ buffer-end ] ! buf
  67     [ buffer-capacity ] bi ! len
  68     SSL_read
  69     check-read-response ;
  70
  71 ! Output ports
  72 : check-write-response ( port r -- event )
  73     check-response
  74     {
  75         { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] }
  76         { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
  77         { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
  78         { SSL_ERROR_SYSCALL [ syscall-error ] }
  79         { SSL_ERROR_SSL [ (ssl-error) ] }
  80     } case ;
  81
  82 M: ssl-handle drain
  83     dup maybe-handshake
  84     handle>> ! ssl
  85     over buffer>>
  86     [ buffer@ ] ! buf
  87     [ buffer-length ] bi ! len
  88     SSL_write
  89     check-write-response ;
  90
  91 M: ssl-handle cancel-operation
  92     file>> cancel-operation ;
  93
  94 M: ssl-handle timeout
  95     drop secure-socket-timeout get ;
  96
  97 ! Client sockets
  98 : <ssl-socket> ( fd -- ssl )
  99     [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
 100     [ handle>> swap dup SSL_set_bio ] keep ;
 101
 102 M: secure ((client)) ( addrspec -- handle )
 103     addrspec>> ((client)) <ssl-socket> ;
 104
 105 M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
 106
 107 M: secure (get-local-address) addrspec>> (get-local-address) ;
 108
 109 : check-connect-response ( ssl-handle r -- event )
 110     over handle>> over SSL_get_error
 111     {
 112         { SSL_ERROR_NONE [ 2drop f ] }
 113         { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
 114         { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
 115         { SSL_ERROR_SYSCALL [ syscall-error ] }
 116         { SSL_ERROR_SSL [ (ssl-error) ] }
 117     } case ;
 118
 119 : do-ssl-connect ( ssl-handle -- )
 120     dup dup handle>> SSL_connect check-connect-response dup
 121     [ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ;
 122
 123 : resume-session ( ssl-handle ssl-session -- )
 124     [ [ handle>> ] dip SSL_set_session ssl-error ]
 125     [ drop do-ssl-connect ]
 126     2bi ;
 127
 128 : begin-session ( ssl-handle addrspec -- )
 129     [ drop do-ssl-connect ]
 130     [ [ handle>> SSL_get1_session ] dip save-session ]
 131     2bi ;
 132
 133 : secure-connection ( ssl-handle addrspec -- )
 134     dup get-session [ resume-session ] [ begin-session ] ?if ;
 135
 136 M: secure establish-connection ( client-out remote -- )
 137     addrspec>>
 138     [ establish-connection ]
 139     [
 140         [ handle>> ] dip
 141         [ [ secure-connection ] curry with-timeout ]
 142         [ drop t >>connected drop ]
 143         2bi
 144     ] 2bi ;
 145
 146 M: secure (server) addrspec>> (server) ;
 147
 148 M: secure (accept)
 149     [
 150         addrspec>> (accept) >r |dispose <ssl-socket> r>
 151     ] with-destructors ;
 152
 153 : check-shutdown-response ( handle r -- event )
 154     #! We don't do two-step shutdown here because I couldn't
 155     #! figure out how to do it with non-blocking BIOs. Also, it
 156     #! seems that SSL_shutdown always returns 0 -- this sounds
 157     #! like a bug
 158     over handle>> over SSL_get_error
 159     {
 160         { SSL_ERROR_NONE [ 2drop f ] }
 161         { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
 162         { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
 163         { SSL_ERROR_SYSCALL [ dup zero? [ 2drop f ] [ syscall-error ] if ] }
 164         { SSL_ERROR_SSL [ (ssl-error) ] }
 165     } case ;
 166
 167 : (shutdown) ( handle -- )
 168     dup dup handle>> SSL_shutdown check-shutdown-response
 169     dup [ dupd wait-for-fd (shutdown) ] [ 2drop ] if ;
 170
 171 M: ssl-handle shutdown
 172     dup connected>> [
 173         f >>connected [ (shutdown) ] with-timeout
 174     ] [ drop ] if ;