130 lines
3.2 KiB
Factor
130 lines
3.2 KiB
Factor
! Copyright (C) 2008, 2010 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors alien.libraries calendar combinators delegate
|
|
destructors io io.sockets io.sockets.private kernel memoize
|
|
namespaces present sequences summary system vocabs ;
|
|
IN: io.sockets.secure
|
|
|
|
SYMBOL: secure-socket-timeout
|
|
|
|
1 minutes secure-socket-timeout set-global
|
|
|
|
SYMBOL: secure-socket-backend
|
|
|
|
HOOK: ssl-supported? secure-socket-backend ( -- ? )
|
|
HOOK: ssl-certificate-verification-supported? secure-socket-backend ( -- ? )
|
|
|
|
M: object ssl-supported? f ;
|
|
M: object ssl-certificate-verification-supported? f ;
|
|
|
|
SINGLETONS: TLSv1 TLSv1.1 TLSv1.2 ;
|
|
|
|
ERROR: no-tls-supported ;
|
|
|
|
MEMO: best-tls-method ( -- class )
|
|
{
|
|
{ [ "TLSv1_2_method" "libssl" dlsym? ] [ TLSv1.2 ] }
|
|
{ [ "TLSv1_1_method" "libssl" dlsym? ] [ TLSv1.1 ] }
|
|
{ [ "TLSv1_method" "libssl" dlsym? ] [ TLSv1 ] }
|
|
[ no-tls-supported ]
|
|
} cond ;
|
|
|
|
TUPLE: secure-config
|
|
method
|
|
key-file password
|
|
verify
|
|
verify-depth
|
|
ca-file ca-path
|
|
dh-file
|
|
ephemeral-key-bits ;
|
|
|
|
: <secure-config> ( -- config )
|
|
secure-config new
|
|
best-tls-method >>method
|
|
1024 >>ephemeral-key-bits
|
|
ssl-certificate-verification-supported? >>verify ;
|
|
|
|
TUPLE: secure-context < disposable config handle ;
|
|
|
|
HOOK: <secure-context> secure-socket-backend ( config -- context )
|
|
|
|
: with-secure-context ( config quot -- )
|
|
[
|
|
[ <secure-context> ] [ [ secure-context set ] prepose ] bi*
|
|
with-disposal
|
|
] with-scope ; inline
|
|
|
|
TUPLE: secure
|
|
{ addrspec read-only }
|
|
{ hostname read-only } ;
|
|
|
|
C: <secure> secure
|
|
|
|
M: secure present addrspec>> present " (secure)" append ;
|
|
|
|
CONSULT: inet secure addrspec>> ;
|
|
|
|
M: secure resolve-host ( secure -- seq )
|
|
[ addrspec>> resolve-host ] [ hostname>> ] bi
|
|
[ <secure> ] curry map ;
|
|
|
|
HOOK: check-certificate secure-socket-backend ( host handle -- )
|
|
|
|
PREDICATE: secure-inet < secure addrspec>> inet? ;
|
|
|
|
<PRIVATE
|
|
|
|
M: secure-inet (client)
|
|
[
|
|
[ resolve-host (client) [ |dispose ] dip ] keep
|
|
addrspec>> host>> pick handle>> check-certificate
|
|
] with-destructors ;
|
|
|
|
PRIVATE>
|
|
|
|
ERROR: premature-close ;
|
|
|
|
M: premature-close summary
|
|
drop "Connection closed prematurely - potential truncation attack" ;
|
|
|
|
ERROR: certificate-verify-error result ;
|
|
|
|
M: certificate-verify-error summary
|
|
drop "Certificate verification failed" ;
|
|
|
|
ERROR: subject-name-verify-error expected got ;
|
|
|
|
M: subject-name-verify-error summary
|
|
drop "Subject name verification failed" ;
|
|
|
|
ERROR: certificate-missing-error ;
|
|
|
|
M: certificate-missing-error summary
|
|
drop "Host did not present any certificate" ;
|
|
|
|
ERROR: upgrade-on-non-socket ;
|
|
|
|
M: upgrade-on-non-socket summary
|
|
drop
|
|
"send-secure-handshake can only be used if input-stream and" print
|
|
"output-stream are a socket" ;
|
|
|
|
ERROR: upgrade-buffers-full ;
|
|
|
|
M: upgrade-buffers-full summary
|
|
drop
|
|
"send-secure-handshake can only be used if buffers are empty" ;
|
|
|
|
HOOK: non-ssl-socket? os ( obj -- ? )
|
|
|
|
HOOK: socket-handle os ( obj -- ? )
|
|
|
|
HOOK: send-secure-handshake secure-socket-backend ( -- )
|
|
|
|
HOOK: accept-secure-handshake secure-socket-backend ( -- )
|
|
|
|
{
|
|
{ [ os unix? ] [ "io.sockets.secure.unix" require ] }
|
|
{ [ os windows? ] [ "io.sockets.secure.windows" require ] }
|
|
} cond
|