1 ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.c-types alien.data alien.strings
4 assocs byte-arrays classes.struct combinators destructors fry io
5 io.backend io.buffers io.encodings.8-bit.latin1
6 io.encodings.utf8 io.files io.pathnames io.ports io.sockets
7 io.sockets.secure io.timeouts kernel libc
9 locals math math.order math.parser namespaces openssl
10 openssl.libcrypto openssl.libssl random sequences splitting
12 IN: io.sockets.secure.openssl
14 GENERIC: ssl-method ( symbol -- method )
16 M: SSLv2 ssl-method drop SSLv2_client_method ;
17 M: SSLv23 ssl-method drop SSLv23_method ;
18 M: SSLv3 ssl-method drop SSLv3_method ;
19 M: TLSv1 ssl-method drop TLSv1_method ;
21 TUPLE: openssl-context < secure-context aliens sessions ;
23 : set-session-cache ( ctx -- )
25 [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
26 [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
29 ERROR: file-expected path ;
31 : ensure-exists ( path -- path )
32 dup exists? [ throw-file-expected ] unless ; inline
34 : ssl-file-path ( path -- path' )
35 absolute-path ensure-exists ;
37 : load-certificate-chain ( ctx -- )
38 dup config>> key-file>> [
39 [ handle>> ] [ config>> key-file>> ssl-file-path ] bi
40 SSL_CTX_use_certificate_chain_file
44 : password-callback ( -- alien )
45 int { void* int bool void* } cdecl
46 [| buf size rwflag password! |
47 password [ B{ 0 } password! ] unless
49 password strlen :> len
50 buf password len 1 + size min memcpy
54 : default-pasword ( ctx -- alien )
55 [ config>> password>> latin1 malloc-string ] [ aliens>> ] bi
56 [ push ] [ drop ] 2bi ;
58 : set-default-password ( ctx -- )
59 dup config>> password>> [
60 [ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
62 [ handle>> ] [ default-pasword ] bi
63 SSL_CTX_set_default_passwd_cb_userdata
67 : use-private-key-file ( ctx -- )
68 dup config>> key-file>> [
70 [ config>> key-file>> ssl-file-path ] bi
71 SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file
75 : load-verify-locations ( ctx -- )
76 dup config>> [ ca-file>> ] [ ca-path>> ] bi or [
80 [ ca-file>> dup [ ssl-file-path ] when ]
81 [ ca-path>> dup [ ssl-file-path ] when ] bi
83 SSL_CTX_load_verify_locations
84 ] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;
86 : set-verify-depth ( ctx -- )
87 dup config>> verify-depth>> [
88 [ handle>> ] [ config>> verify-depth>> ] bi
89 SSL_CTX_set_verify_depth
92 TUPLE: bio < disposable handle ;
94 : <bio> ( handle -- bio ) bio new-disposable swap >>handle ;
96 M: bio dispose* handle>> BIO_free ssl-error ;
98 : <file-bio> ( path -- bio )
99 normalize-path "r" BIO_new_file dup ssl-error <bio> ;
101 : load-dh-params ( ctx -- )
102 dup config>> dh-file>> [
103 [ handle>> ] [ config>> dh-file>> ] bi <file-bio> &dispose
104 handle>> f f f PEM_read_bio_DHparams dup ssl-error
105 SSL_CTX_set_tmp_dh ssl-error
108 TUPLE: rsa < disposable handle ;
110 : <rsa> ( handle -- rsa ) rsa new-disposable swap >>handle ;
112 M: rsa dispose* handle>> RSA_free ;
114 : generate-eph-rsa-key ( ctx -- )
117 config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key
118 dup ssl-error <rsa> &dispose handle>>
120 SSL_CTX_set_tmp_rsa ssl-error ;
122 : <openssl-context> ( config ctx -- context )
123 openssl-context new-disposable
127 H{ } clone >>sessions ;
129 M: openssl <secure-context> ( config -- context )
132 dup method>> ssl-method SSL_CTX_new
133 dup ssl-error <openssl-context> |dispose
135 [ set-session-cache ]
136 [ load-certificate-chain ]
137 [ set-default-password ]
138 [ use-private-key-file ]
139 [ load-verify-locations ]
142 [ generate-eph-rsa-key ]
147 M: openssl-context dispose*
149 [ aliens>> [ &free drop ] each ]
150 [ sessions>> values [ SSL_SESSION_free ] each ]
151 [ handle>> SSL_CTX_free ]
155 TUPLE: ssl-handle < disposable file handle connected ;
157 SYMBOL: default-secure-context
159 : current-secure-context ( -- ctx )
161 default-secure-context [
162 <secure-config> <secure-context>
166 : get-session ( addrspec -- session/f )
167 current-secure-context sessions>> at ;
169 : save-session ( session addrspec -- )
170 current-secure-context sessions>> set-at ;
172 : <ssl-handle> ( fd -- ssl )
174 ssl-handle new-disposable |dispose
175 current-secure-context handle>> SSL_new
176 dup ssl-error >>handle
180 : <ssl-socket> ( winsock -- ssl )
182 socket-handle BIO_NOCLOSE BIO_new_socket dup ssl-error
184 [ handle>> swap dup SSL_set_bio ] keep ;
187 : syscall-error ( r -- event )
191 errno ECONNRESET = [ throw-premature-close ]
194 ! OpenSSL docs say this it is an error condition for
195 ! a server to not send a close notify, but web
196 ! servers in the wild don't seem to do this, for
197 ! example https://www.google.com.
200 ] [ nip (ssl-error) ] if-zero ;
202 : check-ssl-error ( ssl ret exra-cases/f -- event/f )
203 [ swap over SSL_get_error ] dip
205 { SSL_ERROR_NONE [ drop f ] }
206 { SSL_ERROR_WANT_READ [ drop +input+ ] }
207 { SSL_ERROR_WANT_WRITE [ drop +output+ ] }
208 { SSL_ERROR_SYSCALL [ syscall-error ] }
209 { SSL_ERROR_SSL [ drop (ssl-error) ] }
210 } append [ [ execute( -- n ) ] dip ] assoc-map
211 at [ call( x -- y ) ] [ no-cond ] if* ;
214 : do-ssl-accept-once ( ssl -- event/f )
216 { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] }
217 { SSL_ERROR_WANT_ACCEPT [ drop +input+ ] }
220 : do-ssl-accept ( ssl-handle -- )
221 dup handle>> do-ssl-accept-once
222 [ [ dup file>> ] dip wait-for-fd do-ssl-accept ] [ drop ] if* ;
224 : maybe-handshake ( ssl-handle -- )
225 dup connected>> [ drop ] [
227 [ do-ssl-accept ] with-timeout
231 : do-ssl-read ( buffer ssl -- event/f )
232 2dup swap [ buffer-end ] [ buffer-capacity ] bi SSL_read [
233 { { SSL_ERROR_ZERO_RETURN [ drop f ] } } check-ssl-error
234 ] keep swap [ 2nip ] [ swap buffer+ f ] if* ;
236 M: ssl-handle refill ( port handle -- event/f )
237 dup maybe-handshake [ buffer>> ] [ handle>> ] bi* do-ssl-read ;
240 : do-ssl-write ( buffer ssl -- event/f )
241 2dup swap [ buffer@ ] [ buffer-length ] bi SSL_write
242 [ f check-ssl-error ] keep swap [ 2nip ] [ swap buffer-consume f ] if* ;
244 M: ssl-handle drain ( port handle -- event/f )
245 dup maybe-handshake [ buffer>> ] [ handle>> ] bi* do-ssl-write ;
248 : do-ssl-connect-once ( ssl -- event/f )
249 dup SSL_connect f check-ssl-error ;
251 : do-ssl-connect ( ssl-handle -- )
252 dup handle>> do-ssl-connect-once
253 [ dupd wait-for-fd do-ssl-connect ] [ drop ] if* ;
255 : resume-session ( ssl-handle ssl-session -- )
256 [ [ handle>> ] dip SSL_set_session ssl-error ]
257 [ drop do-ssl-connect ]
260 : begin-session ( ssl-handle addrspec -- )
261 [ drop do-ssl-connect ]
262 [ [ handle>> SSL_get1_session ] dip save-session ]
265 : secure-connection ( client-out addrspec -- )
270 [ resume-session ] [ begin-session ] ?if
272 ] [ drop t >>connected drop ] 2bi ;
274 M: ssl-handle timeout
275 drop secure-socket-timeout get ;
277 M: ssl-handle cancel-operation
278 file>> cancel-operation ;
280 M: ssl-handle dispose*
282 ! Free file>> after SSL_free
283 [ file>> &dispose drop ]
284 [ handle>> SSL_free ] bi
287 : check-verify-result ( ssl-handle -- )
288 SSL_get_verify_result dup X509_V_OK =
289 [ drop ] [ verify-message throw-certificate-verify-error ] if ;
291 : x509name>string ( x509name -- string )
292 NID_commonName 256 <byte-array>
293 [ 256 X509_NAME_get_text_by_NID ] keep
294 swap -1 = [ drop f ] [ latin1 alien>string ] if ;
296 : subject-name ( certificate -- host )
297 X509_get_subject_name x509name>string ;
299 : issuer-name ( certificate -- issuer )
300 X509_get_issuer_name x509name>string ;
302 : name-stack>sequence ( name-stack -- seq )
303 dup sk_num iota [ sk_value GENERAL_NAME_st memory>struct ] with map ;
305 : alternative-dns-names ( certificate -- dns-names )
306 NID_subject_alt_name f f X509_get_ext_d2i
307 [ name-stack>sequence ] [ f ] if*
308 [ type>> GEN_DNS = ] filter
309 [ d>> dNSName>> data>> utf8 alien>string ] map ;
311 : subject-names-match? ( host subject -- ? )
312 [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
314 : check-subject-name ( host ssl-handle -- )
315 SSL_get_peer_certificate [
316 [ alternative-dns-names ] [ subject-name ] bi suffix
317 2dup [ subject-names-match? ] with any?
318 [ 2drop ] [ throw-subject-name-verify-error ] if
319 ] [ throw-certificate-missing-error ] if* ;
321 M: openssl check-certificate ( host ssl -- )
322 current-secure-context config>> verify>> [
324 [ nip check-verify-result ]
325 [ check-subject-name ]
329 : check-buffer ( port -- port )
330 dup buffer>> buffer-empty? [ throw-upgrade-buffers-full ] unless ;
332 : input/output-ports ( -- input output )
333 input-stream output-stream
334 [ get underlying-port check-buffer ] bi@
335 2dup [ handle>> ] bi@ eq? [ throw-upgrade-on-non-socket ] unless ;
337 : make-input/output-secure ( input output -- )
338 dup handle>> non-ssl-socket? [ throw-upgrade-on-non-socket ] unless
339 [ <ssl-socket> ] change-handle
340 handle>> >>handle drop ;
342 : (send-secure-handshake) ( output -- )
343 remote-address get [ throw-upgrade-on-non-socket ] unless*
346 M: openssl send-secure-handshake
348 [ make-input/output-secure ] keep
349 [ (send-secure-handshake) ] keep
350 remote-address get dup inet? [
351 host>> swap handle>> check-certificate
354 M: openssl accept-secure-handshake ( -- )
356 make-input/output-secure ;
358 openssl secure-socket-backend set-global