Move code out of openssl vocabulary
Slava Pestov
parent
ab53e7ce7a
commit
7418fd9df4
|
|
@ -1,11 +1,11 @@
|
||||||
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors unix byte-arrays kernel debugger sequences namespaces math
|
USING: accessors unix byte-arrays kernel debugger sequences
|
||||||
math.order combinators init alien alien.c-types alien.strings libc
|
namespaces math math.order combinators init alien alien.c-types
|
||||||
continuations destructors
|
alien.strings libc continuations destructors openssl
|
||||||
openssl openssl.libcrypto openssl.libssl
|
openssl.libcrypto openssl.libssl io.files io.ports
|
||||||
io.files io.ports io.unix.backend io.unix.sockets
|
io.unix.backend io.unix.sockets io.encodings.ascii io.buffers
|
||||||
io.encodings.ascii io.buffers io.sockets io.sockets.secure
|
io.sockets io.sockets.secure io.sockets.secure.openssl
|
||||||
io.timeouts system summary ;
|
io.timeouts system summary ;
|
||||||
IN: io.unix.sockets.secure
|
IN: io.unix.sockets.secure
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,25 +1,13 @@
|
||||||
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors byte-arrays kernel debugger sequences namespaces math
|
USING: init kernel namespaces openssl.libcrypto openssl.libssl
|
||||||
math.order combinators init alien alien.c-types alien.strings libc
|
sequences ;
|
||||||
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.sockets.secure
|
|
||||||
io.timeouts ;
|
|
||||||
IN: openssl
|
IN: openssl
|
||||||
|
|
||||||
! This code is based on http://www.rtfm.com/openssl-examples/
|
! This code is based on http://www.rtfm.com/openssl-examples/
|
||||||
|
|
||||||
SINGLETON: openssl
|
SINGLETON: 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 ;
|
|
||||||
|
|
||||||
: (ssl-error-string) ( n -- string )
|
: (ssl-error-string) ( n -- string )
|
||||||
ERR_clear_error f ERR_error_string ;
|
ERR_clear_error f ERR_error_string ;
|
||||||
|
|
||||||
|
|
@ -47,183 +35,3 @@ SYMBOL: ssl-initialized?
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
||||||
[ f ssl-initialized? set-global ] "openssl" add-init-hook
|
[ f ssl-initialized? set-global ] "openssl" add-init-hook
|
||||||
|
|
||||||
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