diff options
author | Marc Coquand <marc@mccd.space> | 2023-12-20 20:46:00 -0600 |
---|---|---|
committer | Marc Coquand <marc@mccd.space> | 2023-12-25 18:22:59 -0600 |
commit | 262f161f42c4e59beec41c6f440336c38385426a (patch) | |
tree | 6491c9b661a0b5a14c9a30ecf25e036f8762239d /lib | |
parent | cc783c157f31e7e713c8b83be67449b1859dac27 (diff) | |
download | fixgen-262f161f42c4e59beec41c6f440336c38385426a.tar.gz fixgen-262f161f42c4e59beec41c6f440336c38385426a.tar.bz2 fixgen-262f161f42c4e59beec41c6f440336c38385426a.zip |
Initial commit
Diffstat (limited to '')
-rw-r--r-- | lib/activitypub/activitypub.ml | 5 | ||||
-rw-r--r-- | lib/activitypub/common.ml | 47 | ||||
-rw-r--r-- | lib/activitypub/constants.ml | 49 | ||||
-rw-r--r-- | lib/activitypub/decode.ml | 352 | ||||
-rw-r--r-- | lib/activitypub/dune | 3 | ||||
-rw-r--r-- | lib/activitypub/encode.ml | 303 | ||||
-rw-r--r-- | lib/activitypub/readme.md | 5 | ||||
-rw-r--r-- | lib/activitypub/types.ml | 245 | ||||
-rw-r--r-- | lib/ast_types.ml | 178 | ||||
-rw-r--r-- | lib/dune | 25 | ||||
-rw-r--r-- | lib/fixture.ml | 109 | ||||
-rw-r--r-- | lib/http_date.ml | 37 | ||||
-rw-r--r-- | lib/lexer.mll | 27 | ||||
-rw-r--r-- | lib/parser.ml | 75 | ||||
-rw-r--r-- | lib/parser.mly | 31 | ||||
-rw-r--r-- | lib/sig.ml | 167 | ||||
-rw-r--r-- | lib/user.ml | 31 |
17 files changed, 356 insertions, 1333 deletions
diff --git a/lib/activitypub/activitypub.ml b/lib/activitypub/activitypub.ml deleted file mode 100644 index 511b4a3..0000000 --- a/lib/activitypub/activitypub.ml +++ /dev/null @@ -1,5 +0,0 @@ -module Common = Common -module Constants = Constants -module Types = Types -module Encode = Encode -module Decode = Decode diff --git a/lib/activitypub/common.ml b/lib/activitypub/common.ml deleted file mode 100644 index 59c7099..0000000 --- a/lib/activitypub/common.ml +++ /dev/null @@ -1,47 +0,0 @@ -module D = Decoders_yojson.Safe.Decode - -let timestamp = - let open D in - let* time = string in - match Ptime.of_rfc3339 time |> Ptime.rfc3339_error_to_msg with - | Ok (t, _, _) -> succeed t - | Error `Msg err -> fail err - -let singleton_or_list dec = - D.(one_of ["singleton", (dec >|= fun v -> [v]); - "list", list dec; - "null", null >|= fun () -> []]) - -let lossy_list_of dec = - let open D in - list (one_of ["known", (dec >|= fun v -> `Value v); "unknown", value >|= fun v -> `Raw v]) - - -let constant ?msg target = - let open D in - let* str = string in - if String.equal str target - then succeed () - else match msg with - | None -> fail (Printf.sprintf "expected %s received %s" target str) - | Some msg -> fail (Printf.sprintf msg str) - -let field_or_default field' decoder default = - let open D in - let+ field = field_opt field' decoder in - Option.value ~default field - -let list_ignoring_unknown ty = - let open D in - list (maybe ty) >|= fun v -> List.filter_map Fun.id v - -let items obj = - let open D in - one_of [ - ("ordered items", - let* items = field "orderedItems" (list obj) in - succeed (true, items)); - "items", - let* items = field "items" (list obj) in - succeed (false, items) - ] diff --git a/lib/activitypub/constants.ml b/lib/activitypub/constants.ml deleted file mode 100644 index 0488335..0000000 --- a/lib/activitypub/constants.ml +++ /dev/null @@ -1,49 +0,0 @@ -open Containers - -module ContentType = struct - let ld_json_activity_streams = "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" - - let xrd_xml = "application/xrd+xml" - let ld_json = "application/ld+json" - let activity_json = "application/activity+json" - let plain_json = "application/json" - let html = "text/html" - let any = "*/*" - - let content_types = [ - ld_json_activity_streams, `JSON; - ld_json, `JSON; - activity_json, `JSON; - plain_json, `JSON; - html, `HTML; - any, `HTML; - ] - - let of_string content_type = - List.find_opt - (fun (str, _) -> - String.prefix ~pre:str content_type) content_types - |> Option.map snd - - -end - -module Webfinger = struct - let json_rd = "application/jrd+json" - - let self_rel = "self" - let ostatus_rel = "http://ostatus.org/schema/1.0/subscribe" - let profile_page = "http://webfinger.net/rel/profile-page" -end - -module ActivityStreams = struct - - let public = "https://www.w3.org/ns/activitystreams#Public" - - let context : string * Yojson.Safe.t = - "@context", `List [ - `String "https://www.w3.org/ns/activitystreams"; - `String "https://w3id.org/security/v1" - ] - -end diff --git a/lib/activitypub/decode.ml b/lib/activitypub/decode.ml deleted file mode 100644 index 4074e68..0000000 --- a/lib/activitypub/decode.ml +++ /dev/null @@ -1,352 +0,0 @@ -open Containers -open Common - -let decode_string enc vl = D.decode_string enc vl |> Result.map_err D.string_of_error - -let id = D.(one_of ["string", string; "id", field "id" string]) - -let ordered_collection_page obj = - let open D in - let* () = field "type" @@ constant ~msg:"Expected OrderedCollectionPage (received %s)" "OrderedCollectionPage" - and* id = field "id" string - and* next = field_opt "next" id - and* prev = field_opt "prev" id - and* part_of = field_opt "partOf" string - and* total_items = field_opt "totalItems" int - and* (is_ordered, items) = items obj in - succeed ({id; next; prev; part_of; total_items; is_ordered; items}: _ Types.ordered_collection_page) - -let ordered_collection obj = - let open D in - let* () = field "type" @@ constant ~msg:"Expected OrderedCollection (received %s)" "OrderedCollection" - and* id = field_opt "id" string - and* total_items = field "totalItems" int - and* contents = - one_of [ - "items", map (fun v -> `Items v) (items obj); - "first", map (fun v -> `First v) (field "first" (ordered_collection_page obj)) - ] in - succeed ({id; total_items; contents}: _ Types.ordered_collection) - -let mention = - let open D in - let* () = field "type" @@ constant ~msg:"expected Mention (received %s)" "Mention" - and* href = field "href" string - and* name = field "name" string in - succeed ({ty=`Mention; href;name} : Types.tag) - -let hashtag = - let open D in - let* () = field "type" @@ constant ~msg:"expected Hashtag (received %s)" "Hashtag" - and* href = field "href" string - and* name = field "name" string in - succeed ({ty=`Hashtag; href;name}: Types.tag) - -let tag = - let open D in - let* ty = field "type" string in - match ty with - | "Mention" -> mention - | "Hashtag" -> hashtag - | _ -> fail (Printf.sprintf "unknown tag %s" ty) - -let undo obj = - let open D in - let* () = field "type" @@ constant ~msg:"expected Undo (received %s)" "Undo" - and* id = field "id" string - and* actor = field "actor" id - and* published = field_opt "published" timestamp - and* obj = field "object" obj - and* raw = value in - succeed ({id;published;actor;obj;raw}: _ Types.undo) - -let like = - let open D in - let* () = field "type" @@ constant ~msg:"expected Like (received %s)" "Like" - and* id = field "id" string - and* actor = field "actor" id - and* published = field_opt "published" timestamp - and* obj = field "object" id - and* raw = value in - succeed ({id; actor; published; obj; raw}: Types.like) - -let tombstone = - let open D in - let* () = field "type" @@ constant ~msg:"expected Tombstone (received %s)" "Tombstone" - and* id = field "id" string in - succeed id - -let delete obj = - let open D in - let* () = field "type" @@ constant ~msg:"expected Delete (received %s)" "Delete" - and* id = field "id" string - and* actor = field "actor" id - and* published = field_opt "published" timestamp - and* obj = field "object" obj - and* raw = value in - succeed ({id;published;actor;obj;raw}: _ Types.delete) - -let block = - let open D in - let* () = field "type" @@ constant ~msg:"expected Block (received %s)" "Block" - and* id = field "id" string - and* obj = field "object" string - and* published = field_opt "published" timestamp - and* actor = field "actor" id - and* raw = value in - succeed ({id;published;obj;actor;raw}: Types.block) - -let accept obj = - let open D in - let* () = field "type" @@ constant ~msg:"expected Accept (received %s)" "Accept" - and* id = field "id" string - and* actor = field "actor" id - and* published = field_opt "published" timestamp - and* obj = field "object" obj - and* raw = value in - succeed ({id;published;actor;obj;raw}: _ Types.accept) - -let public_key = - let open D in - let* id = field "id" string - and* owner = field "owner" string - and* pem = field "publicKeyPem" string in - succeed ({id;owner;pem}: Types.public_key) - -let attachment = - let open D in - let* media_type = field_opt "mediaType" string - and* name = field_opt "name" string - and* type_ = field_opt "type" string - and* url = field "url" string in - succeed ({media_type;name;type_;url}: Types.attachment) - - -let person = - let open D in - let* () = field "type" @@ constant ~msg:"expected Person (received %s)" "Person" - and* id = field "id" string - and* name = field_opt "name" string - and* url = field_or_default "url" (nullable string) None - and* preferred_username = field_opt "preferredUsername" string - and* inbox = field "inbox" string - and* outbox = field "outbox" string - and* summary = field_opt "summary" string - and* public_key = field "publicKey" public_key - and* manually_approves_followers = - field_or_default "manuallyApprovesFollowers" bool false - and* discoverable = field_or_default "discoverable" bool false - and* followers = field_opt "followers" string - and* following = field_opt "following" string - and* icon = maybe (at ["icon";"url"] string) - and* raw = value in - succeed ({ - id; - name; - url; - - preferred_username; - - inbox; - outbox; - - summary; - - public_key; - - manually_approves_followers; - - discoverable; - followers; - following; - icon; - raw; - }: Types.person) - -let note = - let open D in - let* () = field "type" @@ constant ~msg:"expected Note (received %s)" "Note" - and* id = field "id" string - and* actor = one_of ["actor", field "actor" id; "attributed_to", field "attributedTo" id] - and* attachment = field_or_default "attachment" (singleton_or_list attachment) [] - and* to_ = field "to" (singleton_or_list string) - and* in_reply_to = field_or_default "inReplyTo" (nullable string) None - and* cc = field_or_default "cc" (singleton_or_list string) [] - and* content = field "content" string - and* source = field_opt "source" - (one_of ["string", string; "multi-encode", field "content" string]) - and* summary = field_or_default "summary" (nullable string) None - and* sensitive = field_or_default "sensitive" (nullable bool) None - and* published = field_opt "published" timestamp - and* tags = field_or_default "tag" (lossy_list_of tag) [] - and* raw = value in - succeed ({ id; actor; attachment; in_reply_to; to_; cc; - sensitive=Option.value ~default:false sensitive; - content; source; summary; tags; published; raw }: Types.note) - -let follow = - let open D in - let* () = field "type" @@ constant ~msg:"expected create object (received %s)" "Follow" - and* actor = field "actor" id - and* cc = field_or_default "cc" (singleton_or_list string) [] - and* to_ = field_or_default "to" (singleton_or_list string) [] - and* id = field "id" string - and* object_ = field "object" id - and* state = field_opt "state" (string >>= function "pending" -> succeed `Pending - | "cancelled" -> succeed `Cancelled - | _ -> fail "unknown status") - and* raw = value in - succeed ({actor; cc; to_; id; object_; state; raw}: Types.follow) - -let announce obj = - let open D in - let* () = field "type" @@ constant ~msg:"expected create object (received %s)" "Announce" - and* actor = field "actor" id - and* id = field "id" string - and* published = field_opt "published" timestamp - and* to_ = field "to" (singleton_or_list string) - and* cc = field_or_default "cc" (singleton_or_list string) [] - and* obj = field "object" obj - and* raw = value in - succeed ({id; published; actor; to_; cc; obj; raw}: _ Types.announce) - -let create obj = - let open D in - let* () = field "type" @@ constant ~msg:"expected create object (received %s)" "Create" - and* id = field "id" string - and* actor = field "actor" id - and* direct_message = field_or_default "direct" bool false - and* published = field_opt "published" timestamp - and* to_ = field_or_default "to" (singleton_or_list string) [] - and* cc = field_or_default "cc" (singleton_or_list string) [] - and* obj = field "object" obj - and* raw = value in - - succeed ({ - id; actor; published; - to_; cc; - direct_message; - obj; - raw; - }: _ Types.create) - -let core_obj () = - let open D in - let* ty = field_opt "type" string in - match ty with - | Some "Person" -> person >|= fun v -> `Person v - | Some "Follow" -> follow >|= fun v -> `Follow v - | Some "Note" -> note >|= fun v -> `Note v - | Some "Block" -> block >|= fun v -> `Block v - | Some "Like" -> like >|= fun v -> `Like v - | None -> string >|= fun v -> `Link v - | Some ev -> fail ("unsupported event" ^ ev) - -let core_obj = core_obj () - -let event (enc: Types.core_obj D.decoder) : Types.obj D.decoder = - let open D in - let* ty = field "type" string in - match ty with - | "Create" -> create enc >|= fun v -> `Create v - | "Accept" -> accept enc >|= fun v -> `Accept v - | "Undo" -> undo enc >|= fun v -> `Undo v - | "Delete" -> delete enc >|= fun v -> `Delete v - | "Announce" -> announce enc >|= fun v -> `Announce v - | _ -> fail "unsupported event" - -let obj : Types.obj D.decoder = - D.one_of [ - "core_obj", core_obj; - "core_obj event", (event core_obj) - ] - -module Webfinger = struct - - let ty = - let open D in - string >>= function - | str when String.prefix ~pre:Constants.ContentType.html str -> - succeed `Html - | str when String.prefix ~pre:Constants.ContentType.plain_json str -> - succeed `Json - | str when String.prefix ~pre:Constants.ContentType.activity_json str -> - succeed `ActivityJson - | str when String.prefix ~pre:Constants.ContentType.ld_json_activity_streams str -> - succeed `ActivityJsonLd - | _ -> - fail "unsupported self link type" - - let self = - let open D in - let* ty = field "type" ty - and* href = field "href" string in - succeed @@ Types.Webfinger.Self (ty, href) - - let profile_page = - let open D in - let* ty = field "type" ty - and* href = field "href" string in - succeed @@ Types.Webfinger.ProfilePage (ty, href) - - let ostatus_subscribe = - let open D in - let* template = field "template" string in - succeed @@ Types.Webfinger.OStatusSubscribe template - - let link = - let open D in - let* rel = field "rel" string in - match rel with - | "self" -> self - | str when String.equal str Constants.Webfinger.ostatus_rel -> - ostatus_subscribe - | str when String.equal str Constants.Webfinger.profile_page -> - profile_page - | _ -> fail "unsupported link relation" - - let query_result = - let open D in - let* subject = field "subject" string - and* aliases = field "aliases" (list string) - and* links = field "links" (list_ignoring_unknown link) in - - succeed Types.Webfinger.{subject;aliases;links} - -end - -module Nodeinfo = struct - - let software = - let open D in - let* name = field "name" string - and* version = field "version" string in - succeed @@ Types.Nodeinfo.{name;version} - - let usage_users = - let open D in - let* total = field_or_default "total" int 0 - and* active_month = field_or_default "activeMonth" int 0 - and* active_half_year = field_or_default "activeHalfyear" int 0 in - succeed @@ Types.Nodeinfo.{total; active_month; active_half_year} - - let usage = - let open D in - let* users = field "users" usage_users - and* local_posts = field_or_default "localPosts" int 0 in - succeed @@ Types.Nodeinfo.{users; local_posts} - - let t = - let open D in - let* software = field "software" software - and* protocols = field_or_default "protocols" (list string) [] - and* inbound_services = field_or_default "services" (field_or_default "inbound" (list string) []) [] - and* outbound_services = field_or_default "services" (field_or_default "outbound" (list string) []) [] - and* usage = field "usage" usage - and* open_registrations = field_or_default "openRegistrations" bool false - and* metadata = field_opt "metadata" value - and* raw = value in - succeed @@ Types.Nodeinfo.{software;protocols;inbound_services;outbound_services;usage;open_registrations;metadata;raw} - - -end diff --git a/lib/activitypub/dune b/lib/activitypub/dune deleted file mode 100644 index 9222a82..0000000 --- a/lib/activitypub/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library (name activitypub) - (preprocess (pps ppx_deriving.std)) - (libraries containers uri yojson decoders decoders-yojson ptime)) diff --git a/lib/activitypub/encode.ml b/lib/activitypub/encode.ml deleted file mode 100644 index 2b64e76..0000000 --- a/lib/activitypub/encode.ml +++ /dev/null @@ -1,303 +0,0 @@ -module E = Decoders_yojson.Safe.Encode - - -let (<:) = function - | (_, None) -> fun _ -> [] - | (field, Some vl) -> fun ty -> [field, ty vl] -let (@) field vl = (field, Some vl) -let (@?) field vl = (field, vl) - -let ptime time = E.string (Ptime.to_rfc3339 ~tz_offset_s:0 time) -let obj ls = E.obj @@ List.flatten ls -let ap_obj ty ls = - E.obj (Constants.ActivityStreams.context :: ("type", E.string ty) :: List.flatten ls) - -let or_raw conv = function - | `Raw v -> v - | `Value v -> conv v - -(** * Collections *) -let ordered_collection_page enc - ({ id; prev; next; is_ordered; items; part_of; total_items }: - _ Types.ordered_collection_page) = - ap_obj "OrderedCollectionPage" [ - "id" @ id <: E.string; - "next" @? next <: E.string; - "prev" @? prev <: E.string; - "partOf" @? part_of <: E.string; - "totalItems" @? total_items <: E.int; - (match is_ordered with - | true -> "orderedItems" - | false -> "items") @ items <: E.list enc - ] - -let ordered_collection enc - ({ id; total_items; contents }: _ Types.ordered_collection) = - ap_obj "OrderedCollection" [ - "id" @? id <: E.string; - "totalItems" @ total_items <: E.int; - match contents with - | `First page -> "first" @ page <: ordered_collection_page enc - | `Items (true, items) -> "orderedItems" @ items <: E.list enc - | `Items (false, items) -> "items" @ items <: E.list enc - ] - -(** * Events *) - -let create enc ({ id; actor; published; to_; cc; direct_message; obj; raw=_ }: - _ Types.create) = - ap_obj "Create" [ - "id" @ id <: E.string; - "actor" @ actor <: E.string; - "published" @? published <: ptime; - "to" @ to_ <: E.(list string); - "cc" @ cc <: E.(list string); - "directMessage" @ direct_message <: E.bool; - "object" @ obj <: enc; - ] - -let announce enc ({ id; actor; published; to_; cc; obj; raw=_ } : _ Types.announce) = - ap_obj "Announce" [ - "id" @ id <: E.string; - "actor" @ actor <: E.string; - "published" @? published <: ptime; - "to" @ to_ <: E.(list string); - "cc" @ cc <: E.(list string); - "object" @ obj <: enc; - ] - -let accept enc ({ id; actor; published; obj; raw=_ } : _ Types.accept) = - ap_obj "Accept" [ - "id" @ id <: E.string; - "actor" @ actor <: E.string; - "published" @? published <: ptime; - "object" @ obj <: enc; - ] - -let undo enc ({ id; actor; published; obj; raw=_ } : _ Types.undo) = - ap_obj "Undo" [ - "id" @ id <: E.string; - "actor" @ actor <: E.string; - "published" @? published <: ptime; - "object" @ obj <: enc; - ] - -let delete enc ({ id; actor; published; obj; raw=_ } : _ Types.delete) = - ap_obj "Delete" [ - "id" @ id <: E.string; - "actor" @ actor <: E.string; - "published" @? published <: ptime; - "object" @ obj <: enc; - ] - -(** * Objects *) - -let public_key (key: Types.public_key) = - obj [ - "id" @ key.id <: E.string; - "owner" @ key.owner <: E.string; - "publicKeyPem" @ key.pem <: E.string; - ] - -let icon (url: string) = - obj [ - "type" @ "Image" <: E.string; - "url" @ url <: E.string; - ] - -let person ({ id; name; url; inbox; outbox; - preferred_username; summary; - manually_approves_followers; - discoverable; followers; following; - public_key=key; icon=i; raw=_ }: Types.person) = - ap_obj "Person" [ - - "id" @ id <: E.string; - - "name" @? name <: E.string; - "url" @? url <: E.string; - - "preferredUsername" @? preferred_username <: E.string; - - "inbox" @ inbox <: E.string; - "outbox" @ outbox <: E.string; - - "summary" @? summary <: E.string; - - "publicKey" @ key <: public_key; - - "manuallyApprovesFollowers" @ manually_approves_followers <: E.bool; - - "discoverable" @ discoverable <: E.bool; - - "followers" @? followers <: E.string; - "following" @? following <: E.string; - - "icon" @? i <: icon; - ] - -let state = function - `Pending -> E.string "pending" - | `Cancelled -> E.string "cancelled" - - -let follow ({ id; actor; cc; object_; to_; state=st; raw=_ }: Types.follow) = - ap_obj "Follow" [ - "id" @ id <: E.string; - "actor" @ actor <: E.string; - "to" @ to_ <: E.list E.string; - "cc" @ cc <: E.list E.string; - "object" @ object_ <: E.string; - "state" @? st <: state; - ] - -let tag ({ ty; href; name }: Types.tag) = - ap_obj (match ty with `Mention -> "Mention" | `Hashtag -> "Hashtag") [ - "href" @ href <: E.string; - "name" @ name <: E.string; - ] - -let attachment ({media_type; name; url; type_}: Types.attachment) = - obj [ - "type" @? type_ <: E.string; - "mediaType" @? media_type <: E.string; - "name" @? name <: E.string; - "url" @ url <: E.string; - ] - -let note ({ id; actor; to_; in_reply_to; cc; content; sensitive; source; summary; - attachment=att; - published; tags; raw=_ }: Types.note) = - let att = match att with [] -> None | _ -> Some att in - ap_obj "Note" [ - "id" @ id <: E.string; - "actor" @ actor <: E.string; - "attachment" @? att <: E.list attachment; - "to" @ to_ <: E.list E.string; - "inReplyTo" @? in_reply_to <: E.string; - "cc" @ cc <: E.list E.string; - "content" @ content <: E.string; - "sensitive" @ sensitive <: E.bool; - "source" @? source <: E.string; - "summary" @? summary <: E.string; - "published" @? published <: ptime; - "tags" @ tags <: E.list (or_raw tag); - ] - -let block ({ id; obj; published; actor; raw=_ }: Types.block) = - ap_obj "Block" [ - "id" @ id <: E.string; - "object" @ obj <: E.string; - "actor" @ actor <: E.string; - "published" @? published <: ptime; - ] - -let like ({ id; actor; published; obj; raw=_ }: Types.like) = - ap_obj "Like" [ - "id" @ id <: E.string; - "actor" @ actor <: E.string; - "object" @ obj <: E.string; - "published" @? published <: ptime; - ] - - -let core_obj : Types.core_obj E.encoder = function - | `Follow f -> follow f - | `Block b -> block b - | `Note n -> note n - | `Person p -> person p - | `Like l -> like l - | `Link r -> E.string r - -let event enc : _ Types.event E.encoder = function - | `Announce a -> announce enc a - | `Undo u -> undo enc u - | `Delete d -> delete enc d - | `Create c -> create enc c - | `Accept a -> accept enc a - -let object_ : Types.obj E.encoder = function - | #Types.core_obj as c -> core_obj c - | #Types.core_event as e -> event core_obj e - -module Webfinger = struct - - let ty = function - | `ActivityJson -> E.string Constants.ContentType.activity_json - | `Html -> E.string Constants.ContentType.html - | `ActivityJsonLd -> E.string Constants.ContentType.ld_json_activity_streams - | `Json -> E.string Constants.ContentType.plain_json - - let link = function - | Types.Webfinger.Self (t, href) -> obj [ - "href" @ href <: E.string; - "rel" @ Constants.Webfinger.self_rel <: E.string; - "type" @ t <: ty; - ] - | ProfilePage (t, href) -> - obj [ - "href" @ href <: E.string; - "rel" @ Constants.Webfinger.profile_page <: E.string; - "type" @ t <: ty; - ] - | OStatusSubscribe template -> obj [ - "rel" @ Constants.Webfinger.ostatus_rel <: E.string; - "template" @ template <: E.string; - ] - - let query_result ({subject;aliases;links}: Types.Webfinger.query_result) = - obj [ - "subject" @ subject <: E.string; - "aliases" @ aliases <: E.(list string); - "links" @ links <: E.list link; - ] - -end - -module Nodeinfo = struct - - let software (s: Types.Nodeinfo.software) = - obj [ - "name" @ s.name <: E.string; - "version" @ s.version <: E.string; - ] - - let usage_users ({ total; active_month; active_half_year }: Types.Nodeinfo.usage_users) = - obj [ - "total" @ total <: E.int; - "activeMonth" @ active_month <: E.int; - "activeHalfyear" @ active_half_year <: E.int; - ] - - let usage ({ local_posts; users } : Types.Nodeinfo.usage) = - obj [ - "users" @ users <: usage_users; - "localPosts" @ local_posts <: E.int - ] - - let t ({ software=software'; protocols; inbound_services; outbound_services; usage=usage'; - open_registrations; metadata; raw=_ } : Types.Nodeinfo.t) = - obj [ - "version" @ "2.0" <: E.string; - "software" @ software' <: software; - "protocols" @ protocols <: E.list E.string; - "services" @ obj [ - "inbound" @ inbound_services <: E.list E.string; - "outbound" @ outbound_services <: E.list E.string; - ] <: Fun.id; - "usage" @ usage' <: usage; - "openRegistrations" @ open_registrations <: E.bool; - "metadata" @? metadata <: Fun.id; - ] - -end - - -(* module Build (S: sig - * type user - * - * val owner: user -> Uri.t - * - * end) = struct - * - * end *) diff --git a/lib/activitypub/readme.md b/lib/activitypub/readme.md deleted file mode 100644 index 7282026..0000000 --- a/lib/activitypub/readme.md +++ /dev/null @@ -1,5 +0,0 @@ -# Activitypub Encoding - -This module defines functions to parse to and from activitypub JSONs from other servers. - -Taken from [Ocamlot](https://github.com/gopiandcode/ocamlot). diff --git a/lib/activitypub/types.ml b/lib/activitypub/types.ml deleted file mode 100644 index e4a56e9..0000000 --- a/lib/activitypub/types.ml +++ /dev/null @@ -1,245 +0,0 @@ -type yojson = Yojson.Safe.t -let pp_yojson fmt vl = Yojson.Safe.pretty_print fmt vl -let equal_yojson l r = Yojson.Safe.equal l r - -(** * Collections *) -type 'a ordered_collection_page = { - id: string; - prev: string option; - next: string option; - is_ordered: bool; - items: 'a list; - part_of: string option; - total_items: int option; -} [@@deriving show, eq] - - -type 'a ordered_collection = { - id: string option; - total_items: int; - contents: [ - | `Items of (bool * 'a list) - | `First of 'a ordered_collection_page - ] -} [@@deriving show, eq] - -(** * Events *) -type 'a create = { - id: string; - actor: string; - published: Ptime.t option; - to_: string list; - cc: string list; - direct_message: bool; - obj: 'a; - raw: yojson; -} [@@deriving show, eq] - - -type 'a announce = { - id: string; - actor: string; - published: Ptime.t option; - to_: string list; - cc: string list; - obj: 'a; - raw: yojson; -} [@@deriving show, eq] - - -type 'a accept = { - id: string; - actor: string; - published: Ptime.t option; - obj: 'a; - raw: yojson; -} [@@deriving show, eq] - -type 'a undo = { - id: string; - actor: string; - published: Ptime.t option; - obj: 'a; - raw: yojson; -} [@@deriving show, eq] - -type 'a delete = { - id: string; - actor: string; - published: Ptime.t option; - obj: 'a; - raw: yojson; -} -[@@deriving show, eq] - -type 'a event = [ - `Create of 'a create - | `Announce of 'a announce - | `Accept of 'a accept - | `Undo of 'a undo - | `Delete of 'a delete -] [@@deriving show, eq] - - -(** * Objects *) -type public_key = { - id: string; - owner: string; - pem: string; -} [@@deriving show, eq] - -type person = { - id: string; - name: string option; - url: string option; - - preferred_username: string option; - - inbox: string; - outbox: string; - - summary: string option; - - public_key: public_key; - - manually_approves_followers: bool; - - discoverable: bool; - followers: string option; - following: string option; - icon: string option; - raw: yojson; -} [@@deriving show, eq] - -type follow = { - id: string; - actor: string; - cc: string list; - to_: string list; - object_: string; - state: [`Pending | `Cancelled ] option; - raw: yojson; -} [@@deriving show, eq] - -type tag = { - ty: [`Mention | `Hashtag ]; - href: string; - name: string; -} [@@deriving show, eq] - -type attachment = { - media_type: string option; - name: string option; - type_: string option; - url: string; -} [@@deriving show, eq] - -type note = { - id: string; - actor: string; - attachment: attachment list; - to_: string list; - in_reply_to: string option; - cc: string list; - content: string; - sensitive: bool; - source: string option; - summary: string option; - published: Ptime.t option; - tags: [ `Raw of yojson | `Value of tag ] list; - raw: yojson; -} [@@deriving show, eq] - -type block = { - id: string; - obj: string; - published: Ptime.t option; - actor: string; - raw: yojson; -} [@@deriving show, eq] - -type like = { - id: string; - actor: string; - published: Ptime.t option; - obj: string; - raw: yojson; -} -[@@deriving show, eq] - - -type core_obj = [ - `Person of person - | `Follow of follow - | `Note of note - | `Block of block - | `Like of like - | `Link of string -] [@@deriving show, eq] - -type core_event = core_obj event -[@@deriving show, eq] - -type obj = [ core_obj | core_event ] -[@@deriving show, eq] - -module Webfinger = struct - - type ty = [ `Html | `Json | `ActivityJson | `ActivityJsonLd ] - [@@deriving show, eq] - - type link = - | Self of ty * string - | ProfilePage of ty * string - | OStatusSubscribe of string - [@@deriving show, eq] - - type query_result = { - subject: string; - aliases: string list; - links: link list; - } - [@@deriving show, eq] - - let self_link query = - query.links - |> List.find_map (function - | Self ((`ActivityJson | `ActivityJsonLd | `Json), url) -> Some (Uri.of_string url) - | _ -> None) - -end - -module Nodeinfo = struct - - type software = { - name: string; - version: string; - } - [@@deriving show, eq] - - type usage_users = { - total: int; - active_month: int; - active_half_year: int; - } - [@@deriving show, eq] - - type usage = { - local_posts: int; - users: usage_users; - } - [@@deriving show, eq] - - type t = { - software: software; - protocols: string list; - inbound_services: string list; - outbound_services: string list; - usage: usage; - open_registrations: bool; - metadata: yojson option; - raw: yojson; - } - [@@deriving show, eq] - -end diff --git a/lib/ast_types.ml b/lib/ast_types.ml new file mode 100644 index 0000000..1c5de60 --- /dev/null +++ b/lib/ast_types.ml @@ -0,0 +1,178 @@ +open Format +module Fixture = Fixture + +type ast_row = + | Uuidv4 of string * ast_row + | Name of string * ast_row + | Foreign of string * string * string * ast_row + (* parent, row, child_name, row *) + | End +[@@deriving show, eq] + +type ast_table = + | Table of string * ast_row * ast_table + | End +[@@deriving show, eq] + +let rec print_row = function + | Uuidv4 (s, r) -> + printf "UUIDv4(%s)," s; + print_row r + | Foreign (p, r, c, next_row) -> + printf "Foreign(%s.%s, %s)," p r c; + print_row next_row + | Name (s, r) -> + printf "Name(%s)," s; + print_row r + | End -> printf "\n" + + +let rec print = function + | Table (s, r, t) -> + printf "%s:" s; + print_row r; + print t + | End -> printf "\n" + + +(* AST to Fixtures *) + +type ast_row_relation = + | PRow of Fixture.t + | CRow of (string * string * (string list -> Fixture.t)) + +type ast_table_relation = + | PTable of string * Fixture.t list + | CTable of string * string * string * (string list -> Fixture.t list) + (** parent, row, child_name, row *) + +let table_name = function + | PTable (n,_) -> n + | CTable (_,_,c,_) -> c + +let rec ast_row_to_fixtures = function + | Uuidv4 (s, r) -> PRow (Fixture.Uuidv4 s) :: ast_row_to_fixtures r + | Foreign (p, r, c, next_row) -> + CRow (p, r, fun l -> Fixture.Foreign (c, l)) :: ast_row_to_fixtures next_row + | Name (s, r) -> PRow (Fixture.Name s) :: ast_row_to_fixtures r + | End -> [] + + +let ast_table_to_table name rows = + (** Convert an AST table to a Fixture table that we can more easily work with for + feeding the generated data as input into fixtures that depend on the generated + data from other fixtures *) + List.fold_left + (fun tbl row -> + match row with + | PRow r -> + (match tbl with + | PTable (n, l) -> PTable (n, r :: l) + | CTable (p, pr, c, f) -> CTable (p, pr, c, fun l -> r :: f l)) + | CRow (p, pr, f) -> + (match tbl with + | PTable (c, lr) -> CTable (p, pr, c, fun l -> f l :: lr) + | CTable _ -> failwith "Cannot have multiple relations")) + (PTable (name, [])) + rows + + +let rec ast_table_to_tables ast = + (** Convert an AST table to a list of Fixture tables, so once data has been generated + it can be used as input for the next entry *) + match ast with + | Table (name, r, t) -> + print_endline ("Converting table: " ^ name); + ast_table_to_table name (ast_row_to_fixtures r) :: ast_table_to_tables t + | End -> [] + +let%test "ast_table_to_tables" = + let purchase = Table ("purchase", Uuidv4 ("id", Name ("name", End)), End) in + let ast = Table ("user", Uuidv4 ("id", Name ("name", End)), purchase) in + let tables = ast_table_to_tables ast in + List.length tables == 2 + +let generated_fixtures = ref (Hashtbl.create 10) + +let rec resolve_fixtures tables name ~amount = + (* Verify if we have already generated fixtures for this table *) + let maybe_fixtures = Hashtbl.find_opt !generated_fixtures name in + match maybe_fixtures with + | Some fixtures -> (name, fixtures) + | None -> + let maybe_table = List.find_opt (fun tbl -> table_name tbl = name) tables + in + match maybe_table with + | Some (PTable (n,l)) -> + let resolved = (n, Fixture.compile l ~amount) in + (* store the generated fixtures for this table *) + Hashtbl.add !generated_fixtures name (snd resolved); + resolved + | Some (CTable (p,pr,c,create_fixtures)) -> ( + let (_, parent_fixtures) = resolve_fixtures tables p ~amount in + (* store the generated fixtures for this table *) + Hashtbl.add !generated_fixtures name parent_fixtures; + print_endline ("Resolving fixtures for " ^ c); + for i = 0 to List.length parent_fixtures - 1 do + print_endline ("Parent fixture: " ^ Fixture.csv_of_string_list (List.nth parent_fixtures i)); + done; + let generated_ids = Fixture.find_entries_for_header parent_fixtures pr in + print_endline ("Generated ids: " ^ String.concat ", " (Result.get_ok generated_ids)); + match generated_ids with + | Ok ids -> (c, Fixture.compile ~amount (create_fixtures ids)) + | Error e -> failwith e + ) + | None -> failwith ("Could not find table " ^ name) + +let%test "resolve_fixtures" = + let tables = [ + PTable ("user", [Fixture.Uuidv4 "id"; Fixture.Uuidv4 "uuid"]); + CTable ("user", "id", "posts", fun ids -> [Fixture.Foreign ("user_id", ids)]) + ] in + let (_, user_fixtures) = resolve_fixtures tables "user" ~amount:1 in + let (_, purchase_fixtures) = resolve_fixtures tables "posts" ~amount:1 in + for i = 0 to List.length user_fixtures - 1 do + print_endline ("User fixture: " ^ Fixture.csv_of_string_list (List.nth user_fixtures i)); + done; + for i = 0 to List.length purchase_fixtures - 1 do + print_endline ("Purchase fixture: " ^ Fixture.csv_of_string_list (List.nth purchase_fixtures i)); + done; + match (user_fixtures,purchase_fixtures) with + | ([["id";_];[u;_]], [["user_id"]; [v]]) -> v = u + | _ -> + false + + +let show_tables tables = + let show_table = function + | PTable (n,_) -> n + | CTable (_,_,c,_) -> c + in + tables |> List.map show_table |> String.concat "\n" + + +let compile ast ~amount = + let tables = ast_table_to_tables ast in + print_endline ("Table length: " ^ string_of_int (List.length tables)); + print_endline (show_tables tables); + let resolve_fixtures' = function + | PTable (n,l) -> + let resolved = (n, Fixture.compile l ~amount) in + (* store the generated fixtures for this table *) + Hashtbl.add !generated_fixtures n (snd resolved); + resolved + | CTable (p,pr,c,create_fixtures) -> + let (_, parent_fixtures) = resolve_fixtures tables p ~amount in + (* store the generated fixtures for this table *) + Hashtbl.add !generated_fixtures c parent_fixtures; + print_endline ("Resolving fixtures for " ^ c); + let generated_ids = Fixture.find_entries_for_header parent_fixtures pr in + match generated_ids with + | Ok ids -> (c, Fixture.compile ~amount (create_fixtures ids)) + | Error e -> failwith e + in + let result = List.map resolve_fixtures' tables in + print_endline ("Result names: " ^ String.concat ", " (List.map fst result)); + result + + @@ -1,18 +1,15 @@ +(menhir + (modules parser)) + +(ocamllex lexer) + (library - (name ann_bloop) - (libraries uri - cohttp-lwt-unix - containers - base64 - mirage-crypto - x509 - lwt - cohttp - dream - calendar - ptime - decoders-yojson + (name fixgen) + (libraries + uuidm ) - (preprocess (pps lwt_ppx ppx_yojson_conv ppx_inline_test )) + (modules parser lexer ast_types fixture) + (preprocess (pps ppx_inline_test)) (inline_tests) ) + diff --git a/lib/fixture.ml b/lib/fixture.ml new file mode 100644 index 0000000..31a6e9c --- /dev/null +++ b/lib/fixture.ml @@ -0,0 +1,109 @@ +let names = + [ "Alice" + ; "Bob" + ; "Charlie" + ; "Dave" + ; "Eve" + ; "Frank" + ; "Grace" + ; "Heidi" + ; "Ivan" + ; "Judy" + ; "Mallory" + ; "Oscar" + ; "Peggy" + ; "Sybil" + ; "Trent" + ; "Victor" + ; "Walter" + ] + + +let random_name () = List.nth names (Random.int (List.length names)) +let%test "random_name" = List.mem (random_name ()) names + +type t = + | Name of string + | Uuidv4 of string + | Foreign of (string * string list) +(* (Name, foreign ids to pick from) *) + +let add_name name fixtures = Name name :: fixtures +let add_uuid uuid fixtures = Uuidv4 uuid :: fixtures +let add_foreign id values fixtures = Foreign (id, values) :: fixtures +let random_value_in_list values = List.nth values (Random.int (List.length values)) + +let%test "random_value_in_list" = + let values = [ "a"; "b"; "c" ] in + let result = random_value_in_list values in + List.mem result values + + +let generate_fixture fixture = + match fixture with + | Name _ -> random_name () + | Uuidv4 _ -> Uuidm.v `V4 |> Uuidm.to_string + | Foreign (_, reference) -> random_value_in_list reference + + +let%test "generate_uuid" = + generate_fixture (Uuidv4 "some_id") != generate_fixture (Uuidv4 "some_id") + + +let id_of_fixture fixture = + match fixture with + | Name id -> id + | Uuidv4 id -> id + | Foreign (id, _) -> id + + +let rec replicate element n = + match n with + | 0 -> [] + | n -> element :: replicate element (n - 1) + + +let compile fixtures ~amount = + let identifiers = List.map id_of_fixture fixtures in + let values = replicate fixtures amount |> List.map (List.map generate_fixture) in + identifiers :: values + + +let%test "create" = + let defs = compile [ Uuidv4 "id"; Name "name" ] ~amount:2 in + match defs with + | [ [ "id"; "name" ]; [ _; _ ]; [ _; _ ] ] -> true + | _ -> false + + +let get_id foreign_fixture = + match String.split_on_char '.' foreign_fixture with + | [ _; id ] -> Ok id + | _ -> Error "Not a foreign fixture" + + +let rec csv_of_string_list strs = + match strs with + | [] -> "" + | str :: [] -> str + | str :: rest -> str ^ "," ^ csv_of_string_list rest + + +let find_entries_for_header str_fixtures str = + match str_fixtures with + | [] -> Error "No fixtures" + | header :: rest -> + let maybe_index = List.find_index (fun s -> s = str) header in + (match maybe_index with + | Some index -> Ok (List.map (fun row -> List.nth row index) rest) + | None -> Error ("Could not find header: " ^ str ^ " in " ^ csv_of_string_list header)) + + +let csv_of_generated_fixtures fixtures = + let of_strings = List.map csv_of_string_list fixtures in + String.concat "\n" of_strings + + +let%test "csv_of_generated_fixtures" = + let result = [ [ "id"; "name" ]; [ "1234"; "John" ] ] |> csv_of_generated_fixtures in + result = "id,name\n1234,John" diff --git a/lib/http_date.ml b/lib/http_date.ml deleted file mode 100644 index 38bda02..0000000 --- a/lib/http_date.ml +++ /dev/null @@ -1,37 +0,0 @@ -(* 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 - -let%test "rev" = - List.equal Int.equal (List.rev [ 3; 2; 1 ]) [ 3; 2; 1 ] - diff --git a/lib/lexer.mll b/lib/lexer.mll new file mode 100644 index 0000000..e8a7a73 --- /dev/null +++ b/lib/lexer.mll @@ -0,0 +1,27 @@ +{ +open Parser + +exception SyntaxError of string +} + +let digit = ['0'-'9'] +let frac = '.' digit* +let exp = ['e' 'E'] ['-' '+']? digit+ +let float = digit* frac? exp? +let white = [' ' '\t']+ +let newline = '\r' | '\n' | "\r\n" +let id = ['a'-'z' 'A'-'Z' '_']* + + +rule read = + parse + | white { read lexbuf } + | id { IDENTIFIER (Lexing.lexeme lexbuf) } + | "uuidv4" { UUIDV4 } + | "name" { NAME } + | ":" { COLON } + | "," { COMMA } + | "\n" { NEWLINE } + | "." { DOT } + | eof { EOF } + | _ as c { failwith (Printf.sprintf "unexpected character: %C" c) } diff --git a/lib/parser.ml b/lib/parser.ml deleted file mode 100644 index 2e9d759..0000000 --- a/lib/parser.ml +++ /dev/null @@ -1,75 +0,0 @@ -(*---------------------------------------------------------------------------- - 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/parser.mly b/lib/parser.mly new file mode 100644 index 0000000..f2f53fd --- /dev/null +++ b/lib/parser.mly @@ -0,0 +1,31 @@ +%{ + open Ast_types +%} +%token COMMA +%token <string> IDENTIFIER +%token UUIDV4 +%token NEWLINE +%token NAME +%token COLON +%token DOT +%token EOF +%start <ast_table option > prog +%% + +prog: + | e = expr; EOF { Some e } + ; + +expr: + | tbl = IDENTIFIER; COLON; r = row; NEWLINE; e = expr { Table (tbl,r, e) } + | tbl = IDENTIFIER; COLON; r = row { Table (tbl,r, End) } + ; + +row: + | row_title = IDENTIFIER; parent = IDENTIFIER; DOT; parent_id = IDENTIFIER; COMMA; r = row { Foreign (parent,parent_id,row_title, r) } + | row_title = IDENTIFIER; parent = IDENTIFIER; DOT; parent_id = IDENTIFIER; { Foreign (parent,parent_id,row_title, End) } + | row_title = IDENTIFIER; UUIDV4; COMMA; r = row { Uuidv4 (row_title, r) } + | row_title = IDENTIFIER; UUIDV4 { Uuidv4 (row_title, End) } + | row_title = IDENTIFIER; NAME; COMMA; r = row { Name (row_title, r) } + | row_title = IDENTIFIER; NAME { Name (row_title, End) } + ; diff --git a/lib/sig.ml b/lib/sig.ml deleted file mode 100644 index b4f49d7..0000000 --- a/lib/sig.ml +++ /dev/null @@ -1,167 +0,0 @@ -(* 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 deleted file mode 100644 index ba802c0..0000000 --- a/lib/user.ml +++ /dev/null @@ -1,31 +0,0 @@ -open Ppx_yojson_conv_lib.Yojson_conv.Primitives -open Cohttp -open Cohttp_lwt_unix -open Lwt - -type public_key = { - id : string; - owner : string; - public_key_pem : string; [@key "publicKeyPem"] -} -[@@deriving yojson] [@@yojson.allow_extra_fields] - -type t = { name : string; public_key : public_key [@key "publicKey"] } -[@@deriving yojson] [@@yojson.allow_extra_fields] - -let activity_header = - Some (Header.of_list [ ("Accept", "application/activity+json") ]) - -let get_user actor_url = - let%lwt _, body = - Client.get ?headers:activity_header (Uri.of_string actor_url) - in - body |> Cohttp_lwt.Body.to_string >|= fun body -> - let body = Yojson.Safe.from_string body |> t_of_yojson in - body - -let get_public_pem user = - user.public_key.public_key_pem |> Cstruct.of_string - |> X509.Public_key.decode_pem - -let name user = user.name |