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