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