diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/dune | 13 | ||||
| -rw-r--r-- | lib/http_date.ml | 33 | ||||
| -rw-r--r-- | lib/parser.ml | 75 | ||||
| -rw-r--r-- | lib/sig.ml | 167 | ||||
| -rw-r--r-- | lib/user.ml | 6 |
5 files changed, 292 insertions, 2 deletions
@@ -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 |