summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRyan Kavanagh <rak@rak.ac>2020-06-03 10:31:55 -0400
committerRyan Kavanagh <rak@rak.ac>2020-06-07 11:39:58 -0400
commit17fb2a0f1332c1db9748644b9abf84cdd79b7ed2 (patch)
tree050732b99029ee2f608dc8fa0c77c404fb201fc7
parentAdd an UNDEFINED status (diff)
Added some TLS utilities
Diffstat (limited to '')
-rw-r--r--gemini/dune2
-rw-r--r--gemini/tlsUtils.ml39
-rw-r--r--gemini/tlsUtils.mli14
3 files changed, 54 insertions, 1 deletions
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