1 ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors byte-arrays kernel sequences namespaces math
4 math.order combinators init alien alien.c-types alien.data
5 alien.strings libc continuations destructors summary splitting
6 assocs random math.parser locals unicode.case openssl
7 openssl.libcrypto openssl.libssl io.backend io.ports io.pathnames
8 io.encodings.8-bit io.timeouts io.sockets.secure ;
9 IN: io.sockets.secure.openssl
11 GENERIC: ssl-method ( symbol -- method )
13 M: SSLv2 ssl-method drop SSLv2_client_method ;
14 M: SSLv23 ssl-method drop SSLv23_method ;
15 M: SSLv3 ssl-method drop SSLv3_method ;
16 M: TLSv1 ssl-method drop TLSv1_method ;
18 TUPLE: openssl-context < secure-context aliens sessions ;
20 : set-session-cache ( ctx -- )
22 [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
23 [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
26 : load-certificate-chain ( ctx -- )
27 dup config>> key-file>> [
28 [ handle>> ] [ config>> key-file>> absolute-path ] bi
29 SSL_CTX_use_certificate_chain_file
33 : password-callback ( -- alien )
34 int { void* int bool void* } "cdecl"
35 [| buf size rwflag password! |
36 password [ B{ 0 } password! ] unless
38 password strlen :> len
39 buf password len 1 + size min memcpy
43 : default-pasword ( ctx -- alien )
44 [ config>> password>> latin1 malloc-string ] [ aliens>> ] bi
45 [ push ] [ drop ] 2bi ;
47 : set-default-password ( ctx -- )
48 dup config>> password>> [
49 [ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
51 [ handle>> ] [ default-pasword ] bi
52 SSL_CTX_set_default_passwd_cb_userdata
56 : use-private-key-file ( ctx -- )
57 dup config>> key-file>> [
58 [ handle>> ] [ config>> key-file>> absolute-path ] bi
59 SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file
63 : load-verify-locations ( ctx -- )
64 dup config>> [ ca-file>> ] [ ca-path>> ] bi or [
68 [ ca-file>> dup [ absolute-path ] when ]
69 [ ca-path>> dup [ absolute-path ] when ] bi
71 SSL_CTX_load_verify_locations
72 ] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;
74 : set-verify-depth ( ctx -- )
75 dup config>> verify-depth>> [
76 [ handle>> ] [ config>> verify-depth>> ] bi
77 SSL_CTX_set_verify_depth
80 TUPLE: bio < disposable handle ;
82 : <bio> ( handle -- bio ) bio new-disposable swap >>handle ;
84 M: bio dispose* handle>> BIO_free ssl-error ;
86 : <file-bio> ( path -- bio )
87 normalize-path "r" BIO_new_file dup ssl-error <bio> ;
89 : load-dh-params ( ctx -- )
90 dup config>> dh-file>> [
91 [ handle>> ] [ config>> dh-file>> ] bi <file-bio> &dispose
92 handle>> f f f PEM_read_bio_DHparams dup ssl-error
93 SSL_CTX_set_tmp_dh ssl-error
96 TUPLE: rsa < disposable handle ;
98 : <rsa> ( handle -- rsa ) rsa new-disposable swap >>handle ;
100 M: rsa dispose* handle>> RSA_free ;
102 : generate-eph-rsa-key ( ctx -- )
105 config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key
106 dup ssl-error <rsa> &dispose handle>>
108 SSL_CTX_set_tmp_rsa ssl-error ;
110 : <openssl-context> ( config ctx -- context )
111 openssl-context new-disposable
115 H{ } clone >>sessions ;
117 M: openssl <secure-context> ( config -- context )
120 dup method>> ssl-method SSL_CTX_new
121 dup ssl-error <openssl-context> |dispose
123 [ set-session-cache ]
124 [ load-certificate-chain ]
125 [ set-default-password ]
126 [ use-private-key-file ]
127 [ load-verify-locations ]
130 [ generate-eph-rsa-key ]
135 M: openssl-context dispose*
136 [ aliens>> [ free ] each ]
137 [ sessions>> values [ SSL_SESSION_free ] each ]
138 [ handle>> SSL_CTX_free ]
141 TUPLE: ssl-handle < disposable file handle connected ;
143 SYMBOL: default-secure-context
145 : current-secure-context ( -- ctx )
147 default-secure-context [
148 <secure-config> <secure-context>
152 : <ssl-handle> ( fd -- ssl )
153 ssl-handle new-disposable
154 current-secure-context handle>> SSL_new
155 dup ssl-error >>handle
158 M: ssl-handle dispose*
159 [ handle>> SSL_free ] [ file>> dispose ] bi ;
161 : check-verify-result ( ssl-handle -- )
162 SSL_get_verify_result dup X509_V_OK =
163 [ drop ] [ verify-message certificate-verify-error ] if ;
165 : common-name ( certificate -- host )
166 X509_get_subject_name
167 NID_commonName 256 <byte-array>
168 [ 256 X509_NAME_get_text_by_NID ] keep
169 swap -1 = [ drop f ] [ latin1 alien>string ] if ;
171 : common-names-match? ( expected actual -- ? )
172 [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
174 : check-common-name ( host ssl-handle -- )
175 SSL_get_peer_certificate common-name
176 2dup common-names-match?
177 [ 2drop ] [ common-name-verify-error ] if ;
179 M: openssl check-certificate ( host ssl -- )
180 current-secure-context config>> verify>> [
182 [ nip check-verify-result ]
183 [ check-common-name ]
187 : get-session ( addrspec -- session/f )
188 current-secure-context sessions>> at ;
190 : save-session ( session addrspec -- )
191 current-secure-context sessions>> set-at ;
193 openssl secure-socket-backend set-global