basis/io/sockets/secure/openssl/openssl.factor

   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
   9 io.timeouts ;
  10 IN: io.sockets.secure.openssl
  11
  12 GENERIC: ssl-method ( symbol -- method )
  13
  14 M: SSLv2  ssl-method drop SSLv2_client_method ;
  15 M: SSLv23 ssl-method drop SSLv23_method ;
  16 M: SSLv3  ssl-method drop SSLv3_method ;
  17 M: TLSv1  ssl-method drop TLSv1_method ;
  18
  19 TUPLE: openssl-context < secure-context aliens sessions ;
  20
  21 : set-session-cache ( ctx -- )
  22     handle>>
  23     [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
  24     [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
  25     bi ;
  26
  27 : load-certificate-chain ( ctx -- )
  28     dup config>> key-file>> [
  29         [ handle>> ] [ config>> key-file>> (normalize-path) ] bi
  30         SSL_CTX_use_certificate_chain_file
  31         ssl-error
  32     ] [ drop ] if ;
  33
  34 : password-callback ( -- alien )
  35     "int" { "void*" "int" "bool" "void*" } "cdecl"
  36     [| buf size rwflag password! |
  37         password [ B{ 0 } password! ] unless
  38
  39         [let | len [ password strlen ] |
  40             buf password len 1+ size min memcpy
  41             len
  42         ]
  43     ] alien-callback ;
  44
  45 : default-pasword ( ctx -- alien )
  46     [ config>> password>> latin1 malloc-string ] [ aliens>> ] bi
  47     [ push ] [ drop ] 2bi ;
  48
  49 : set-default-password ( ctx -- )
  50     [ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
  51     [
  52         [ handle>> ] [ default-pasword ] bi
  53         SSL_CTX_set_default_passwd_cb_userdata
  54     ] bi ;
  55
  56 : use-private-key-file ( ctx -- )
  57     dup config>> key-file>> [
  58         [ handle>> ] [ config>> key-file>> (normalize-path) ] bi
  59         SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file
  60         ssl-error
  61     ] [ drop ] if ;
  62
  63 : load-verify-locations ( ctx -- )
  64     dup config>> [ ca-file>> ] [ ca-path>> ] bi or [
  65         [ handle>> ]
  66         [
  67             config>>
  68             [ ca-file>> dup [ (normalize-path) ] when ]
  69             [ ca-path>> dup [ (normalize-path) ] when ] bi
  70         ] bi
  71         SSL_CTX_load_verify_locations
  72     ] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;
  73
  74 : set-verify-depth ( ctx -- )
  75     dup config>> verify-depth>> [
  76         [ handle>> ] [ config>> verify-depth>> ] bi
  77         SSL_CTX_set_verify_depth
  78     ] [ drop ] if ;
  79
  80 TUPLE: bio handle disposed ;
  81
  82 : <bio> ( handle -- bio ) f bio boa ;
  83
  84 M: bio dispose* handle>> BIO_free ssl-error ;
  85
  86 : <file-bio> ( path -- bio )
  87     normalize-path "r" BIO_new_file dup ssl-error <bio> ;
  88
  89 : load-dh-params ( ctx -- )
  90     dup config>> dh-file>> [
  91         [ handle>> ] [ config>> dh-file>> ] bi <file-bio> &dispose
  92         handle>> f f f PEM_read_bio_DHparams dup ssl-error
  93         SSL_CTX_set_tmp_dh ssl-error
  94     ] [ drop ] if ;
  95
  96 TUPLE: rsa handle disposed ;
  97
  98 : <rsa> ( handle -- rsa ) f rsa boa ;
  99
 100 M: rsa dispose* handle>> RSA_free ;
 101
 102 : generate-eph-rsa-key ( ctx -- )
 103     [ handle>> ]
 104     [
 105         config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key
 106         dup ssl-error <rsa> &dispose handle>>
 107     ] bi
 108     SSL_CTX_set_tmp_rsa ssl-error ;
 109
 110 : <openssl-context> ( config ctx -- context )
 111     openssl-context new
 112         swap >>handle
 113         swap >>config
 114         V{ } clone >>aliens
 115         H{ } clone >>sessions ;
 116
 117 M: openssl <secure-context> ( config -- context )
 118     maybe-init-ssl
 119     [
 120         dup method>> ssl-method SSL_CTX_new
 121         dup ssl-error <openssl-context> |dispose
 122         {
 123             [ set-session-cache ]
 124             [ load-certificate-chain ]
 125             [ set-default-password ]
 126             [ use-private-key-file ]
 127             [ load-verify-locations ]
 128             [ set-verify-depth ]
 129             [ load-dh-params ]
 130             [ generate-eph-rsa-key ]
 131             [ ]
 132         } cleave
 133     ] with-destructors ;
 134
 135 M: openssl-context dispose*
 136     [ aliens>> [ free ] each ]
 137     [ sessions>> values [ SSL_SESSION_free ] each ]
 138     [ handle>> SSL_CTX_free ]
 139     tri ;
 140
 141 TUPLE: ssl-handle file handle connected disposed ;
 142
 143 SYMBOL: default-secure-context
 144
 145 : context-expired? ( context -- ? )
 146     dup [ handle>> expired? ] [ drop t ] if ;
 147
 148 : current-secure-context ( -- ctx )
 149     secure-context get [
 150         default-secure-context get dup context-expired? [
 151             drop
 152             <secure-config> <secure-context> default-secure-context set-global
 153             current-secure-context
 154         ] when
 155     ] unless* ;
 156
 157 : <ssl-handle> ( fd -- ssl )
 158     current-secure-context handle>> SSL_new dup ssl-error
 159     f f ssl-handle boa ;
 160
 161 M: ssl-handle dispose*
 162     [ handle>> SSL_free ] [ file>> dispose ] bi ;
 163
 164 : check-verify-result ( ssl-handle -- )
 165     SSL_get_verify_result dup X509_V_OK =
 166     [ drop ] [ verify-message certificate-verify-error ] if ;
 167
 168 : common-name ( certificate -- host )
 169     X509_get_subject_name
 170     NID_commonName 256 <byte-array>
 171     [ 256 X509_NAME_get_text_by_NID ] keep
 172     swap -1 = [ drop f ] [ latin1 alien>string ] if ;
 173
 174 : common-names-match? ( expected actual -- ? )
 175     [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
 176
 177 : check-common-name ( host ssl-handle -- )
 178     SSL_get_peer_certificate common-name
 179     2dup common-names-match?
 180     [ 2drop ] [ common-name-verify-error ] if ;
 181
 182 M: openssl check-certificate ( host ssl -- )
 183     current-secure-context config>> verify>> [
 184         handle>>
 185         [ nip check-verify-result ]
 186         [ check-common-name ]
 187         2bi
 188     ] [ 2drop ] if ;
 189
 190 : get-session ( addrspec -- session/f )
 191     current-secure-context sessions>> at
 192     dup expired? [ drop f ] when ;
 193
 194 : save-session ( session addrspec -- )
 195     current-secure-context sessions>> set-at ;
 196
 197 openssl secure-socket-backend set-global