basis/io/sockets/secure/openssl/openssl.factor

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