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 alien alien.c-types alien.data alien.strings
   4 assocs byte-arrays classes.struct combinators destructors fry io
   5 io.backend io.buffers io.encodings.8-bit.latin1
   6 io.encodings.utf8 io.files io.pathnames io.ports io.sockets
   7 io.sockets.secure io.timeouts kernel libc
   8
   9 locals math math.order math.parser namespaces openssl
  10 openssl.libcrypto openssl.libssl random sequences splitting
  11 unicode.case ;
  12 IN: io.sockets.secure.openssl
  13
  14 GENERIC: ssl-method ( symbol -- method )
  15
  16 M: SSLv2  ssl-method drop SSLv2_client_method ;
  17 M: SSLv23 ssl-method drop SSLv23_method ;
  18 M: SSLv3  ssl-method drop SSLv3_method ;
  19 M: TLSv1  ssl-method drop TLSv1_method ;
  20
  21 TUPLE: openssl-context < secure-context aliens sessions ;
  22
  23 : set-session-cache ( ctx -- )
  24     handle>>
  25     [ SSL_SESS_CACHE_BOTH SSL_CTX_set_session_cache_mode ssl-error ]
  26     [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ]
  27     bi ;
  28
  29 ERROR: file-expected path ;
  30
  31 : ensure-exists ( path -- path )
  32     dup exists? [ throw-file-expected ] unless ; inline
  33
  34 : ssl-file-path ( path -- path' )
  35     absolute-path ensure-exists ;
  36
  37 : load-certificate-chain ( ctx -- )
  38     dup config>> key-file>> [
  39         [ handle>> ] [ config>> key-file>> ssl-file-path ] bi
  40         SSL_CTX_use_certificate_chain_file
  41         ssl-error
  42     ] [ drop ] if ;
  43
  44 : password-callback ( -- alien )
  45     int { void* int bool void* } cdecl
  46     [| buf size rwflag password! |
  47         password [ B{ 0 } password! ] unless
  48
  49         password strlen :> len
  50         buf password len 1 + size min memcpy
  51         len
  52     ] alien-callback ;
  53
  54 : default-pasword ( ctx -- alien )
  55     [ config>> password>> latin1 malloc-string ] [ aliens>> ] bi
  56     [ push ] [ drop ] 2bi ;
  57
  58 : set-default-password ( ctx -- )
  59     dup config>> password>> [
  60         [ handle>> password-callback SSL_CTX_set_default_passwd_cb ]
  61         [
  62             [ handle>> ] [ default-pasword ] bi
  63             SSL_CTX_set_default_passwd_cb_userdata
  64         ] bi
  65     ] [ drop ] if ;
  66
  67 : use-private-key-file ( ctx -- )
  68     dup config>> key-file>> [
  69         [ handle>> ]
  70         [ config>> key-file>> ssl-file-path ] bi
  71         SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file
  72         ssl-error
  73     ] [ drop ] if ;
  74
  75 : load-verify-locations ( ctx -- )
  76     dup config>> [ ca-file>> ] [ ca-path>> ] bi or [
  77         [ handle>> ]
  78         [
  79             config>>
  80             [ ca-file>> dup [ ssl-file-path ] when ]
  81             [ ca-path>> dup [ ssl-file-path ] when ] bi
  82         ] bi
  83         SSL_CTX_load_verify_locations
  84     ] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;
  85
  86 : set-verify-depth ( ctx -- )
  87     dup config>> verify-depth>> [
  88         [ handle>> ] [ config>> verify-depth>> ] bi
  89         SSL_CTX_set_verify_depth
  90     ] [ drop ] if ;
  91
  92 TUPLE: bio < disposable handle ;
  93
  94 : <bio> ( handle -- bio ) bio new-disposable swap >>handle ;
  95
  96 M: bio dispose* handle>> BIO_free ssl-error ;
  97
  98 : <file-bio> ( path -- bio )
  99     normalize-path "r" BIO_new_file dup ssl-error <bio> ;
 100
 101 : load-dh-params ( ctx -- )
 102     dup config>> dh-file>> [
 103         [ handle>> ] [ config>> dh-file>> ] bi <file-bio> &dispose
 104         handle>> f f f PEM_read_bio_DHparams dup ssl-error
 105         SSL_CTX_set_tmp_dh ssl-error
 106     ] [ drop ] if ;
 107
 108 TUPLE: rsa < disposable handle ;
 109
 110 : <rsa> ( handle -- rsa ) rsa new-disposable swap >>handle ;
 111
 112 M: rsa dispose* handle>> RSA_free ;
 113
 114 : generate-eph-rsa-key ( ctx -- )
 115     [ handle>> ]
 116     [
 117         config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key
 118         dup ssl-error <rsa> &dispose handle>>
 119     ] bi
 120     SSL_CTX_set_tmp_rsa ssl-error ;
 121
 122 : <openssl-context> ( config ctx -- context )
 123     openssl-context new-disposable
 124         swap >>handle
 125         swap >>config
 126         V{ } clone >>aliens
 127         H{ } clone >>sessions ;
 128
 129 M: openssl <secure-context> ( config -- context )
 130     maybe-init-ssl
 131     [
 132         dup method>> ssl-method SSL_CTX_new
 133         dup ssl-error <openssl-context> |dispose
 134         {
 135             [ set-session-cache ]
 136             [ load-certificate-chain ]
 137             [ set-default-password ]
 138             [ use-private-key-file ]
 139             [ load-verify-locations ]
 140             [ set-verify-depth ]
 141             [ load-dh-params ]
 142             [ generate-eph-rsa-key ]
 143             [ ]
 144         } cleave
 145     ] with-destructors ;
 146
 147 M: openssl-context dispose*
 148     [
 149         [ aliens>> [ &free drop ] each ]
 150         [ sessions>> values [ SSL_SESSION_free ] each ]
 151         [ handle>> SSL_CTX_free ]
 152         tri
 153     ] with-destructors ;
 154
 155 TUPLE: ssl-handle < disposable file handle connected ;
 156
 157 SYMBOL: default-secure-context
 158
 159 : current-secure-context ( -- ctx )
 160     secure-context get [
 161         default-secure-context [
 162             <secure-config> <secure-context>
 163         ] initialize-alien
 164     ] unless* ;
 165
 166 : get-session ( addrspec -- session/f )
 167     current-secure-context sessions>> at ;
 168
 169 : save-session ( session addrspec -- )
 170     current-secure-context sessions>> set-at ;
 171
 172 : <ssl-handle> ( fd -- ssl )
 173     [
 174         ssl-handle new-disposable |dispose
 175         current-secure-context handle>> SSL_new
 176         dup ssl-error >>handle
 177         swap >>file
 178     ] with-destructors ;
 179
 180 : <ssl-socket> ( winsock -- ssl )
 181     [
 182         socket-handle BIO_NOCLOSE BIO_new_socket dup ssl-error
 183     ] keep <ssl-handle>
 184     [ handle>> swap dup SSL_set_bio ] keep ;
 185
 186 ! Error handling
 187 : syscall-error ( r -- event )
 188     ERR_get_error [
 189         {
 190             { -1 [
 191                 errno ECONNRESET = [ throw-premature-close ]
 192                 [ throw-errno ] if
 193             ] }
 194             ! OpenSSL docs say this it is an error condition for
 195             ! a server to not send a close notify, but web
 196             ! servers in the wild don't seem to do this, for
 197             ! example https://www.google.com.
 198             { 0 [ f ] }
 199         } case
 200     ] [ nip (ssl-error) ] if-zero ;
 201
 202 : check-ssl-error ( ssl ret exra-cases/f -- event/f )
 203     [ swap over SSL_get_error ] dip
 204     {
 205         { SSL_ERROR_NONE [ drop f ] }
 206         { SSL_ERROR_WANT_READ [ drop +input+ ] }
 207         { SSL_ERROR_WANT_WRITE [ drop +output+ ] }
 208         { SSL_ERROR_SYSCALL [ syscall-error ] }
 209         { SSL_ERROR_SSL [ drop (ssl-error) ] }
 210     } append [ [ execute( -- n ) ] dip ] assoc-map
 211     at [ call( x -- y ) ] [ no-cond ] if* ;
 212
 213 ! Accept
 214 : do-ssl-accept-once ( ssl -- event/f )
 215     dup SSL_accept {
 216         { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] }
 217         { SSL_ERROR_WANT_ACCEPT [ drop +input+ ] }
 218     } check-ssl-error ;
 219
 220 : do-ssl-accept ( ssl-handle -- )
 221     dup handle>> do-ssl-accept-once
 222     [ [ dup file>> ] dip wait-for-fd do-ssl-accept ] [ drop ] if* ;
 223
 224 : maybe-handshake ( ssl-handle -- )
 225     dup connected>> [ drop ] [
 226         t >>connected
 227         [ do-ssl-accept ] with-timeout
 228     ] if ;
 229
 230 ! Input ports
 231 : do-ssl-read ( buffer ssl -- event/f )
 232     2dup swap [ buffer-end ] [ buffer-capacity ] bi SSL_read [
 233         { { SSL_ERROR_ZERO_RETURN [ drop f ] } } check-ssl-error
 234     ] keep swap [ 2nip ] [ swap buffer+ f ] if* ;
 235
 236 M: ssl-handle refill ( port handle -- event/f )
 237     dup maybe-handshake [ buffer>> ] [ handle>> ] bi* do-ssl-read ;
 238
 239 ! Output ports
 240 : do-ssl-write ( buffer ssl -- event/f )
 241     2dup swap [ buffer@ ] [ buffer-length ] bi SSL_write
 242     [ f check-ssl-error ] keep swap [ 2nip ] [ swap buffer-consume f ] if* ;
 243
 244 M: ssl-handle drain ( port handle -- event/f )
 245     dup maybe-handshake [ buffer>> ] [ handle>> ] bi* do-ssl-write ;
 246
 247 ! Connect
 248 : do-ssl-connect-once ( ssl -- event/f )
 249     dup SSL_connect f check-ssl-error ;
 250
 251 : do-ssl-connect ( ssl-handle -- )
 252     dup handle>> do-ssl-connect-once
 253     [ dupd wait-for-fd do-ssl-connect ] [ drop ] if* ;
 254
 255 : resume-session ( ssl-handle ssl-session -- )
 256     [ [ handle>> ] dip SSL_set_session ssl-error ]
 257     [ drop do-ssl-connect ]
 258     2bi ;
 259
 260 : begin-session ( ssl-handle addrspec -- )
 261     [ drop do-ssl-connect ]
 262     [ [ handle>> SSL_get1_session ] dip save-session ]
 263     2bi ;
 264
 265 : secure-connection ( client-out addrspec -- )
 266     [ handle>> ] dip
 267     [
 268         '[
 269             _ dup get-session
 270             [ resume-session ] [ begin-session ] ?if
 271         ] with-timeout
 272     ] [ drop t >>connected drop ] 2bi ;
 273
 274 M: ssl-handle timeout
 275     drop secure-socket-timeout get ;
 276
 277 M: ssl-handle cancel-operation
 278     file>> cancel-operation ;
 279
 280 M: ssl-handle dispose*
 281     [
 282         ! Free file>> after SSL_free
 283         [ file>> &dispose drop ]
 284         [ handle>> SSL_free ] bi
 285     ] with-destructors ;
 286
 287 : check-verify-result ( ssl-handle -- )
 288     SSL_get_verify_result dup X509_V_OK =
 289     [ drop ] [ verify-message throw-certificate-verify-error ] if ;
 290
 291 : x509name>string ( x509name -- string )
 292     NID_commonName 256 <byte-array>
 293     [ 256 X509_NAME_get_text_by_NID ] keep
 294     swap -1 = [ drop f ] [ latin1 alien>string ] if ;
 295
 296 : subject-name ( certificate -- host )
 297     X509_get_subject_name x509name>string ;
 298
 299 : issuer-name ( certificate -- issuer )
 300     X509_get_issuer_name x509name>string ;
 301
 302 : name-stack>sequence ( name-stack -- seq )
 303     dup sk_num iota [ sk_value GENERAL_NAME_st memory>struct ] with map ;
 304
 305 : alternative-dns-names ( certificate -- dns-names )
 306     NID_subject_alt_name f f X509_get_ext_d2i
 307     [ name-stack>sequence ] [ f ] if*
 308     [ type>> GEN_DNS = ] filter
 309     [ d>> dNSName>> data>> utf8 alien>string ] map ;
 310
 311 : subject-names-match? ( host subject -- ? )
 312     [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
 313
 314 : check-subject-name ( host ssl-handle -- )
 315     SSL_get_peer_certificate [
 316         [ alternative-dns-names ] [ subject-name ] bi suffix
 317         2dup [ subject-names-match? ] with any?
 318         [ 2drop ] [ throw-subject-name-verify-error ] if
 319     ] [ throw-certificate-missing-error ] if* ;
 320
 321 M: openssl check-certificate ( host ssl -- )
 322     current-secure-context config>> verify>> [
 323         handle>>
 324         [ nip check-verify-result ]
 325         [ check-subject-name ]
 326         2bi
 327     ] [ 2drop ] if ;
 328
 329 : check-buffer ( port -- port )
 330     dup buffer>> buffer-empty? [ throw-upgrade-buffers-full ] unless ;
 331
 332 : input/output-ports ( -- input output )
 333     input-stream output-stream
 334     [ get underlying-port check-buffer ] bi@
 335     2dup [ handle>> ] bi@ eq? [ throw-upgrade-on-non-socket ] unless ;
 336
 337 : make-input/output-secure ( input output -- )
 338     dup handle>> non-ssl-socket? [ throw-upgrade-on-non-socket ] unless
 339     [ <ssl-socket> ] change-handle
 340     handle>> >>handle drop ;
 341
 342 : (send-secure-handshake) ( output -- )
 343     remote-address get [ throw-upgrade-on-non-socket ] unless*
 344     secure-connection ;
 345
 346 M: openssl send-secure-handshake
 347     input/output-ports
 348     [ make-input/output-secure ] keep
 349     [ (send-secure-handshake) ] keep
 350     remote-address get dup inet? [
 351         host>> swap handle>> check-certificate
 352     ] [ 2drop ] if ;
 353
 354 M: openssl accept-secure-handshake ( -- )
 355     input/output-ports
 356     make-input/output-secure ;
 357
 358 openssl secure-socket-backend set-global