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