From 7418fd9df4d8c8b28efc5ba4567283301318de68 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 23 Nov 2008 01:00:29 -0600 Subject: [PATCH] Move code out of openssl vocabulary --- basis/io/unix/sockets/secure/secure.factor | 12 +- basis/openssl/openssl.factor | 196 +-------------------- 2 files changed, 8 insertions(+), 200 deletions(-) diff --git a/basis/io/unix/sockets/secure/secure.factor b/basis/io/unix/sockets/secure/secure.factor index 649c68673f..fb5ed93978 100644 --- a/basis/io/unix/sockets/secure/secure.factor +++ b/basis/io/unix/sockets/secure/secure.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors unix byte-arrays kernel debugger sequences namespaces math -math.order combinators init alien alien.c-types alien.strings libc -continuations destructors -openssl openssl.libcrypto openssl.libssl -io.files io.ports io.unix.backend io.unix.sockets -io.encodings.ascii io.buffers io.sockets io.sockets.secure +USING: accessors unix byte-arrays kernel debugger sequences +namespaces math math.order combinators init alien alien.c-types +alien.strings libc continuations destructors openssl +openssl.libcrypto openssl.libssl io.files io.ports +io.unix.backend io.unix.sockets io.encodings.ascii io.buffers +io.sockets io.sockets.secure io.sockets.secure.openssl io.timeouts system summary ; IN: io.unix.sockets.secure diff --git a/basis/openssl/openssl.factor b/basis/openssl/openssl.factor index 284e42cd1b..8f14c60e14 100644 --- a/basis/openssl/openssl.factor +++ b/basis/openssl/openssl.factor @@ -1,25 +1,13 @@ ! 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 ; @@ -47,183 +35,3 @@ SYMBOL: ssl-initialized? ] 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 ; - -: ( handle -- bio ) f bio boa ; - -M: bio dispose* handle>> BIO_free ssl-error ; - -: ( path -- bio ) - normalize-path "r" BIO_new_file dup ssl-error ; - -: load-dh-params ( ctx -- ) - dup config>> dh-file>> [ - [ handle>> ] [ config>> dh-file>> ] bi &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 ; - -: ( 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 &dispose handle>> - ] bi - SSL_CTX_set_tmp_rsa ssl-error ; - -: ( config ctx -- context ) - openssl-context new - swap >>handle - swap >>config - V{ } clone >>aliens - H{ } clone >>sessions ; - -M: openssl ( config -- context ) - maybe-init-ssl - [ - dup method>> ssl-method SSL_CTX_new - dup ssl-error |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 - default-secure-context set-global - current-secure-context - ] when - ] unless* ; - -: ( 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 - [ 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