Add initial auth

5 files changed, 292 insertions, 2 deletions

diff --git a/lib/dune b/lib/dune
index 441cc53..8786484 100644
--- a/lib/dune
+++ b/lib/dune
@@ -1,4 +1,15 @@
 (library
  (name wormhole)
- (libraries uri cohttp cohttp-lwt-unix)
+ (libraries uri 
+        cohttp-lwt-unix
+        containers 
+        base64
+        mirage-crypto 
+        x509
+        lwt 
+        cohttp 
+        dream
+        calendar
+        ptime 
+ )
  (preprocess (pps lwt_ppx ppx_yojson_conv)))
diff --git a/lib/http_date.ml b/lib/http_date.ml
new file mode 100644
index 0000000..88692a5
--- /dev/null
+++ b/lib/http_date.ml
@@ -0,0 +1,33 @@
+(* Taken from https://github.com/gopiandcode/ocamlot *)
+let parse_date = Parser.parse_date
+let parse_date_exn = Parser.parse_date_exn
+
+let to_utc_string t =
+  let www =
+    Ptime.weekday t |> function
+    | `Sat -> "Sat"
+    | `Fri -> "Fri"
+    | `Mon -> "Mon"
+    | `Wed -> "Wed"
+    | `Sun -> "Sun"
+    | `Tue -> "Tue"
+    | `Thu -> "Thu"
+  in
+  let (yyyy, mmm, dd), ((hh, mm, ss), _) = Ptime.to_date_time t in
+  let mmm =
+    match mmm with
+    | 1 -> "Jan"
+    | 2 -> "Feb"
+    | 3 -> "Mar"
+    | 4 -> "Apr"
+    | 5 -> "May"
+    | 6 -> "Jun"
+    | 7 -> "Jul"
+    | 8 -> "Aug"
+    | 9 -> "Sep"
+    | 10 -> "Oct"
+    | 11 -> "Nov"
+    | 12 -> "Dec"
+    | _ -> assert false
+  in
+  Printf.sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT" www dd mmm yyyy hh mm ss
diff --git a/lib/parser.ml b/lib/parser.ml
new file mode 100644
index 0000000..2e9d759
--- /dev/null
+++ b/lib/parser.ml
@@ -0,0 +1,75 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2015 Inhabited Type LLC.
+    All rights reserved.
+    Redistribution and use in source and binary forms, with or without
+    modification, are permitted provided that the following conditions
+    are met:
+    1. Redistributions of source code must retain the above copyright
+       notice, this list of conditions and the following disclaimer.
+    2. Redistributions in binary form must reproduce the above copyright
+       notice, this list of conditions and the following disclaimer in the
+       documentation and/or other materials provided with the distribution.
+    3. Neither the name of the author nor the names of his contributors
+       may be used to endorse or promote products derived from this software
+       without specific prior written permission.
+    THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
+    OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+    DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+    ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+    DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+    OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+    HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+    STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+    POSSIBILITY OF SUCH DAMAGE.
+  ----------------------------------------------------------------------------*)
+
+let parse_date_exn s =
+  try
+    Scanf.sscanf s "%3s, %d %s %4d %d:%d:%d %s"
+      (fun _wday mday mon year hour min sec tz ->
+        let months =
+          [
+            ("Jan", 1);
+            ("Feb", 2);
+            ("Mar", 3);
+            ("Apr", 4);
+            ("May", 5);
+            ("Jun", 6);
+            ("Jul", 7);
+            ("Aug", 8);
+            ("Sep", 9);
+            ("Oct", 10);
+            ("Nov", 11);
+            ("Dec", 12);
+          ]
+        in
+        let parse_tz = function
+          | "" | "Z" | "GMT" | "UTC" | "UT" -> 0
+          | "PST" -> -480
+          | "MST" | "PDT" -> -420
+          | "CST" | "MDT" -> -360
+          | "EST" | "CDT" -> -300
+          | "EDT" -> -240
+          | s ->
+              Scanf.sscanf s "%c%02d%_[:]%02d" (fun sign hour min ->
+                  min + (hour * if sign = '-' then -60 else 60))
+        in
+        let mon = List.assoc mon months in
+        let year =
+          if year < 50 then year + 2000
+          else if year < 1000 then year + 1900
+          else year
+        in
+        let date = (year, mon, mday) in
+        let time = ((hour, min, sec), parse_tz tz * 60) in
+        let ptime = Ptime.of_date_time (date, time) in
+        match ptime with
+        | None -> raise (Invalid_argument "Invalid date string")
+        | Some date -> date)
+  with
+  | Scanf.Scan_failure e -> raise (Invalid_argument e)
+  | Not_found -> raise (Invalid_argument "Invalid date string")
+
+let parse_date s = try Some (parse_date_exn s) with Invalid_argument _ -> None
diff --git a/lib/sig.ml b/lib/sig.ml
new file mode 100644
index 0000000..b4f49d7
--- /dev/null
+++ b/lib/sig.ml
@@ -0,0 +1,167 @@
+(* Taken from https://gopiandcode.uk/logs/log-writing-activitypub.html
+   License is AGPL-v3
+*)
+open Containers
+module StringMap = Map.Make (String)
+
+let drop_quotes str = String.sub str 1 (String.length str - 2)
+
+let body_digest body =
+  Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string body) |> Cstruct.to_string
+  |> fun hash -> "SHA-256=" ^ Base64.encode_string hash
+
+let req_headers headers = Cohttp.Header.to_list headers |> StringMap.of_list
+
+let split_equals str =
+  match String.index_opt str '=' with
+  | Some ind ->
+      let key = String.sub str 0 ind in
+      let data = String.sub str (ind + 1) (String.length str - ind - 1) in
+      Some (key, data)
+  | _ -> None
+
+(* constructs a signed string *)
+let build_signed_string ~signed_headers ~meth ~path ~headers ~body_digest =
+  (* (request-target) user-agent host date digest content-type *)
+  String.split_on_char ' ' signed_headers
+  |> List.map (function
+       | "(request-target)" ->
+           "(request-target): " ^ String.lowercase_ascii meth ^ " " ^ path
+       | "digest" -> "digest: " ^ body_digest
+       | header ->
+           header ^ ": "
+           ^ (StringMap.find_opt header headers |> Option.value ~default:""))
+  |> String.concat "\n"
+
+let parse_signature signature =
+  String.split_on_char ',' signature
+  |> List.filter_map split_equals
+  |> List.map (Pair.map_snd drop_quotes)
+  |> StringMap.of_list
+
+let verify ~signed_string ~signature pubkey =
+  let result =
+    X509.Public_key.verify `SHA256 ~scheme:`RSA_PKCS1
+      ~signature:(Cstruct.of_string signature)
+      pubkey
+      (`Message (Cstruct.of_string signed_string))
+  in
+  match result with
+  | Ok () -> true
+  | Error (`Msg e) ->
+      Dream.log
+        "error while verifying: %s\n\nsigned_string is:%s\n\nsignature is:%s\n"
+        e signed_string signature;
+      false
+
+let encrypt (privkey : X509.Private_key.t) str =
+  Base64.encode
+    (X509.Private_key.sign `SHA256 ~scheme:`RSA_PKCS1 privkey
+       (`Message (Cstruct.of_string str))
+    |> Result.get_exn |> Cstruct.to_string)
+
+let time_now () =
+  CalendarLib.Calendar.now ()
+  |> CalendarLib.Calendar.to_unixfloat |> Ptime.of_float_s
+  |> Option.get_exn_or "invalid date"
+
+let verify_request taken_public_key (req : Dream.request) =
+  let ( let+ ) x f =
+    match x with None -> Lwt.return (Ok false) | Some v -> f v
+  in
+  let ( let@ ) x f = Lwt.bind x f in
+  let meth =
+    Dream.method_ req |> Dream.method_to_string |> String.lowercase_ascii
+  in
+  let path = Dream.target req in
+  let headers =
+    Dream.all_headers req
+    |> List.map (Pair.map_fst String.lowercase_ascii)
+    |> StringMap.of_list
+  in
+  let+ signature = Dream.header req "Signature" in
+  let signed_headers = parse_signature signature in
+  (* 1. build signed string *)
+  let@ body = Dream.body req in
+  let body_digest = body_digest body in
+  let+ public_key = taken_public_key in
+  (* signed headers *)
+  let+ headers_in_signed_string = StringMap.find_opt "headers" signed_headers in
+  (* signed string *)
+  let signed_string =
+    build_signed_string ~signed_headers:headers_in_signed_string ~meth ~path
+      ~headers ~body_digest
+  in
+  (* 2. retrieve signature *)
+  let+ signature = StringMap.find_opt "signature" signed_headers in
+  let+ signature = Base64.decode signature |> Result.to_opt in
+  (* verify signature against signed string with public key *)
+  Lwt_result.return @@ verify ~signed_string ~signature public_key
+
+let build_signed_headers ~priv_key ~key_id ~headers ?body_str ~current_time
+    ~method_ ~uri () =
+  let signed_headers =
+    match body_str with
+    | Some _ -> "(request-target) content-length host date digest"
+    | None -> "(request-target) host date"
+  in
+
+  let body_str_len = Option.map Fun.(Int.to_string % String.length) body_str in
+  let body_digest = Option.map body_digest body_str in
+
+  let date = Http_date.to_utc_string current_time in
+  let host = uri |> Uri.host |> Option.get_exn_or "no host for request" in
+
+  let signature_string =
+    let opt name vl =
+      match vl with None -> Fun.id | Some vl -> StringMap.add name vl
+    in
+    let to_be_signed =
+      build_signed_string ~signed_headers
+        ~meth:(method_ |> String.lowercase_ascii)
+        ~path:(Uri.path uri)
+        ~headers:
+          (opt "content-length" body_str_len
+          @@ StringMap.add "date" date @@ StringMap.add "host" host @@ headers)
+        ~body_digest:(Option.value body_digest ~default:"")
+    in
+
+    let signed_string = encrypt priv_key to_be_signed |> Result.get_exn in
+    Printf.sprintf
+      {|keyId="%s",algorithm="rsa-sha256",headers="%s",signature="%s"|} key_id
+      signed_headers signed_string
+  in
+  List.fold_left
+    (fun map (k, v) ->
+      match v with None -> map | Some v -> StringMap.add k v map)
+    headers
+    [
+      ("Digest", body_digest);
+      ("Date", Some date);
+      ("Host", Some host);
+      ("Signature", Some signature_string);
+      ("Content-Length", body_str_len);
+    ]
+  |> StringMap.to_list
+
+let sign_headers ~priv_key ~key_id ?(body : Cohttp_lwt.Body.t option)
+    ~(headers : Cohttp.Header.t) ~uri ~method_ () =
+  let ( let* ) x f = Lwt.bind x f in
+
+  let* body_str =
+    match body with
+    | None -> Lwt.return None
+    | Some body -> Lwt.map Option.some (Cohttp_lwt.Body.to_string body)
+  in
+  let current_time = time_now () in
+
+  let headers =
+    List.fold_left
+      (fun header (key, vl) -> Cohttp.Header.add header key vl)
+      headers
+      (build_signed_headers ~priv_key ~key_id ~headers:(req_headers headers)
+         ?body_str ~current_time
+         ~method_:(Cohttp.Code.string_of_method method_)
+         ~uri ())
+  in
+  Lwt.return headers
diff --git a/lib/user.ml b/lib/user.ml
index 00cd33f..f0ac7cf 100644
--- a/lib/user.ml
+++ b/lib/user.ml
@@ -6,7 +6,7 @@ open Lwt
 type public_key = {
   id : string;
   owner : string;
-  public_key_prem : string; [@key "publicKeyPem"]
+  public_key_pem : string; [@key "publicKeyPem"]
 }
 [@@deriving yojson] [@@yojson.allow_extra_fields]
 
@@ -26,4 +26,8 @@ let get_user actor_url =
     Ok body
   with exn -> Lwt.return (Error exn)
 
+let get_public_pem user =
+  user.public_key.public_key_pem |> Cstruct.of_string
+  |> X509.Public_key.decode_pem
+
 let name user = user.name