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