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
12 M: ssl-handle handle-fd file>> handle-fd ;
14 : syscall-error ( r -- * )
15 ERR_get_error dup zero? [
18 { -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
19 { 0 [ premature-close ] }
25 : check-accept-response ( handle r -- event )
26 over handle>> over SSL_get_error
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) ] }
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 ;
41 : maybe-handshake ( ssl-handle -- )
42 dup connected>> [ drop ] [
44 [ do-ssl-accept ] with-timeout
47 : check-response ( port r -- port r n )
48 over handle>> handle>> over SSL_get_error ; inline
51 : check-read-response ( port r -- event )
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) ] }
67 [ buffer-capacity ] bi ! len
72 : check-write-response ( port r -- event )
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) ] }
87 [ buffer-length ] bi ! len
89 check-write-response ;
91 M: ssl-handle cancel-operation
92 file>> cancel-operation ;
95 drop secure-socket-timeout get ;
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 ;
102 M: secure ((client)) ( addrspec -- handle )
103 addrspec>> ((client)) <ssl-socket> ;
105 M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
107 M: secure (get-local-address) addrspec>> (get-local-address) ;
109 : check-connect-response ( ssl-handle r -- event )
110 over handle>> over SSL_get_error
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) ] }
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 ;
123 : resume-session ( ssl-handle ssl-session -- )
124 [ [ handle>> ] dip SSL_set_session ssl-error ]
125 [ drop do-ssl-connect ]
128 : begin-session ( ssl-handle addrspec -- )
129 [ drop do-ssl-connect ]
130 [ [ handle>> SSL_get1_session ] dip save-session ]
133 : secure-connection ( ssl-handle addrspec -- )
134 dup get-session [ resume-session ] [ begin-session ] ?if ;
136 M: secure establish-connection ( client-out remote -- )
138 [ establish-connection ]
141 [ [ secure-connection ] curry with-timeout ]
142 [ drop t >>connected drop ]
146 M: secure (server) addrspec>> (server) ;
150 addrspec>> (accept) >r |dispose <ssl-socket> r>
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
158 over handle>> over SSL_get_error
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) ] }
167 : (shutdown) ( handle -- )
168 dup dup handle>> SSL_shutdown check-shutdown-response
169 dup [ dupd wait-for-fd (shutdown) ] [ 2drop ] if ;
171 M: ssl-handle shutdown
173 f >>connected [ (shutdown) ] with-timeout