! 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.sockets.secure
-io.timeouts ;
+USING: init kernel namespaces openssl.libcrypto openssl.libssl
+sequences ;
IN: openssl
! This code is based on http://www.rtfm.com/openssl-examples/
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 )
ERR_clear_error f ERR_error_string ;
] unless ;
[ 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
projects / factor.git / commitdiff