Forgot to add a vocab
Slava Pestov
parent
2a0c92eb89
commit
304ee19a3b
|
|
@ -0,0 +1,197 @@
|
|||
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors byte-arrays kernel debugger sequences namespaces math
|
||||
math.order combinators init alien alien.c-types alien.strings libc
|
||||
continuations destructors debugger summary splitting assocs
|
||||
random math.parser locals unicode.case
|
||||
openssl.libcrypto openssl.libssl
|
||||
io.backend io.ports io.files io.encodings.8-bit
|
||||
io.timeouts ;
|
||||
IN: io.sockets.secure.openssl
|
||||
|
||||
GENERIC: ssl-method ( symbol -- method )
|
||||
|
||||
M: SSLv2 ssl-method drop SSLv2_client_method ;
|
||||
M: SSLv23 ssl-method drop SSLv23_method ;
|
||||
M: SSLv3 ssl-method drop SSLv3_method ;
|
||||
M: TLSv1 ssl-method drop TLSv1_method ;
|
||||
|
||||
TUPLE: openssl-context < secure-context aliens sessions ;
|
||||
|
||||
: set-session-cache ( ctx -- )
|
||||
handle>>
|
||||
[ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
|
||||
[ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
|
||||
bi ;
|
||||
|
||||
: load-certificate-chain ( ctx -- )
|
||||
dup config>> key-file>> [
|
||||
[ handle>> ] [ config>> key-file>> (normalize-path) ] bi
|
||||
SSL_CTX_use_certificate_chain_file
|
||||
ssl-error
|
||||
] [ drop ] if ;
|
||||
|
||||
: password-callback ( -- alien )
|
||||
"int" { "void*" "int" "bool" "void*" } "cdecl"
|
||||
[| buf size rwflag password! |
|
||||
password [ B{ 0 } password! ] unless
|
||||
|
||||
[let | len [ password strlen ] |
|
||||
buf password len 1+ size min memcpy
|
||||
len
|
||||
]
|
||||
] alien-callback ;
|
||||
|
||||
: default-pasword ( ctx -- alien )
|
||||
[ config>> password>> latin1 malloc-string ] [ aliens>> ] bi
|
||||
[ push ] [ drop ] 2bi ;
|
||||
|
||||
: set-default-password ( ctx -- )
|
||||
[ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
|
||||
[
|
||||
[ handle>> ] [ default-pasword ] bi
|
||||
SSL_CTX_set_default_passwd_cb_userdata
|
||||
] bi ;
|
||||
|
||||
: use-private-key-file ( ctx -- )
|
||||
dup config>> key-file>> [
|
||||
[ handle>> ] [ config>> key-file>> (normalize-path) ] bi
|
||||
SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file
|
||||
ssl-error
|
||||
] [ drop ] if ;
|
||||
|
||||
: load-verify-locations ( ctx -- )
|
||||
dup config>> [ ca-file>> ] [ ca-path>> ] bi or [
|
||||
[ handle>> ]
|
||||
[
|
||||
config>>
|
||||
[ ca-file>> dup [ (normalize-path) ] when ]
|
||||
[ ca-path>> dup [ (normalize-path) ] when ] bi
|
||||
] bi
|
||||
SSL_CTX_load_verify_locations
|
||||
] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;
|
||||
|
||||
: set-verify-depth ( ctx -- )
|
||||
dup config>> verify-depth>> [
|
||||
[ handle>> ] [ config>> verify-depth>> ] bi
|
||||
SSL_CTX_set_verify_depth
|
||||
] [ drop ] if ;
|
||||
|
||||
TUPLE: bio handle disposed ;
|
||||
|
||||
: <bio> ( handle -- bio ) f bio boa ;
|
||||
|
||||
M: bio dispose* handle>> BIO_free ssl-error ;
|
||||
|
||||
: <file-bio> ( path -- bio )
|
||||
normalize-path "r" BIO_new_file dup ssl-error <bio> ;
|
||||
|
||||
: load-dh-params ( ctx -- )
|
||||
dup config>> dh-file>> [
|
||||
[ handle>> ] [ config>> dh-file>> ] bi <file-bio> &dispose
|
||||
handle>> f f f PEM_read_bio_DHparams dup ssl-error
|
||||
SSL_CTX_set_tmp_dh ssl-error
|
||||
] [ drop ] if ;
|
||||
|
||||
TUPLE: rsa handle disposed ;
|
||||
|
||||
: <rsa> ( handle -- rsa ) f rsa boa ;
|
||||
|
||||
M: rsa dispose* handle>> RSA_free ;
|
||||
|
||||
: generate-eph-rsa-key ( ctx -- )
|
||||
[ handle>> ]
|
||||
[
|
||||
config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key
|
||||
dup ssl-error <rsa> &dispose handle>>
|
||||
] bi
|
||||
SSL_CTX_set_tmp_rsa ssl-error ;
|
||||
|
||||
: <openssl-context> ( config ctx -- context )
|
||||
openssl-context new
|
||||
swap >>handle
|
||||
swap >>config
|
||||
V{ } clone >>aliens
|
||||
H{ } clone >>sessions ;
|
||||
|
||||
M: openssl <secure-context> ( config -- context )
|
||||
maybe-init-ssl
|
||||
[
|
||||
dup method>> ssl-method SSL_CTX_new
|
||||
dup ssl-error <openssl-context> |dispose
|
||||
{
|
||||
[ set-session-cache ]
|
||||
[ load-certificate-chain ]
|
||||
[ set-default-password ]
|
||||
[ use-private-key-file ]
|
||||
[ load-verify-locations ]
|
||||
[ set-verify-depth ]
|
||||
[ load-dh-params ]
|
||||
[ generate-eph-rsa-key ]
|
||||
[ ]
|
||||
} cleave
|
||||
] with-destructors ;
|
||||
|
||||
M: openssl-context dispose*
|
||||
[ aliens>> [ free ] each ]
|
||||
[ sessions>> values [ SSL_SESSION_free ] each ]
|
||||
[ handle>> SSL_CTX_free ]
|
||||
tri ;
|
||||
|
||||
TUPLE: ssl-handle file handle connected disposed ;
|
||||
|
||||
SYMBOL: default-secure-context
|
||||
|
||||
: context-expired? ( context -- ? )
|
||||
dup [ handle>> expired? ] [ drop t ] if ;
|
||||
|
||||
: current-secure-context ( -- ctx )
|
||||
secure-context get [
|
||||
default-secure-context get dup context-expired? [
|
||||
drop
|
||||
<secure-config> <secure-context> default-secure-context set-global
|
||||
current-secure-context
|
||||
] when
|
||||
] unless* ;
|
||||
|
||||
: <ssl-handle> ( fd -- ssl )
|
||||
current-secure-context handle>> SSL_new dup ssl-error
|
||||
f f ssl-handle boa ;
|
||||
|
||||
M: ssl-handle dispose*
|
||||
[ handle>> SSL_free ] [ file>> dispose ] bi ;
|
||||
|
||||
: check-verify-result ( ssl-handle -- )
|
||||
SSL_get_verify_result dup X509_V_OK =
|
||||
[ drop ] [ verify-message certificate-verify-error ] if ;
|
||||
|
||||
: common-name ( certificate -- host )
|
||||
X509_get_subject_name
|
||||
NID_commonName 256 <byte-array>
|
||||
[ 256 X509_NAME_get_text_by_NID ] keep
|
||||
swap -1 = [ drop f ] [ latin1 alien>string ] if ;
|
||||
|
||||
: common-names-match? ( expected actual -- ? )
|
||||
[ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
|
||||
|
||||
: check-common-name ( host ssl-handle -- )
|
||||
SSL_get_peer_certificate common-name
|
||||
2dup common-names-match?
|
||||
[ 2drop ] [ common-name-verify-error ] if ;
|
||||
|
||||
M: openssl check-certificate ( host ssl -- )
|
||||
current-secure-context config>> verify>> [
|
||||
handle>>
|
||||
[ nip check-verify-result ]
|
||||
[ check-common-name ]
|
||||
2bi
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: get-session ( addrspec -- session/f )
|
||||
current-secure-context sessions>> at
|
||||
dup expired? [ drop f ] when ;
|
||||
|
||||
: save-session ( session addrspec -- )
|
||||
current-secure-context sessions>> set-at ;
|
||||
|
||||
openssl secure-socket-backend set-global
|
||||
Loading…
Reference in New Issue