Initial commit

This commit is contained in:
Reynir Björnsson 2020-12-09 20:28:07 +01:00
commit 9690ef010f
10 changed files with 347 additions and 0 deletions

View file

@ -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 ())

View file

@ -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 ())

11
bin/dune Normal file
View file

@ -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))

0
cert_service.opam Normal file
View file

2
dune-project Normal file
View file

@ -0,0 +1,2 @@
(lang dune 2.7)
(name cert_service)

53
lib/cert_service.ml Normal file
View file

@ -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)

3
lib/dune Normal file
View file

@ -0,0 +1,3 @@
(library
(name cert_service)
(libraries x509 duration ptime.clock.os asn1-combinators lwt lwt.unix))

92
lib/wire_asn.ml Normal file
View file

@ -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

20
lib/wire_commands.ml Normal file
View file

@ -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

61
lib/wire_lwt.ml Normal file
View file

@ -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