commit 9690ef010feb1c1df138ba458a44334f7d539b9f
Author: Reynir Björnsson <reynir@reynir.dk>
Date:   Wed Dec 9 20:28:07 2020 +0100

    Initial commit

diff --git a/bin/cert_service_client.ml b/bin/cert_service_client.ml
new file mode 100644
index 0000000..f8df28f
--- /dev/null
+++ b/bin/cert_service_client.ml
@@ -0,0 +1,46 @@
+open Lwt.Syntax
+
+let sock_path = "/home/reynir/cert.sock"
+let version = `V1
+
+let csr user =
+  let dn = 
+    X509.Distinguished_name.(Relative_distinguished_name.singleton (CN user)) in
+  let key : X509.Private_key.t =
+    `RSA (Mirage_crypto_pk.Rsa.generate ~bits:2048 ()) in
+  let csr = X509.Signing_request.create [dn] key in
+  key, csr
+
+
+let main () =
+  Mirage_crypto_rng_lwt.initialize ();
+  let user = Unix.getpwuid (Unix.getuid ()) in
+  let fd = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+  let* () = Lwt_unix.connect fd (Unix.ADDR_UNIX sock_path) in
+  let key, csr = csr user.pw_name in
+  let* r = Cert_service.Wire_lwt.write_wire fd
+      ({ version }, `Command (`Sign_request csr)) in
+  let* () =
+    match r with
+    |Error `Exception ->
+      let* () = Lwt_io.eprintl "Error writing to cert service" in
+      exit 2
+    | Ok () ->
+      Lwt.return_unit
+  in
+  let* r = Cert_service.Wire_lwt.read_wire fd in
+  let* cert =
+    match r with
+    | Ok ({ version = `V1 }, `Sign cert) ->
+      Lwt.return cert
+    | Ok ({ version = `V1 }, `Failure e) ->
+      let* () = Lwt_io.eprintf "cert service reported failure: %s\n" e in
+      exit 1
+    | Ok ({ version = `V1 }, `Command _) | Error _ ->
+      let* () = Lwt_io.eprintl "Error reading from cert service" in
+      exit 2
+  in
+  let* () = Lwt_io.printl (Cstruct.to_string (X509.Private_key.encode_pem key)) in
+  Lwt_io.printl (Cstruct.to_string (X509.Certificate.encode_pem cert))
+
+let () = Lwt_main.run (main ())
diff --git a/bin/cert_service_server.ml b/bin/cert_service_server.ml
new file mode 100644
index 0000000..97805c5
--- /dev/null
+++ b/bin/cert_service_server.ml
@@ -0,0 +1,59 @@
+open Lwt.Syntax
+
+let sock_path = "/home/reynir/cert.sock"
+let cacert_path = "/home/reynir/CA/cert.pem"
+let cakey_path = "/home/reynir/CA/key.pem"
+
+let handler t _sockaddr fd =
+  let _pid, _gid, uid = ExtUnix.Specific.read_credentials
+      (Lwt_unix.unix_file_descr fd) in
+  let pwentry = Unix.getpwuid uid in
+  let* () = Lwt_io.printf "Connect by %s\n" pwentry.pw_name in
+  let* w = Cert_service.Wire_lwt.read_wire fd in
+  match w with
+  | Ok ({ version = `V1 }, `Failure _)
+  | Ok ({ version = `V1 }, `Sign _)
+  | Error _ ->
+    Lwt.return_unit
+  | Ok ({ version = `V1 }, `Command (`Sign_request csr)) ->
+    match Cert_service.sign t csr pwentry.pw_name with
+    | Ok cert ->
+      let+ _ = Cert_service.Wire_lwt.write_wire fd ({ version = `V1 }, (`Sign cert)) in
+      ()
+    | Error (`Msg e) ->
+      let+ _ = Cert_service.Wire_lwt.write_wire fd ({ version = `V1 }, (`Failure e)) in
+      ()
+
+let load_cacert f =
+  Rresult.R.bind
+    (Bos.OS.File.read f)
+    (fun s -> X509.Certificate.decode_pem (Cstruct.of_string s))
+
+let load_cakey f =
+  Rresult.R.bind
+    (Bos.OS.File.read f)
+    (fun s -> X509.Private_key.decode_pem (Cstruct.of_string s))
+
+let main () =
+  Mirage_crypto_rng_lwt.initialize ();
+  let cacert = Rresult.R.get_ok (load_cacert (Fpath.v cacert_path)) in
+  let cakey = Rresult.R.get_ok (load_cakey (Fpath.v cakey_path)) in
+  let t = { Cert_service.host = "de1.hashbang.sh"; cacert; cakey } in
+  let server_fd = Lwt_unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+  let old_umask = Unix.umask 0o011 in
+  let () = try Unix.unlink sock_path
+    with Unix.Unix_error (Unix.ENOENT, _, _) -> () in
+  let* _server =
+    Lwt_io.establish_server_with_client_socket
+      ~server_fd
+      (Unix.ADDR_UNIX sock_path)
+      (handler t)
+  in
+  Lwt_main.at_exit (fun () ->
+      Lwt_unix.unlink sock_path);
+  let _ = Unix.umask old_umask in
+  let forever, _ = Lwt.wait () in
+  forever
+
+
+let () = Lwt_main.run (main ())
diff --git a/bin/dune b/bin/dune
new file mode 100644
index 0000000..78243f7
--- /dev/null
+++ b/bin/dune
@@ -0,0 +1,11 @@
+(executable
+ (public_name cert-service-server)
+ (name cert_service_server)
+ (modules cert_service_server)
+ (libraries cert_service lwt.unix extunix bos mirage-crypto-rng.lwt))
+
+(executable
+ (public_name cert-service-client)
+ (name cert_service_client)
+ (modules cert_service_client)
+ (libraries cert_service lwt.unix bos mirage-crypto-rng.lwt))
diff --git a/cert_service.opam b/cert_service.opam
new file mode 100644
index 0000000..e69de29
diff --git a/dune-project b/dune-project
new file mode 100644
index 0000000..a55e9f1
--- /dev/null
+++ b/dune-project
@@ -0,0 +1,2 @@
+(lang dune 2.7)
+(name cert_service)
diff --git a/lib/cert_service.ml b/lib/cert_service.ml
new file mode 100644
index 0000000..01c7fc6
--- /dev/null
+++ b/lib/cert_service.ml
@@ -0,0 +1,53 @@
+open Rresult
+
+module Commands = Wire_commands
+module Wire_lwt = Wire_lwt
+
+let wire_of_cstruct = Wire_asn.wire_of_cstruct
+let wire_to_cstruct = Wire_asn.wire_to_cstruct
+
+type t = {
+  host : string;
+  cacert : X509.Certificate.t;
+  cakey : X509.Private_key.t;
+}
+
+let check_csr_dn csr user =
+  let subject = 
+    [X509.Distinguished_name.(Relative_distinguished_name.singleton (CN user))] in
+  if X509.Distinguished_name.equal
+      subject
+      (X509.Signing_request.info csr).subject
+  then Ok ()
+  else R.error_msgf "Bad subject in csr: %a"
+      X509.Distinguished_name.pp (X509.Signing_request.info csr).subject
+
+let sign t csr user =
+  check_csr_dn csr user >>= fun () ->
+  let issuer = X509.Certificate.subject t.cacert in
+  let email = Printf.sprintf "%s@%s" user t.host in
+  let valid_from = Ptime_clock.now () in
+  let valid_until =
+    Ptime.add_span valid_from 
+      (Ptime.Span.of_int_s (Duration.of_day 90 |> Duration.to_sec))
+    |> Option.get
+  in
+  let extensions = 
+    let open X509.Extension in
+    let auth = Some (X509.Public_key.id (X509.Certificate.public_key t.cacert)),
+               X509.General_name.empty, None in
+    X509.Extension.empty
+    |> add Authority_key_id (false, auth)
+    |> add Subject_key_id (false, X509.(Public_key.id (Signing_request.info csr).public_key))
+    |> add Subject_alt_name (false, X509.General_name.singleton Rfc_822 [email])
+    |> add Ext_key_usage (true, [`Client_auth])
+  in
+  X509.Signing_request.sign
+    csr
+    ~valid_from
+    ~valid_until
+    ~extensions
+    t.cakey
+    issuer
+  |> R.reword_error (fun ve ->
+      R.msgf "Signing failed: %a" X509.Validation.pp_validation_error ve)
diff --git a/lib/dune b/lib/dune
new file mode 100644
index 0000000..e2bc967
--- /dev/null
+++ b/lib/dune
@@ -0,0 +1,3 @@
+(library
+ (name cert_service)
+ (libraries x509 duration ptime.clock.os asn1-combinators lwt lwt.unix))
diff --git a/lib/wire_asn.ml b/lib/wire_asn.ml
new file mode 100644
index 0000000..74268cb
--- /dev/null
+++ b/lib/wire_asn.ml
@@ -0,0 +1,92 @@
+open Rresult
+open Wire_commands
+
+let oid = Asn.OID.(base 1 3 <| 6 <| 1 <| 4 <| 1 <| 49836 <| 5171)
+
+let decode_strict codec cs =
+  match Asn.decode codec cs with
+  | Ok (a, cs) ->
+    if Cstruct.len cs > 0
+    then R.error_msg "trailing bytes"
+    else Ok a
+  | Error (`Parse msg) -> Error (`Msg msg)
+
+let projections_of asn =
+  let c = Asn.codec Asn.der asn in
+  (decode_strict c, Asn.encode c)
+
+let my_explicit ?cls id ~label:_ asn = Asn.S.explicit ?cls id asn
+
+let version =
+  let f = function
+    | 1 -> `V1
+    | x -> Asn.S.error (`Parse (Printf.sprintf "unknown version number 0x%X" x))
+  and g `V1 = 1
+  in
+  Asn.S.map f g Asn.S.int
+
+let header =
+  let f (version, _) = { version }
+  and g h = h.version, 0
+  in
+  Asn.S.map f g @@
+  Asn.S.(sequence2 
+          (required ~label:"version" version)
+          (required ~label:"placeholder" int))
+
+let csr =
+  let f data =
+    match X509.Signing_request.decode_der data with
+    | Ok csr -> csr
+    | Error (`Msg e) -> Asn.S.error (`Parse e)
+  and g csr =
+    X509.Signing_request.encode_der csr
+  in
+  Asn.S.map f g Asn.S.octet_string
+
+let cert =
+  let f data =
+    match X509.Certificate.decode_der data with
+    | Ok cert -> cert
+    | Error (`Msg e) -> Asn.S.error (`Parse e)
+  and g cert =
+    X509.Certificate.encode_der cert
+  in
+  Asn.S.map f g Asn.S.octet_string
+
+
+let wire_command =
+  let f = function
+    | `C1 csr ->
+      `Sign_request csr
+    | `C2 () -> assert false
+  and g = function
+    | `Sign_request csr -> `C1 csr
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice2
+          (my_explicit 0 ~label:"sign-request" csr)
+          (my_explicit 1 ~label:"placeholder" null))
+
+let payload =
+  let f = function
+    | `C1 cmd -> `Command cmd
+    | `C2 cert -> `Sign cert
+    | `C3 e -> `Failure e
+  and g = function
+    | `Command cmd -> `C1 cmd
+    | `Sign cert -> `C2 cert
+    | `Failure e -> `C3 e
+  in
+  Asn.S.map f g @@
+  Asn.S.(choice3
+          (my_explicit 0 ~label:"command" wire_command)
+          (my_explicit 1 ~label:"sign" cert)
+          (my_explicit 2 ~label:"failure" utf8_string))
+
+let wire =
+  Asn.S.(sequence2
+          (required ~label:"header" header)
+          (required ~label:"payload" payload))
+
+let wire_of_cstruct, wire_to_cstruct = projections_of wire
diff --git a/lib/wire_commands.ml b/lib/wire_commands.ml
new file mode 100644
index 0000000..16a787c
--- /dev/null
+++ b/lib/wire_commands.ml
@@ -0,0 +1,20 @@
+type version = [ `V1 ]
+
+let pp_version ppf v =
+  Fmt.int ppf (match v with `V1 -> 1)
+
+type header = {
+  version : version;
+}
+
+type t = [
+  | `Sign_request of X509.Signing_request.t
+]
+
+type res = [
+  | `Command of t
+  | `Sign of X509.Certificate.t
+  | `Failure of string
+]
+
+type wire = header * res
diff --git a/lib/wire_lwt.ml b/lib/wire_lwt.ml
new file mode 100644
index 0000000..ccb0760
--- /dev/null
+++ b/lib/wire_lwt.ml
@@ -0,0 +1,61 @@
+open Lwt.Infix
+
+let safe_close s =
+  Lwt.catch (fun () -> Lwt_unix.close s)
+    (fun _ -> Lwt.return_unit)
+
+let read_wire fd =
+  let buf = Bytes.create 4 in
+  let rec r b i l =
+    Lwt.catch (fun () ->
+        Lwt_unix.read fd b i l >>= function
+        | 0 ->
+          Lwt.return (Error `Eof)
+        | n when n == l -> Lwt.return (Ok ())
+        | n when n < l -> r b (i + n) (l - n)
+        | _ ->
+          Lwt.return (Error `Toomuch))
+      (fun _ ->
+         safe_close fd >|= fun () ->
+         Error `Exception)
+  in
+  r buf 0 4 >>= function
+  | Error e -> Lwt.return (Error e)
+  | Ok () ->
+    let len = Cstruct.BE.get_uint32 (Cstruct.of_bytes buf) 0 in
+    if len > 0l then begin
+      let b = Bytes.create (Int32.to_int len) in
+      r b 0 (Int32.to_int len) >|= function
+      | Error e -> Error e
+      | Ok () ->
+        match Wire_asn.wire_of_cstruct (Cstruct.of_bytes b) with
+        | Error (`Msg _msg) ->
+          Error `Exception
+        | (Ok (hdr, _)) as w ->
+          if not (hdr.version = `V1) then
+            assert false; (* FIXME *)
+          w
+    end else begin
+      Lwt.return (Error `Eof)
+    end
+
+let write_raw fd buf =
+  let rec w off l =
+    Lwt.catch (fun () ->
+        Lwt_unix.send fd buf off l [] >>= fun n ->
+        if n = l then
+          Lwt.return (Ok ())
+        else
+          w (off + n) (l - n))
+      (fun _ ->
+         safe_close fd >|= fun () ->
+         Error `Exception)
+  in
+  w 0 (Bytes.length buf)
+
+let write_wire fd wire =
+  let data = Wire_asn.wire_to_cstruct wire in
+  let dlen = Cstruct.create 4 in
+  Cstruct.BE.set_uint32 dlen 0 (Int32.of_int (Cstruct.len data)) ;
+  let buf = Cstruct.(to_bytes (append dlen data)) in
+  write_raw fd buf