Add SNI support to Factor

Fixes #1527

diff --git a/basis/io/servers/servers.factor b/basis/io/servers/servers.factor
index a2911b1f2cb5496e89ae6bbcc5f480273bbef423..af1923ddde7fcde6ec62ba8e2c45e5347221e201 100755 (executable)
--- a/basis/io/servers/servers.factor
+++ b/basis/io/servers/servers.factor
@@ -81,7 +81,7 @@ M: array >insecure [ >insecure ] map ;
 M: f >insecure ;
 
 : >secure ( addrspec -- addrspec' )
-    >insecure [ dup secure? [ <secure> ] unless ] map ;
+    >insecure [ dup secure? [ f <secure> ] unless ] map ;
 
 : configurable-addrspecs ( addrspecs -- addrspecs' )
     [ inet6? not ipv6-supported? or ] filter ;
@@ -230,7 +230,7 @@ M: inet4 connect-addr [ "127.0.0.1" ] dip port>> <inet4> ;
 
 M: inet6 connect-addr [ "::1" ] dip port>> <inet6> ;
 
-M: secure connect-addr addrspec>> connect-addr <secure> ;
+M: secure connect-addr addrspec>> connect-addr f <secure> ;
 
 M: local connect-addr ;
 

diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor
index e2f169997a3e888fd3c4c61a6582f04775e4c086..b87e3951c9258c648d2661aebf16f9073627ac33 100644 (file)
--- a/basis/io/sockets/secure/openssl/openssl.factor
+++ b/basis/io/sockets/secure/openssl/openssl.factor
@@ -171,11 +171,16 @@ SYMBOL: default-secure-context
         swap >>file
     ] with-destructors ;
 
-: <ssl-socket> ( winsock -- ssl )
-    [
-        socket-handle BIO_NOCLOSE BIO_new_socket dup ssl-error
-    ] keep <ssl-handle>
-    [ handle>> swap dup SSL_set_bio ] keep ;
+:: <ssl-socket> ( winsock hostname -- ssl )
+    winsock socket-handle BIO_NOCLOSE BIO_new_socket dup ssl-error :> bio
+    winsock <ssl-handle> :> handle
+    handle handle>> :> native-handle
+    hostname [
+        utf8 string>alien
+        native-handle swap SSL_set_tlsext_host_name ssl-error
+    ] when*
+    native-handle bio bio SSL_set_bio
+    handle ;
 
 ! Error handling
 : syscall-error ( r -- event )
@@ -330,7 +335,7 @@ M: openssl check-certificate ( host ssl -- )
 
 : make-input/output-secure ( input output -- )
     dup handle>> non-ssl-socket? [ upgrade-on-non-socket ] unless
-    [ <ssl-socket> ] change-handle
+    [ f <ssl-socket> ] change-handle
     handle>> >>handle drop ;
 
 : (send-secure-handshake) ( output -- )

diff --git a/basis/io/sockets/secure/secure-docs.factor b/basis/io/sockets/secure/secure-docs.factor
index fdf2503d56c1b310500bf58ca02c75368fbff752..fe911466d9fbe25143a15bf1bafcc107696d72e1 100644 (file)
--- a/basis/io/sockets/secure/secure-docs.factor
+++ b/basis/io/sockets/secure/secure-docs.factor
@@ -1,4 +1,4 @@
-USING: io help.markup help.syntax calendar quotations io.sockets ;
+USING: io help.markup help.syntax calendar quotations strings io.sockets ;
 IN: io.sockets.secure
 
 HELP: secure-socket-timeout
@@ -74,7 +74,7 @@ HELP: secure
 { $class-description "The class of secure socket addresses." } ;
 
 HELP: <secure>
-{ $values { "addrspec" "an address specifier" } { "secure" secure } }
+{ $values { "addrspec" "an address specifier" } { "hostname" { $maybe string } } { "secure" secure } }
 { $description "Creates a new secure socket address, which can then be passed to " { $link <client> } " or " { $link <server> } "." } ;
 
 ARTICLE: "ssl-addresses" "Secure socket addresses"

diff --git a/basis/io/sockets/secure/secure-tests.factor b/basis/io/sockets/secure/secure-tests.factor
index d591ac15e7bd532397e243ac4d8cacc9d08c4720..65ca8abcd1a91fb8165a255fe4c47e59f7a4453d 100644 (file)
--- a/basis/io/sockets/secure/secure-tests.factor
+++ b/basis/io/sockets/secure/secure-tests.factor
@@ -2,7 +2,7 @@ IN: io.sockets.secure.tests
 USING: accessors io.sockets io.sockets.secure io.sockets.secure.debug
 kernel system tools.test ;
 
-{ "hello" 24 } [ "hello" 24 <inet> <secure> [ host>> ] [ port>> ] bi ] unit-test
+{ "hello" 24 } [ "hello" 24 <inet> "hello" <secure> [ host>> ] [ port>> ] bi ] unit-test
 
 { } [
     <test-secure-config> [ ] with-secure-context

diff --git a/basis/io/sockets/secure/secure.factor b/basis/io/sockets/secure/secure.factor
index 8f4678fd6c1f011864cfa028194b9ec0d92755a1..2ef50a07a13df0e45c91b4a1a5e9c4a32f1950f2 100644 (file)
--- a/basis/io/sockets/secure/secure.factor
+++ b/basis/io/sockets/secure/secure.factor
@@ -44,7 +44,9 @@ HOOK: <secure-context> secure-socket-backend ( config -- context )
         with-disposal
     ] with-scope ; inline
 
-TUPLE: secure { addrspec read-only } ;
+TUPLE: secure
+    { addrspec read-only }
+    { hostname read-only } ;
 
 C: <secure> secure
 
@@ -53,7 +55,8 @@ M: secure present addrspec>> present " (secure)" append ;
 CONSULT: inet secure addrspec>> ;
 
 M: secure resolve-host ( secure -- seq )
-    addrspec>> resolve-host [ <secure> ] map ;
+    [ addrspec>> resolve-host ] [ hostname>> ] bi
+    [ <secure> ] curry map ;
 
 HOOK: check-certificate secure-socket-backend ( host handle -- )
 

diff --git a/basis/io/sockets/secure/unix/unix-tests.factor b/basis/io/sockets/secure/unix/unix-tests.factor
index 6611c854fc68a3327376e151d641f571b0a65ec5..6d06db2c4f6dc040616e7b940940be41ddc1e121 100644 (file)
--- a/basis/io/sockets/secure/unix/unix-tests.factor
+++ b/basis/io/sockets/secure/unix/unix-tests.factor
@@ -12,7 +12,7 @@ io.sockets.secure.debug ;
 :: server-test ( quot -- )
     [
         [
-            "127.0.0.1" 0 <inet4> <secure> ascii <server> [
+            "127.0.0.1" 0 <inet4> f <secure> ascii <server> [
                 dup addr>> addrspec>> port>> "port" get fulfill
                 accept [
                     quot call
@@ -23,7 +23,7 @@ io.sockets.secure.debug ;
 
 : client-test ( -- string )
     <secure-config> [
-        "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop stream-contents
+        "127.0.0.1" "port" get ?promise <inet4> f <secure> ascii <client> drop stream-contents
     ] with-secure-context ;
 
 { } [ [ class-of name>> write ] server-test ] unit-test
@@ -55,7 +55,7 @@ io.sockets.secure.debug ;
 
 [
     <secure-config> [
-        "localhost" "port" get ?promise <inet> <secure> ascii
+        "localhost" "port" get ?promise <inet> f <secure> ascii
         <client> drop dispose
     ] with-secure-context
 ] [ certificate-verify-error? ] must-fail-with
@@ -95,7 +95,7 @@ io.sockets.secure.debug ;
     1 seconds secure-socket-timeout [
         [
             [
-                "127.0.0.1" 0 <inet4> <secure> ascii <server> [
+                "127.0.0.1" 0 <inet4> f <secure> ascii <server> [
                     dup addr>> addrspec>> port>> "port" get fulfill
                     accept drop &dispose dup stream-read1 drop
                 ] with-disposal
@@ -114,7 +114,7 @@ io.sockets.secure.debug ;
         [
             [
                 [
-                    "127.0.0.1" 0 <inet4> <secure> ascii <server> [
+                    "127.0.0.1" 0 <inet4> f <secure> ascii <server> [
                         dup addr>> addrspec>> port>> "port" get fulfill
                         accept drop &dispose 1 minutes sleep
                     ] with-disposal
@@ -126,7 +126,7 @@ io.sockets.secure.debug ;
     [
         1 seconds secure-socket-timeout [
             <secure-config> [
-                "127.0.0.1" "port" get ?promise <inet4> <secure>
+                "127.0.0.1" "port" get ?promise <inet4> f <secure>
                 ascii <client> drop dispose
             ] with-secure-context
         ] with-variable
@@ -140,7 +140,7 @@ io.sockets.secure.debug ;
             [
                 [
                     "127.0.0.1" "port" get ?promise
-                    <inet4> <secure> ascii <client> drop &dispose 1 minutes sleep
+                    <inet4> f <secure> ascii <client> drop &dispose 1 minutes sleep
                 ] with-test-context
             ] with-destructors
         ] "Silly client" spawn drop
@@ -150,7 +150,7 @@ io.sockets.secure.debug ;
         [
             1 seconds secure-socket-timeout [
                 [
-                    "127.0.0.1" 0 <inet4> <secure> ascii <server> [
+                    "127.0.0.1" 0 <inet4> f <secure> ascii <server> [
                         dup addr>> addrspec>> port>> "port" get fulfill
                         accept drop &dispose
                     ] with-disposal

diff --git a/basis/io/sockets/secure/unix/unix.factor b/basis/io/sockets/secure/unix/unix.factor
index 8ccc61a63afbdd322b71e9d89da0cb942f3903bf..e1c5a5032a2778936b00665393f9947cd1dd5476 100644 (file)
--- a/basis/io/sockets/secure/unix/unix.factor
+++ b/basis/io/sockets/secure/unix/unix.factor
@@ -14,10 +14,10 @@ M: ssl-handle handle-fd file>> handle-fd ;
 
 M: unix socket-handle fd>> ;
 
-M: secure ((client)) ( addrspec -- handle )
-    addrspec>> ((client)) <ssl-socket> ;
+M: secure ((client)) ( secure -- handle )
+    [ addrspec>> ((client)) ] [ hostname>> ] bi <ssl-socket> ;
 
-M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
+M: secure parse-sockaddr addrspec>> parse-sockaddr f <secure> ;
 
 M: secure (get-local-address) addrspec>> (get-local-address) ;
 
@@ -28,7 +28,8 @@ M: secure (server) addrspec>> (server) ;
 
 M: secure (accept)
     [
-        addrspec>> (accept) [ |dispose <ssl-socket> ] dip
+        [ hostname>> ] [ addrspec>> ] bi (accept)
+        [ |dispose <ssl-socket> ] dip
     ] with-destructors ;
 
 : check-shutdown-response ( handle r -- event )

diff --git a/basis/io/sockets/secure/windows/windows.factor b/basis/io/sockets/secure/windows/windows.factor
index 95525a170e5d759be819a5a79ec8d471d361a08a..af39da72b708293c1211942ac49666a342803c2a 100644 (file)
--- a/basis/io/sockets/secure/windows/windows.factor
+++ b/basis/io/sockets/secure/windows/windows.factor
@@ -14,7 +14,7 @@ M: secure ((client)) ( addrspec -- handle )
 M: secure (get-local-address) ( handle remote -- sockaddr )
     [ file>> ] [ addrspec>> ] bi* (get-local-address) ;
 
-M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
+M: secure parse-sockaddr addrspec>> parse-sockaddr f <secure> ;
 
 M:: secure establish-connection ( client-out addrspec -- )
     client-out handle>> file>> :> socket

diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor
index 8393a3eb6cb67bc26722fbdbef2445acc8aee3ad..e9c101dc6f44e0523ac1c8cee92e7c8d458b1287 100644 (file)
--- a/basis/openssl/libssl/libssl.factor
+++ b/basis/openssl/libssl/libssl.factor
@@ -392,7 +392,6 @@ FUNCTION: int SSL_connect ( SSL* ssl )
 FUNCTION: int SSL_read ( SSL* ssl, void* buf, int num )
 FUNCTION: int SSL_write ( SSL* ssl, void* buf, int num )
 FUNCTION: long SSL_ctrl ( SSL* ssl, int cmd, long larg, void* parg )
-! FUNCTION: long SSL_callback_ctrl ( SSL* ssl, int cmd, long larg, void* parg )
 
 FUNCTION: int SSL_shutdown ( SSL* ssl )
 
@@ -468,6 +467,10 @@ FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( SSL_CTX* ctx, void* rsa )
 
 FUNCTION: void* BIO_f_ssl (  )
 
+: SSL_set_tlsext_host_name ( ctx hostname -- n )
+    [ SSL_CTRL_SET_TLSEXT_HOSTNAME TLSEXT_NAMETYPE_host_name ] dip
+    SSL_ctrl ;
+
 : SSL_CTX_need_tmp_rsa ( ctx -- n )
     SSL_CTRL_NEED_TMP_RSA 0 f SSL_CTX_ctrl ;
 

diff --git a/basis/urls/secure/secure.factor b/basis/urls/secure/secure.factor
index 1c9b92564128b203b15c15d9fcbdb598c36b030f..6961a8ec2592997413f86bbc71553fef581c05d1 100644 (file)
--- a/basis/urls/secure/secure.factor
+++ b/basis/urls/secure/secure.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: urls urls.private io.sockets io.sockets.secure ;
+USING: kernel urls urls.private io.sockets io.sockets.secure ;
 IN: urls.secure
 
 UNION: abstract-inet inet inet4 inet6 ;

diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor
index f50e3ee9e0cbc80163e04fdab679aa1538284704..1d52fc5adf5edc9b5af826998cd94d7499d5973c 100644 (file)
--- a/basis/urls/urls.factor
+++ b/basis/urls/urls.factor
@@ -172,7 +172,7 @@ PRIVATE>
 
 <PRIVATE
 
-GENERIC: >secure-addr ( addrspec -- addrspec' )
+GENERIC# >secure-addr 1 ( addrspec host -- addrspec' )
 
 PRIVATE>
 
@@ -182,8 +182,10 @@ PRIVATE>
         [ port>> ]
         [ protocol>> protocol-port ]
         tri or <inet>
-    ] [ protocol>> ] bi
-    secure-protocol? [ >secure-addr ] when ;
+    ]
+    [ host>> ]
+    [ protocol>> ] tri
+    secure-protocol? [ >secure-addr ] [ drop ] if ;
 
 : set-url-addr ( url addr -- url )
     [ host>> >>host ] [ port>> >>port ] bi ;

diff --git a/extra/imap/imap.factor b/extra/imap/imap.factor
index 2436af9b322c926ca84e28ef20daa71015fe1e76..e3a9b4fc4bc456081f74de082fceda25d0cf648e 100644 (file)
--- a/extra/imap/imap.factor
+++ b/extra/imap/imap.factor
@@ -108,7 +108,7 @@ PRIVATE>
 
 ! Constructor
 : <imap4ssl> ( host -- imap4 )
-    IMAP4_SSL_PORT <inet> <secure> binary <client> drop
+    IMAP4_SSL_PORT <inet> f <secure> binary <client> drop
     ! Read the useless welcome message.
     dup [ "\\*" read-response drop ] with-stream* ;