extra/io/sockets/secure/secure.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel symbols namespaces continuations
   4 destructors io.sockets sequences inspector calendar delegate ;
   5 IN: io.sockets.secure
   6
   7 SYMBOL: secure-socket-timeout
   8
   9 1 minutes secure-socket-timeout set-global
  10
  11 SYMBOL: secure-socket-backend
  12
  13 SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;
  14
  15 TUPLE: secure-config
  16 method
  17 key-file password
  18 verify
  19 verify-depth
  20 ca-file ca-path
  21 dh-file
  22 ephemeral-key-bits ;
  23
  24 : <secure-config> ( -- config )
  25     secure-config new
  26         SSLv23 >>method
  27         1024 >>ephemeral-key-bits
  28         "resource:extra/openssl/cacert.pem" >>ca-file
  29         t >>verify ;
  30
  31 TUPLE: secure-context config handle disposed ;
  32
  33 HOOK: <secure-context> secure-socket-backend ( config -- context )
  34
  35 : with-secure-context ( config quot -- )
  36     [
  37         [ <secure-context> ] [ [ secure-context set ] prepose ] bi*
  38         with-disposal
  39     ] with-scope ; inline
  40
  41 TUPLE: secure addrspec ;
  42
  43 C: <secure> secure
  44
  45 CONSULT: inet secure addrspec>> ;
  46
  47 M: secure resolve-host ( secure -- seq )
  48     addrspec>> resolve-host [ <secure> ] map ;
  49
  50 HOOK: check-certificate secure-socket-backend ( host handle -- )
  51
  52 <PRIVATE
  53
  54 PREDICATE: secure-inet < secure addrspec>> inet? ;
  55
  56 M: secure-inet (client)
  57     [
  58         [ resolve-host (client) [ |dispose ] dip ] keep
  59         addrspec>> host>> pick handle>> check-certificate
  60     ] with-destructors ;
  61
  62 PRIVATE>
  63
  64 ERROR: premature-close ;
  65
  66 M: premature-close summary
  67     drop "Connection closed prematurely - potential truncation attack" ;
  68
  69 ERROR: certificate-verify-error result ;
  70
  71 M: certificate-verify-error summary
  72     drop "Certificate verification failed" ;
  73
  74 ERROR: common-name-verify-error expected got ;
  75
  76 M: common-name-verify-error summary
  77     drop "Common name verification failed" ;