From 17fb2a0f1332c1db9748644b9abf84cdd79b7ed2 Mon Sep 17 00:00:00 2001
From: Ryan Kavanagh <rak@rak.ac>
Date: Wed, 3 Jun 2020 10:31:55 -0400
Subject: Added some TLS utilities

---
 gemini/dune         |  2 +-
 gemini/tlsUtils.ml  | 39 +++++++++++++++++++++++++++++++++++++++
 gemini/tlsUtils.mli | 14 ++++++++++++++
 3 files changed, 54 insertions(+), 1 deletion(-)
 create mode 100644 gemini/tlsUtils.ml
 create mode 100644 gemini/tlsUtils.mli

(limited to 'gemini')

diff --git a/gemini/dune b/gemini/dune
index 3087c29..7e15878 100644
--- a/gemini/dune
+++ b/gemini/dune
@@ -1,4 +1,4 @@
 (library
  (name gemini)
- (libraries base angstrom angstrom-lwt-unix lwt lwt_ppx stdlib tls.lwt uri)
+ (libraries base angstrom angstrom-lwt-unix lwt lwt_ppx mirage-crypto-pk ptime stdlib tls.lwt uri)
  (preprocess (pps lwt_ppx)))
diff --git a/gemini/tlsUtils.ml b/gemini/tlsUtils.ml
new file mode 100644
index 0000000..0916185
--- /dev/null
+++ b/gemini/tlsUtils.ml
@@ -0,0 +1,39 @@
+module type TLS_UTILS =
+sig
+  type authenticator = X509_lwt.authenticator Lwt.t
+
+  val null_auth : authenticator
+
+  val ca : Lwt_io.file_name -> authenticator
+
+  val self_sign : ?bits:int -> ?days:int
+    -> X509.Distinguished_name.t
+    -> (Tls.Config.certchain, string) result
+end
+
+module TlsUtils : TLS_UTILS =
+struct
+  type authenticator = X509.Authenticator.t Lwt.t
+
+  let null_auth = Lwt.return (fun ~host:_ -> fun _ -> Ok None)
+
+  let ca path = if Sys.is_directory path then
+      X509_lwt.authenticator (`Ca_dir path)
+    else
+      X509_lwt.authenticator (`Ca_file path)
+
+  let self_sign ?(bits=2048) ?(days=1) dnames =
+    let () = Mirage_crypto_rng_unix.initialize () in
+    let priv = Mirage_crypto_pk.Rsa.generate ~bits:bits () in
+    let csr = X509.Signing_request.create dnames (`RSA priv) in
+    let valid_from : Ptime.t = Ptime_clock.now () in
+    let valid_span = Ptime.Span.of_int_s (days * 24 * 60 * 60) in
+    let open Base in
+    let open Result.Monad_infix in
+     Result.of_option (Ptime.add_span valid_from valid_span)
+       ~error:"exceeds posix time range" >>= (fun valid_until ->
+        match X509.Signing_request.sign csr ~valid_from ~valid_until
+                (`RSA priv) dnames with
+        | Ok cert -> Ok ([cert], priv)
+        | Error _ -> Error "Unable to sign")
+end
diff --git a/gemini/tlsUtils.mli b/gemini/tlsUtils.mli
new file mode 100644
index 0000000..ba89de7
--- /dev/null
+++ b/gemini/tlsUtils.mli
@@ -0,0 +1,14 @@
+module type TLS_UTILS =
+sig
+  type authenticator = X509_lwt.authenticator Lwt.t
+
+  val null_auth : authenticator
+
+  val ca : Lwt_io.file_name -> authenticator
+
+  val self_sign : ?bits:int -> ?days:int
+    -> X509.Distinguished_name.t
+    -> (Tls.Config.certchain, string) result
+end
+
+module TlsUtils : TLS_UTILS
-- 
cgit v1.2.3