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 debugger sequences namespaces math
4 math.order combinators init alien alien.c-types alien.strings libc
5 continuations destructors debugger summary splitting assocs
6 random math.parser locals unicode.case
7 openssl.libcrypto openssl.libssl
8 io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
12 ! This code is based on http://www.rtfm.com/openssl-examples/
16 GENERIC: ssl-method ( symbol -- method )
18 M: SSLv2 ssl-method drop SSLv2_client_method ;
19 M: SSLv23 ssl-method drop SSLv23_method ;
20 M: SSLv3 ssl-method drop SSLv3_method ;
21 M: TLSv1 ssl-method drop TLSv1_method ;
23 : (ssl-error-string) ( n -- string )
24 ERR_clear_error f ERR_error_string ;
26 : ssl-error-string ( -- string )
27 ERR_get_error ERR_clear_error f ERR_error_string ;
29 : (ssl-error) ( -- * )
30 ssl-error-string throw ;
32 : ssl-error ( obj -- )
33 { f 0 } member? [ (ssl-error) ] when ;
36 SSL_library_init ssl-error
37 SSL_load_error_strings
38 OpenSSL_add_all_digests
39 OpenSSL_add_all_ciphers ;
41 SYMBOL: ssl-initialized?
43 : maybe-init-ssl ( -- )
44 ssl-initialized? get-global [
46 t ssl-initialized? set-global
49 [ f ssl-initialized? set-global ] "openssl" add-init-hook
51 TUPLE: openssl-context < secure-context aliens sessions ;
53 : set-session-cache ( ctx -- )
55 [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
56 [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
59 : load-certificate-chain ( ctx -- )
60 dup config>> key-file>> [
61 [ handle>> ] [ config>> key-file>> (normalize-path) ] bi
62 SSL_CTX_use_certificate_chain_file
66 : password-callback ( -- alien )
67 "int" { "void*" "int" "bool" "void*" } "cdecl"
68 [| buf size rwflag password! |
69 password [ B{ 0 } password! ] unless
71 [let | len [ password strlen ] |
72 buf password len 1+ size min memcpy
77 : default-pasword ( ctx -- alien )
78 [ config>> password>> latin1 malloc-string ] [ aliens>> ] bi
79 [ push ] [ drop ] 2bi ;
81 : set-default-password ( ctx -- )
82 [ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
84 [ handle>> ] [ default-pasword ] bi
85 SSL_CTX_set_default_passwd_cb_userdata
88 : use-private-key-file ( ctx -- )
89 dup config>> key-file>> [
90 [ handle>> ] [ config>> key-file>> (normalize-path) ] bi
91 SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file
95 : load-verify-locations ( ctx -- )
96 dup config>> [ ca-file>> ] [ ca-path>> ] bi or [
100 [ ca-file>> dup [ (normalize-path) ] when ]
101 [ ca-path>> dup [ (normalize-path) ] when ] bi
103 SSL_CTX_load_verify_locations
104 ] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;
106 : set-verify-depth ( ctx -- )
107 dup config>> verify-depth>> [
108 [ handle>> ] [ config>> verify-depth>> ] bi
109 SSL_CTX_set_verify_depth
112 TUPLE: bio handle disposed ;
114 : <bio> ( handle -- bio ) f bio boa ;
116 M: bio dispose* handle>> BIO_free ssl-error ;
118 : <file-bio> ( path -- bio )
119 normalize-path "r" BIO_new_file dup ssl-error <bio> ;
121 : load-dh-params ( ctx -- )
122 dup config>> dh-file>> [
123 [ handle>> ] [ config>> dh-file>> ] bi <file-bio> &dispose
124 handle>> f f f PEM_read_bio_DHparams dup ssl-error
125 SSL_CTX_set_tmp_dh ssl-error
128 TUPLE: rsa handle disposed ;
130 : <rsa> ( handle -- rsa ) f rsa boa ;
132 M: rsa dispose* handle>> RSA_free ;
134 : generate-eph-rsa-key ( ctx -- )
137 config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key
138 dup ssl-error <rsa> &dispose handle>>
140 SSL_CTX_set_tmp_rsa ssl-error ;
142 : <openssl-context> ( config ctx -- context )
147 H{ } clone >>sessions ;
149 M: openssl <secure-context> ( config -- context )
152 dup method>> ssl-method SSL_CTX_new
153 dup ssl-error <openssl-context> |dispose
155 [ set-session-cache ]
156 [ load-certificate-chain ]
157 [ set-default-password ]
158 [ use-private-key-file ]
159 [ load-verify-locations ]
162 [ generate-eph-rsa-key ]
167 M: openssl-context dispose*
168 [ aliens>> [ free ] each ]
169 [ sessions>> values [ SSL_SESSION_free ] each ]
170 [ handle>> SSL_CTX_free ]
173 TUPLE: ssl-handle file handle connected disposed ;
175 SYMBOL: default-secure-context
177 : context-expired? ( context -- ? )
178 dup [ handle>> expired? ] [ drop t ] if ;
180 : current-secure-context ( -- ctx )
182 default-secure-context get dup context-expired? [
184 <secure-config> <secure-context> default-secure-context set-global
185 current-secure-context
189 : <ssl-handle> ( fd -- ssl )
190 current-secure-context handle>> SSL_new dup ssl-error
193 M: ssl-handle dispose*
194 [ handle>> SSL_free ] [ file>> dispose ] bi ;
196 : check-verify-result ( ssl-handle -- )
197 SSL_get_verify_result dup X509_V_OK =
198 [ drop ] [ verify-message certificate-verify-error ] if ;
200 : common-name ( certificate -- host )
201 X509_get_subject_name
202 NID_commonName 256 <byte-array>
203 [ 256 X509_NAME_get_text_by_NID ] keep
204 swap -1 = [ drop f ] [ latin1 alien>string ] if ;
206 : common-names-match? ( expected actual -- ? )
207 [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
209 : check-common-name ( host ssl-handle -- )
210 SSL_get_peer_certificate common-name
211 2dup common-names-match?
212 [ 2drop ] [ common-name-verify-error ] if ;
214 M: openssl check-certificate ( host ssl -- )
215 current-secure-context config>> verify>> [
217 [ nip check-verify-result ]
218 [ check-common-name ]
222 : get-session ( addrspec -- session/f )
223 current-secure-context sessions>> at
224 dup expired? [ drop f ] when ;
226 : save-session ( session addrspec -- )
227 current-secure-context sessions>> set-at ;
229 openssl secure-socket-backend set-global