feat: SSL for client and socket servers

dune-project

@@ -21,6 +21,8 @@
   "Riot is an actor-model multi-core scheduler for OCaml 5. It brings Erlang-style concurrency to the language, where lighweight process communicate via message passing")
  (depends
   (cstruct (>= "6.2.0"))
+  (x509 (and :with-test (>= "0.16.5")))
+  (castore (and :with-test (>= "0.0.2")))
   (mdx (and :with-test (>= "2.3.1")))
   (ocaml (>= "5.1"))
   (odoc (and :with-doc (>= "2.2.2")))

riot.opam

@@ -11,6 +11,8 @@ homepage: "https://github.com/leostera/riot"
 bug-reports: "https://github.com/leostera/riot/issues"
 depends: [
   "cstruct" {>= "6.2.0"}
+  "x509" {with-test & >= "0.16.5"}
+  "castore" {with-test & >= "0.0.2"}
   "mdx" {with-test & >= "2.3.1"}
   "ocaml" {>= "5.1"}
   "odoc" {with-doc & >= "2.2.2"}

riot/lib/ssl.ml

@@ -44,9 +44,10 @@ type 'src t = {
   recv_buf : Cstruct.t;
 }
 
+exception Tls_alert of Tls.Packet.alert_type
+exception Tls_failure of Tls.Engine.failure
+
 module Tls_unix = struct
-  exception Tls_alert of Tls.Packet.alert_type
-  exception Tls_failure of Tls.Engine.failure
   exception Read_error of [ `Closed | `Eof | `Unix_error of Unix.error ]
   exception Write_error of [ `Closed | `Eof | `Unix_error of Unix.error ]
 
@@ -173,7 +174,7 @@ module Tls_unix = struct
         push_linger t cs;
         drain_handshake t
 
-  let make ?host ~reader ~writer config =
+  let make_client ?host ~reader ~writer config =
     let config' =
       match host with
       | None -> config
@@ -193,6 +194,18 @@ module Tls_unix = struct
     write_t t init;
     drain_handshake t
 
+  let make_server ~reader ~writer config =
+    let t =
+      {
+        state = `Active (Tls.Engine.server config);
+        writer;
+        reader;
+        linger = None;
+        recv_buf = Cstruct.create 4_096;
+      }
+    in
+    drain_handshake t
+
   let to_reader : type src. src t -> src t IO.Reader.t =
    fun t ->
     let module Read = IO.Reader.Make (struct
@@ -219,7 +232,12 @@ module Tls_unix = struct
     IO.Writer.of_write_src (module Write) t
 end
 
-let of_socket ?host ~auth sock =
-  let reader, writer = (Net.Socket.to_reader sock, Net.Socket.to_writer sock) in
-  let tls = Tls_unix.make ?host ~reader ~writer auth in
-  (Tls_unix.to_reader tls, Tls_unix.to_writer tls)
+let of_server_socket ?(config = Tls.Config.server ()) sock =
+  let reader, writer = Net.Socket.(to_reader sock, to_writer sock) in
+  let tls = Tls_unix.make_server ~reader ~writer config in
+  Tls_unix.(to_reader tls, to_writer tls)
+
+let of_client_socket ?host ~config sock =
+  let reader, writer = Net.Socket.(to_reader sock, to_writer sock) in
+  let tls = Tls_unix.make_client ?host ~reader ~writer config in
+  Tls_unix.(to_reader tls, to_writer tls)

riot/riot.mli

@@ -601,9 +601,18 @@ end
 module SSL : sig
   type 'src t
 
-  val of_socket :
+  exception Tls_alert of Tls.Packet.alert_type
+  exception Tls_failure of Tls.Engine.failure
+
+  val of_server_socket :
+    ?config:Tls.Config.server ->
+    Net.Socket.stream_socket ->
+    Net.Socket.stream_socket t IO.Reader.t
+    * Net.Socket.stream_socket t IO.Writer.t
+
+  val of_client_socket :
     ?host:[ `host ] Domain_name.t ->
-    auth:Tls.Config.client ->
+    config:Tls.Config.client ->
     Net.Socket.stream_socket ->
     Net.Socket.stream_socket t IO.Reader.t
     * Net.Socket.stream_socket t IO.Writer.t

test/dune

@@ -1,3 +1,9 @@
+(test
+ (name ssl_test)
+ (modules ssl_test)
+ (deps fixtures/tls.crt fixtures/tls.key)
+ (libraries riot x509 mirage-crypto-rng mirage-crypto-rng.unix))
+
 (test
  (name io_copy_buffered_test)
  (enabled_if

test/fixtures/tls.crt

@@ -0,0 +1,31 @@
+-----BEGIN CERTIFICATE-----
+MIIFSzCCAzOgAwIBAgIUDqxfiGDtqNRUH4jtEy/0rzWRlOkwDQYJKoZIhvcNAQEL
+BQAwNTESMBAGA1UEAwwJbG9jYWxob3N0MQswCQYDVQQGEwJTRTESMBAGA1UEBwwJ
+U3RvY2tob2xtMB4XDTIzMTIyNzAyMTczN1oXDTMzMTIyNDAyMTczN1owNTESMBAG
+A1UEAwwJbG9jYWxob3N0MQswCQYDVQQGEwJTRTESMBAGA1UEBwwJU3RvY2tob2xt
+MIICIjANBgkqhkiG9w0BAQEFAAOCAg8AMIICCgKCAgEAx9Z2zhjg5SyUX85WMkhs
+kajgRR5bqGKPhqglbdtslxwG4lgL6tzPWAEJ0i9L2vBkdGNg27EdwFrui3VJYjRe
+5T8w2h83hQ8P4IEq2LEhuhFHEeC7DSf11dESFZ/HEa9am6d3Xv0qAdg+5S1GSmjU
+1eBx53o2jlQc2eEcZ8488Nf/+61MDufKZDr1yCOXzudXJO+O41h+S7I1XSVPlN7r
+ouRq5U+e37GoRdTnuyLIQ1XnHgXELNwG1LKDJstdsOwl6Z7o1Mtb/R3Ja+3YHwfW
+pDNyt0a8WAPPM6bzMFNjCml+8h1SfBX7uYEz9PTxY9WYLyy/Dg9Vwi6qnlkG8XbL
+yYCV4sg/IRXy32kg3mHZd10rcKbJp7Jx4nZ25teg8/s9WEIz64CfPvyapS3PIJbl
+nwPzsi6G2MDy1ZM6J9OlFpAAu2kjvocs9dwmiVutHEWGyJ2VN5ykV5NgPzd0p+x+
+C4kQGie/engXwgM7Xz20zmJk4Atfe7r8FTxD6lwuGGdSG4nVZy+ugodXWLUq7ROi
+DM4cxTgq1ZEydoXTvCQ6Vds5mcA/hBZjggkXpyqRuUFKTMsL+FF9nMRtA2IwKXlg
+5VNiXNS+p2oW7z75SOoKJtK5G7EwOMxv3OCdSqCSK1Qd4Rz4a6E9McxbmV99J838
+RKOwocMXiv6VMsVC6+tuyfUCAwEAAaNTMFEwHQYDVR0OBBYEFOneKxyRtEPYqcc1
+iCD+bCZmXg0/MB8GA1UdIwQYMBaAFOneKxyRtEPYqcc1iCD+bCZmXg0/MA8GA1Ud
+EwEB/wQFMAMBAf8wDQYJKoZIhvcNAQELBQADggIBAJ/mACwlugqWYMjLO2JjUGe0
+NMTCrvelfZI+GIJXZJj5zWHNng5XpcJ+kTtG5nm763RbWs6Whl7fqScel06fwoD7
+oYQ1GOE4boCwo0rA8cGtxKOAmkAx+LPuo+Id2pYQTT9SR6GvngaBhvY6gbbaWOkp
+jk6vlrUGXd0lP7TtwH8j1ijewKQBpEEAuZOP17R9r9R6j9e3qvrqIMP9s6Cr0wLW
+PMQaPPHV0priuQyMq1B4EIAZKqXVL4E6r+YW/hOl3MiU7XTyxjY2xfT50S7Q/Es5
+Hl7c9dZDGzs8CnObOPqRUTGkQjKGWpDajQp1+h44wqwoIEgHrmKQArK5yrAgYqhj
+MP3hy1MqYaIPkHBn1q7p6SJVdp3WWVhU6MhwgcKFF5W13MBOvunhqscVq1nhbMoq
+kGWYNFoP/Ocbjfex1pnxPTxZWcXNWVa/jHBorwiOPYw2vcktz2CJlxKpAVrDrJzE
+Tr0shvWuqDqqZdlLmTH61VMPCj+H0cJnqmaDPf1utq6nD8oAyrVocI88brIeloWg
+Kjla/4Nt1pqlg47hmgWzS8a4WFsUMICWWOcqDiPh6qFQlqyt0TE5kjlK1odUrfG9
+/oaMUlOgg7VI4zkAetp4mqjHdQ9EQsgr7gCeaohFO27pgiOwf9fC58Td9g01Q9Mr
+KXM1CjcPdn+GO3MMPZFe
+-----END CERTIFICATE-----

test/fixtures/tls.key

@@ -0,0 +1,52 @@
+-----BEGIN PRIVATE KEY-----
+MIIJQwIBADANBgkqhkiG9w0BAQEFAASCCS0wggkpAgEAAoICAQDH1nbOGODlLJRf
+zlYySGyRqOBFHluoYo+GqCVt22yXHAbiWAvq3M9YAQnSL0va8GR0Y2DbsR3AWu6L
+dUliNF7lPzDaHzeFDw/ggSrYsSG6EUcR4LsNJ/XV0RIVn8cRr1qbp3de/SoB2D7l
+LUZKaNTV4HHnejaOVBzZ4Rxnzjzw1//7rUwO58pkOvXII5fO51ck747jWH5LsjVd
+JU+U3uui5GrlT57fsahF1Oe7IshDVeceBcQs3AbUsoMmy12w7CXpnujUy1v9Hclr
+7dgfB9akM3K3RrxYA88zpvMwU2MKaX7yHVJ8Ffu5gTP09PFj1ZgvLL8OD1XCLqqe
+WQbxdsvJgJXiyD8hFfLfaSDeYdl3XStwpsmnsnHidnbm16Dz+z1YQjPrgJ8+/Jql
+Lc8gluWfA/OyLobYwPLVkzon06UWkAC7aSO+hyz13CaJW60cRYbInZU3nKRXk2A/
+N3Sn7H4LiRAaJ796eBfCAztfPbTOYmTgC197uvwVPEPqXC4YZ1IbidVnL66Ch1dY
+tSrtE6IMzhzFOCrVkTJ2hdO8JDpV2zmZwD+EFmOCCRenKpG5QUpMywv4UX2cxG0D
+YjApeWDlU2Jc1L6nahbvPvlI6gom0rkbsTA4zG/c4J1KoJIrVB3hHPhroT0xzFuZ
+X30nzfxEo7ChwxeK/pUyxULr627J9QIDAQABAoICAAW8Hx0zhBK3mIt2T61yPCFi
+/AqnwCAhMfa+kRJpw2BDxuPMfI0RKKchIn/EaTQfhXZ8mp07ZDvusB1S8JfvolCI
+Y3XDAxQftkguVMUysiHVmJlH/n42aRzpetAhjXQxuNMyN2ADumaips1rYvLENuVr
+Y0FuFa44djp/dhH5jnCn9jnqA36DAuEk+wQzF0pyA6N094AJPFieRN9HMJU4X4FF
+dlbd1dScE9TrMvpBGYerKa6IIlTaPJzygYaFvArVgBIIBC0FJ/7n0a21/eeIEU4V
+huOBFWseMt5L2ntGzVcRZ3n5wvH6LIbqkQvk0p+Xk944tcPox0CDF9Ti/6rCyr7Q
+3jaJYi4q2VaA8uWKs6FOOrvcOBS6iwABMb9lOxhWud46g2lgcyNjZuNlcdNmLr4r
+mppKZ2aE9md4cNYIPCCFdjxxP0TisJXb1PF0+hYnv0UCY00IGRxOwysN66h82kzS
+Os5HYgIux74AWxwkm+3EEM+zdlof+i61uRi6d+MAsm+WvQnXiy2PCvBoLNdAOaA6
+tbCDFXL3/RJdF9wx2julyEihF0jjBafxQwZKqFlPbCwZc08kDSjozCMwork9CSA8
+T5pSMxS7aq6zHrFoWqypB+8QH16YpkmwzDQKkVhc97Va6kZMGk697JscUpG5bPXp
+VzRH+k4q0E8C0QX5eRV5AoIBAQDxXhpS8DZ7bXPGCjldYF1FO9S4pT7li/XPkXwS
+EFwJhci0FM4kB/B5F8gMiXhUZP7iqDriLEXRdlaeZHBGO3PcjRltfauqXBKQ1sSk
+C775v52xaIHjFtZ867wqHlBs+uh836fK55FjAqaEwyjZTBi/i9wB6IAltZjOFZ7N
+avmqLFgPAe2k9bkZiYsSImsfI3ZFT9VQewjLZgMd9gk7uXaQ8Vg1FWOU4e0Jp/L5
+s++sdyIw3JJCiHXULAsVZONKb5dIIbLZ2w66jhLRFkn70pjH4Wbcmd0GHvt2jKV3
+1LLPZUO09Q/9RvMhL5WH/KQOmPERxeznRHuVVv8qPanORpB9AoIBAQDT89cT2pB9
+qfQfTssvQhN6Gq12Kf9LLr1tYwozTz+YZZdUdRY8BfT6XuwxirB1qaaDq1+/0nfv
+ZQZprsHr7Gh3HgdkQlESuMnrepsK7Wa17LNkL8iOfJrMAMUxPjGWnN+Hsnhk5zbv
+dOUIyD+vtJO+d/8znpSieIRn8iN2cyfqT/RjxWjssEQBWpaHRBGDq9GY1tfpU01O
+/3r4w9Tog2Pu2xGukP/l/Ohp/E3otK9O3RmSM2bTd9Qm3SomN4mX8MHr1PG9ci/p
+KEVeE+z9p62pTYB8diMl2d5xMQdUcuN/O5Ue1Umwmz0JqDdNqQCz5SKYZo4tT+SN
+a0ehr3/pOJDZAoIBAQDi89/+sn4YKr+crIpqAa1R50NK554vix30MdEezyErlw80
+PQfkG08DHdht6Wkqudhs2VCc0JJJtWMXBkwHzelQraAGMw+SXYbbiAZYVe8ZuRIW
++bSACj5eMe65D84B2x92I3sLsBglqB1ZYoRrZkEzAtg5Nxwf2RQ4W135uyfM2mtm
+mSKSZLbKi2koARMGsXqJC9sBFN8dGeu+ZVUjQm15NmYBa/45xQH0fWZbYtTvLwoI
+Na6VPujEOzGkyTtrB2iRW5ZngLHluqd40ON6FPixoYDt1wNbuRAr1W3VMjt8BbTX
+V0LUnb0JLEwHFQhR7X9nfdsXTm6B6s59MoQTQIilAoIBAGbZupKdyuPP5vCSUbKb
+A8yKyYW/l2yqP62nE7oWSKvxEGAheSqjUV91VHQt8rcGHhFixdHVlfGLOnNqJBwR
+2heDcN7L9394QDOOiVHiJac+N0b0kQPjn1JDRW1B2tpVQXsdtaJxOI02UjXSxmTC
+4bbZj/NCjqnQhZ/TNjYyZzoillsb3nCMkFN/2+/DriQQ6mKaTqegjrE49Dlm/hfe
+Ok4b7BajsimucjGMB1pW44MHc3MokksnqME7LUriRFiAsfl4md3uXSVtL0wZqzTj
+ezferey3fxLNCE4xFnd6UL7a8N/HbDzQ9+uJv1xmGDszg3gku/VtAWFGn7nr6cwI
+cPECggEBANoHlBJofeYArwgzZdkA7kCyspdcR1Kmk6W6pFVSWMTA5S3ow8FYaxd4
+MxouBMoro8QhkdszwnCyvwOxghykTLT9W5jdRGSBCnHYg7GZImVWhFxKSBIc7vHb
+T0xHfLkAD8GYhux9mgLTVZDijB/Gj3//E26kT6eFpJR0s5Xj0kSGcIChHBoGJTmW
+dyWarF/v/wpjMiGHF1HQ1I9jF70Ly4WQhDcVlCLIpnM6ChNqdSJDwNDEnL7Gexjq
++bRaTqSkUU++H+E78kcw+U0hC+Ac5wy2B32H5E32ghhWkVYDGlLn5oBsZcbCmqAE
+7/kQTUM7p6ZquKZ2RYCmBlpyKZ7iP38=
+-----END PRIVATE KEY-----

test/ssl_test.ml

@@ -0,0 +1,160 @@
+open Riot
+
+let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna)
+
+type Message.t += Received of string
+
+(* rudimentary tcp echo server *)
+let server port =
+  let socket = Net.Socket.listen ~port () |> Result.get_ok in
+  Logger.debug (fun f -> f "Started server on %d" port);
+  process_flag (Trap_exit true);
+  let conn, addr = Net.Socket.accept socket |> Result.get_ok in
+  Logger.debug (fun f ->
+      f "Accepted client %a (%a)" Net.Addr.pp addr Net.Socket.pp conn);
+  let close () =
+    Net.Socket.close conn;
+    Logger.debug (fun f ->
+        f "Closed client %a (%a)" Net.Addr.pp addr Net.Socket.pp conn)
+  in
+
+  let certificates =
+    let crt =
+      let buf = IO.Buffer.with_capacity 4_096 in
+      let _len =
+        File.open_read "fixtures/tls.crt"
+        |> File.to_reader |> IO.Reader.read ~buf |> Result.get_ok
+      in
+      X509.Certificate.decode_pem_multiple (IO.Buffer.as_cstruct buf)
+      |> Result.get_ok
+    in
+    let pk =
+      let buf = IO.Buffer.with_capacity 4_096 in
+      let _len =
+        File.open_read "fixtures/tls.key"
+        |> File.to_reader |> IO.Reader.read ~buf |> Result.get_ok
+      in
+      X509.Private_key.decode_pem (IO.Buffer.as_cstruct buf) |> Result.get_ok
+    in
+    `Single (crt, pk)
+  in
+  let config = Tls.Config.server ~certificates () in
+  let reader, writer = SSL.of_server_socket ~config conn in
+
+  let buf = IO.Buffer.with_capacity 1024 in
+
+  let rec echo () =
+    Logger.debug (fun f ->
+        f "Reading from client client %a (%a)" Net.Addr.pp addr Net.Socket.pp
+          conn);
+    match IO.Reader.read reader ~buf with
+    | Ok len -> (
+        Logger.debug (fun f -> f "Server received %d bytes" len);
+        let data = IO.Buffer.sub ~off:0 ~len buf in
+        match IO.write_all ~data writer with
+        | Ok bytes ->
+            Logger.debug (fun f -> f "Server sent %d bytes" bytes);
+            echo ()
+        | Error (`Eof | `Closed) -> close ()
+        | Error (`Unix_error unix_err) ->
+            Logger.error (fun f ->
+                f "send unix error %s" (Unix.error_message unix_err));
+            close ())
+    | Error (`Eof | `Closed | `Timeout) -> close ()
+    | Error (`Unix_error unix_err) ->
+        Logger.error (fun f ->
+            f "recv unix error %s" (Unix.error_message unix_err));
+        close ()
+  in
+  echo ()
+
+let client port main =
+  let addr = Net.Addr.(tcp loopback port) in
+  let conn = Net.Socket.connect addr |> Result.get_ok in
+  Logger.debug (fun f -> f "Connected to server on %d" port);
+
+  let host =
+    let domain_name = Domain_name.of_string_exn "localhost" in
+    Domain_name.host_exn domain_name
+  in
+
+  let null ?ip:_ ~host:_ _ = Ok None in
+  let config = Tls.Config.client ~authenticator:null () in
+  let reader, writer = SSL.of_client_socket ~host ~config conn in
+
+  let data = IO.Buffer.of_string "hello world" in
+  let rec send_loop n =
+    sleep 0.001;
+    if n = 0 then Logger.error (fun f -> f "client retried too many times")
+    else
+      match IO.write_all ~data writer with
+      | Ok bytes -> Logger.debug (fun f -> f "Client sent %d bytes" bytes)
+      | Error (`Closed | `Eof) -> Logger.debug (fun f -> f "connection closed")
+      | Error (`Unix_error (ENOTCONN | EPIPE)) -> send_loop n
+      | Error (`Unix_error unix_err) ->
+          Logger.error (fun f ->
+              f "client unix error %s" (Unix.error_message unix_err));
+          send_loop (n - 1)
+  in
+  send_loop 10_000;
+
+  let buf = IO.Buffer.with_capacity 128 in
+  let recv_loop () =
+    match IO.Reader.read ~buf reader with
+    | Ok bytes ->
+        Logger.debug (fun f -> f "Client received %d bytes" bytes);
+        bytes
+    | Error (`Closed | `Timeout | `Eof) ->
+        Logger.error (fun f -> f "Server closed the connection");
+        0
+    | Error (`Unix_error unix_err) ->
+        Logger.error (fun f ->
+            f "client unix error %s" (Unix.error_message unix_err));
+        0
+  in
+  let len = recv_loop () in
+
+  if len = 0 then send main (Received "empty paylaod")
+  else send main (Received (IO.Buffer.to_string buf))
+
+let () =
+  Riot.run @@ fun () ->
+  let _ = Logger.start () |> Result.get_ok in
+  Logger.set_log_level (Some Info);
+  let port = 2113 in
+  let main = self () in
+  let server =
+    spawn (fun () ->
+        try server port
+        with SSL.Tls_failure failure ->
+          Logger.error (fun f ->
+              f "server error: %a" Tls.Engine.pp_failure failure))
+  in
+  let client =
+    spawn (fun () ->
+        try client port main
+        with SSL.Tls_failure failure ->
+          Logger.error (fun f ->
+              f "client error: %a" Tls.Engine.pp_failure failure))
+  in
+  monitor main server;
+  monitor main client;
+  match receive () with
+  | Received "hello world" ->
+      Logger.info (fun f -> f "ssl_test: OK");
+      sleep 0.001;
+      shutdown ()
+  | Received other ->
+      Logger.error (fun f -> f "ssl_test: bad payload: %S" other);
+      sleep 0.001;
+      Stdlib.exit 1
+  | Process.Messages.Monitor (Process_down pid) ->
+      let who = if Pid.equal pid server then "server" else "client" in
+      Logger.error (fun f ->
+          f "ssl_test: %s(%a) died unexpectedly" who Pid.pp pid);
+      sleep 0.001;
+      Stdlib.exit 1
+  | _ ->
+      Logger.error (fun f -> f "ssl_test: unexpected message");
+      sleep 0.001;
+      Stdlib.exit 1