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