Merge pull request #1129 from triska/tls_servers

ADDED: Support for creating TLS servers.

README.md

@@ -539,6 +539,8 @@ The modules that ship with Scryer Prolog are also called
   Predicates for opening and accepting TCP connections as streams.
   TLS negotiation is performed via the option `tls(true)` in
   `socket_client_open/3`, yielding secure encrypted connections.
+  TLS *servers* can be created with `tls_server_context/2` and
+  `tls_server_negotiate/3`.
 * [`os`](src/lib/os.pl)
   Predicates for reasoning about environment variables.
 * [`iso_ext`](src/lib/iso_ext.pl)

src/clause_types.rs

@@ -273,6 +273,7 @@ pub(crate) enum SystemClauseType {
     SocketServerOpen,
     SocketServerAccept,
     SocketServerClose,
+    TLSAcceptClient,
     Succeed,
     TermAttributedVariables,
     TermVariables,
@@ -563,6 +564,7 @@ impl SystemClauseType {
             &SystemClauseType::SocketServerOpen => clause_name!("$socket_server_open"),
             &SystemClauseType::SocketServerAccept => clause_name!("$socket_server_accept"),
             &SystemClauseType::SocketServerClose => clause_name!("$socket_server_close"),
+            &SystemClauseType::TLSAcceptClient => clause_name!("$tls_accept_client"),
             &SystemClauseType::Succeed => clause_name!("$succeed"),
             &SystemClauseType::TermAttributedVariables => {
                 clause_name!("$term_attributed_variables")
@@ -744,6 +746,7 @@ impl SystemClauseType {
             ("$socket_server_open", 3) => Some(SystemClauseType::SocketServerOpen),
             ("$socket_server_accept", 7) => Some(SystemClauseType::SocketServerAccept),
             ("$socket_server_close", 1) => Some(SystemClauseType::SocketServerClose),
+            ("$tls_accept_client", 4) => Some(SystemClauseType::TLSAcceptClient),
             ("$store_global_var", 2) => Some(SystemClauseType::StoreGlobalVar),
             ("$store_backtrackable_global_var", 2) => {
                 Some(SystemClauseType::StoreBacktrackableGlobalVar)

src/lib/sockets.pl

@@ -3,11 +3,16 @@
                     socket_server_open/2,
                     socket_server_accept/4,
                     socket_server_close/1,
+                    tls_server_context/2,       % tls_server_context(-Context, +Options)
+                    tls_server_negotiate/3,     % tls_server_negotiate(+Context, +Stream0, -Stream)
                     current_hostname/1]).
 
 :- use_module(library(error)).
 :- use_module(library(lists)).
 
+% a client can negotiate a TLS connection by specifying the option
+% tls(true) in socket_client_open/3
+
 parse_socket_options_(tls(TLS), tls-TLS) :-
     must_be(boolean, TLS), !.
 parse_socket_options_(Option, OptionPair) :-
@@ -65,3 +70,65 @@ socket_server_close(ServerSocket) :-
 
 current_hostname(HostName) :-
     '$current_hostname'(HostName).
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+   TLS Servers
+   ===========
+
+   Use tls_server_context/2 to create a TLS context, for example with:
+
+   tls_server_context(Context, [pkcs12(Chars)])
+
+   where Chars is a list of characters with the contents of a
+   DER-formatted PKCS #12 archive. The option password(Ps) can be used
+   to specify the password Ps (also a string) for decrypting the key.
+   On some versions of OSX, and potentially also on other platforms,
+   empty passwords are not supported.
+
+   The archive should contain a leaf certificate and its private key,
+   as well any intermediate certificates that should be sent to
+   clients to allow them to build a chain to a trusted root. The chain
+   certificates should be in order from the leaf certificate towards
+   the root.
+
+   PKCS #12 archives typically have the file extension .p12 or .pfx,
+   and can be created with the OpenSSL pkcs12 tool:
+
+   $ openssl pkcs12 -export -out identity.pfx \
+                    -inkey key.pem -in cert.pem -certfile chain_certs.pem
+
+
+   You can use phrase_from_file/3 from library(pio) and seq//1 from
+   library(dcgs) to read the contents of "identity.pfx" into a string:
+
+   phrase_from_file(seq(Chars), "identity.pfx", [type(binary)])
+
+   The obtained context should be treated as an opaque Prolog term.
+
+   Using the context and an existing stream S0 (for example, the
+   result of socket_server_accept/4), a TLS stream S can be negotiated
+   by a Prolog-based server with:
+
+   tls_server_negotiate(Context, S0, S)
+
+   S will be an encrypted and authenticated stream with the client.
+
+   The advantage of separating the creation of the server context from
+   negotiating a connection is that the context can be created only
+   once, and quickly cloned for every incoming connection. This is
+   currently not implemented: In the present implementation, a new context
+   is created for every connection, using the specified parameters.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+tls_server_context(tls_context(Cert,Password), Options) :-
+        (   member(pcks12(Cert), Options) ->
+            must_be(chars, Cert)
+        ;   domain_error(contains_pcks12, Options, tls_server_context/2)
+        ),
+        (   member(password(Password), Options) ->
+            must_be(chars, Password)
+        ;   Password = ""
+        ).
+
+tls_server_negotiate(tls_context(Cert,Password), S0, S) :-
+        '$tls_accept_client'(Cert, Password, S0, S).

src/machine/streams.rs

@@ -117,7 +117,7 @@ enum StreamInstance {
     Stderr,
     Stdout,
     TcpStream(ClauseName, TcpStream),
-    TlsStream(ClauseName, TlsStream<TcpStream>),
+    TlsStream(ClauseName, TlsStream<Stream>),
 }
 
 impl StreamInstance {
@@ -543,7 +543,7 @@ impl Stream {
     }
 
     #[inline]
-    pub(crate) fn from_tls_stream(address: ClauseName, tls_stream: TlsStream<TcpStream>) -> Self {
+    pub(crate) fn from_tls_stream(address: ClauseName, tls_stream: TlsStream<Stream>) -> Self {
         Stream::from_inst(StreamInstance::TlsStream(address, tls_stream))
     }
 

src/machine/system_calls.rs

@@ -65,7 +65,7 @@ use openssl::nid::Nid;
 
 use sodiumoxide::crypto::scalarmult::curve25519::*;
 
-use native_tls::TlsConnector;
+use native_tls::{TlsConnector,TlsAcceptor,Identity};
 
 use base64;
 use roxmltree;
@@ -4194,8 +4194,9 @@ impl MachineState {
                                 "false" => Stream::from_tcp_stream(socket_addr, tcp_stream),
                                 "true" => {
                                     let connector = TlsConnector::new().unwrap();
+                                    let stream = Stream::from_tcp_stream(socket_addr, tcp_stream);
                                     let stream =
-                                        match connector.connect(socket_atom.as_str(), tcp_stream) {
+                                        match connector.connect(socket_atom.as_str(), stream) {
                                             Ok(tls_stream) => tls_stream,
                                             Err(_) => {
                                                 return Err(self.open_permission_error(
@@ -4206,7 +4207,8 @@ impl MachineState {
                                             }
                                         };
 
-                                    Stream::from_tls_stream(socket_addr, stream)
+                                    let addr = clause_name!("TLS".to_string(), self.atom_tbl);
+                                    Stream::from_tls_stream(addr, stream)
                                 }
                                 _ => {
                                     unreachable!()
@@ -4416,6 +4418,49 @@ impl MachineState {
                     }
                 }
             }
+            &SystemClauseType::TLSAcceptClient => {
+                let pkcs12 = self.string_encoding_bytes(1, "octet");
+                let password = self.heap_pstr_iter(self[temp_v!(2)]).to_string();
+                let identity =
+                    match Identity::from_pkcs12(&pkcs12, &password) {
+                        Ok(identity) => identity,
+                        Err(_) => {
+                            return Err(self.open_permission_error(
+                                self[temp_v!(1)],
+                                "tls_server_negotiate",
+                                3,
+                            ));
+                        }
+                    };
+
+                let stream0 = self.get_stream_or_alias(
+                    self[temp_v!(3)],
+                    &indices.stream_aliases,
+                    "tls_server_negotiate",
+                    3,
+                )?;
+
+                let acceptor = TlsAcceptor::new(identity).unwrap();
+
+                let stream =
+                    match acceptor.accept(stream0) {
+                        Ok(tls_stream) => tls_stream,
+                        Err(_) => {
+                            return Err(self.open_permission_error(
+                                self[temp_v!(3)],
+                                "tls_server_negotiate",
+                                3,
+                            ));
+                        }
+                    };
+                let addr = clause_name!("TLS".to_string(), self.atom_tbl);
+                let stream = Stream::from_tls_stream(addr, stream);
+                indices.streams.insert(stream.clone());
+
+                let stream = self.heap.to_unifiable(HeapCellValue::Stream(stream));
+                let stream_addr = self.store(self.deref(self[temp_v!(4)]));
+                self.bind(stream_addr.as_var().unwrap(), stream);
+            }
             &SystemClauseType::SetStreamPosition => {
                 let mut stream = self.get_stream_or_alias(
                     self[temp_v!(1)],