aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/dune13
-rw-r--r--lib/http_date.ml33
-rw-r--r--lib/parser.ml75
-rw-r--r--lib/sig.ml167
-rw-r--r--lib/user.ml6
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