basis/io/sockets/secure/secure.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.libraries calendar combinators delegate
   4 destructors io io.sockets io.sockets.private kernel memoize namespaces
   5 openssl.libssl present sequences summary system vocabs ;
   6 IN: io.sockets.secure
   7
   8 SYMBOL: secure-socket-timeout
   9
  10 1 minutes secure-socket-timeout set-global
  11
  12 SYMBOL: secure-socket-backend
  13
  14 HOOK: ssl-supported? secure-socket-backend ( -- ? )
  15 HOOK: ssl-certificate-verification-supported? secure-socket-backend ( -- ? )
  16
  17 M: object ssl-supported? f ;
  18 M: object ssl-certificate-verification-supported? f ;
  19
  20 SINGLETONS: TLSv1 TLSv1.1 TLSv1.2 ;
  21
  22 ERROR: no-tls-supported ;
  23
  24 MEMO: best-tls-method ( -- class )
  25     {
  26         { [ "TLSv1_2_method" "libssl" dlsym? ] [ TLSv1.2 ] }
  27         { [ "TLSv1_1_method" "libssl" dlsym? ] [ TLSv1.1 ] }
  28         { [ "TLSv1_method" "libssl" dlsym? ] [ TLSv1 ] }
  29         [ no-tls-supported ]
  30     } cond ;
  31
  32 TUPLE: secure-config
  33 method
  34 key-file password
  35 verify
  36 verify-depth
  37 ca-file ca-path
  38 dh-file
  39 ephemeral-key-bits
  40 alpn-supported-protocols ;
  41
  42 : <secure-config> ( -- config )
  43     secure-config new
  44         best-tls-method >>method
  45         1024 >>ephemeral-key-bits
  46         ssl-certificate-verification-supported? >>verify ;
  47
  48 TUPLE: secure-context < disposable config handle ;
  49
  50 HOOK: <secure-context> secure-socket-backend ( config -- context )
  51
  52 : with-secure-context ( config quot -- )
  53     [
  54         [ <secure-context> ] [ [ secure-context set ] prepose ] bi*
  55         with-disposal
  56     ] with-scope ; inline
  57
  58 TUPLE: secure
  59     { addrspec read-only }
  60     { hostname read-only } ;
  61
  62 C: <secure> secure
  63
  64 M: secure present addrspec>> present " (secure)" append ;
  65
  66 M: secure (server) addrspec>> (server) ;
  67
  68 CONSULT: inet secure addrspec>> ;
  69
  70 M: secure resolve-host
  71     [ addrspec>> resolve-host ] [ hostname>> ] bi
  72     [ <secure> ] curry map ;
  73
  74 HOOK: check-certificate secure-socket-backend ( host handle -- )
  75
  76 PREDICATE: secure-inet < secure addrspec>> inet? ;
  77
  78 <PRIVATE
  79
  80 M: secure-inet (client)
  81     [
  82         [ resolve-host (client) [ |dispose ] dip ] keep
  83         addrspec>> host>> pick handle>> check-certificate
  84     ] with-destructors ;
  85
  86 PRIVATE>
  87
  88 ERROR: premature-close-error ;
  89
  90 M: premature-close-error summary
  91     drop "Connection closed prematurely" ;
  92
  93 ERROR: certificate-verify-error result ;
  94
  95 M: certificate-verify-error summary
  96     drop "Certificate verification failed" ;
  97
  98 ERROR: subject-name-verify-error expected got ;
  99
 100 M: subject-name-verify-error summary
 101     drop "Subject name verification failed" ;
 102
 103 ERROR: certificate-missing-error ;
 104
 105 M: certificate-missing-error summary
 106     drop "Host did not present any certificate" ;
 107
 108 ERROR: upgrade-on-non-socket ;
 109
 110 M: upgrade-on-non-socket summary
 111     drop
 112     "send-secure-handshake can only be used if input-stream and" print
 113     "output-stream are a socket" ;
 114
 115 ERROR: upgrade-buffers-full ;
 116
 117 M: upgrade-buffers-full summary
 118     drop
 119     "send-secure-handshake can only be used if buffers are empty" ;
 120
 121 HOOK: non-ssl-socket? os ( obj -- ? )
 122
 123 HOOK: socket-handle os ( obj -- ? )
 124
 125 HOOK: send-secure-handshake secure-socket-backend ( -- )
 126
 127 HOOK: accept-secure-handshake secure-socket-backend ( -- )
 128
 129 {
 130     { [ os unix? ] [ "io.sockets.secure.unix" require ] }
 131     { [ os windows? ] [ "io.sockets.secure.windows" require ] }
 132 } cond