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