From cc783c157f31e7e713c8b83be67449b1859dac27 Mon Sep 17 00:00:00 2001 From: Marc Coquand Date: Wed, 20 Dec 2023 20:43:25 -0600 Subject: Initial commit --- lib/activitypub/activitypub.ml | 5 + lib/activitypub/common.ml | 47 ++++++ lib/activitypub/constants.ml | 49 ++++++ lib/activitypub/decode.ml | 352 +++++++++++++++++++++++++++++++++++++++++ lib/activitypub/dune | 3 + lib/activitypub/encode.ml | 303 +++++++++++++++++++++++++++++++++++ lib/activitypub/readme.md | 5 + lib/activitypub/types.ml | 245 ++++++++++++++++++++++++++++ lib/dune | 18 +++ lib/http_date.ml | 37 +++++ lib/parser.ml | 75 +++++++++ lib/sig.ml | 167 +++++++++++++++++++ lib/user.ml | 31 ++++ 13 files changed, 1337 insertions(+) create mode 100644 lib/activitypub/activitypub.ml create mode 100644 lib/activitypub/common.ml create mode 100644 lib/activitypub/constants.ml create mode 100644 lib/activitypub/decode.ml create mode 100644 lib/activitypub/dune create mode 100644 lib/activitypub/encode.ml create mode 100644 lib/activitypub/readme.md create mode 100644 lib/activitypub/types.ml create mode 100644 lib/dune create mode 100644 lib/http_date.ml create mode 100644 lib/parser.ml create mode 100644 lib/sig.ml create mode 100644 lib/user.ml (limited to 'lib') diff --git a/lib/activitypub/activitypub.ml b/lib/activitypub/activitypub.ml new file mode 100644 index 0000000..511b4a3 --- /dev/null +++ b/lib/activitypub/activitypub.ml @@ -0,0 +1,5 @@ +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 new file mode 100644 index 0000000..59c7099 --- /dev/null +++ b/lib/activitypub/common.ml @@ -0,0 +1,47 @@ +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 new file mode 100644 index 0000000..0488335 --- /dev/null +++ b/lib/activitypub/constants.ml @@ -0,0 +1,49 @@ +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 new file mode 100644 index 0000000..4074e68 --- /dev/null +++ b/lib/activitypub/decode.ml @@ -0,0 +1,352 @@ +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 new file mode 100644 index 0000000..9222a82 --- /dev/null +++ b/lib/activitypub/dune @@ -0,0 +1,3 @@ +(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 new file mode 100644 index 0000000..2b64e76 --- /dev/null +++ b/lib/activitypub/encode.ml @@ -0,0 +1,303 @@ +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 new file mode 100644 index 0000000..7282026 --- /dev/null +++ b/lib/activitypub/readme.md @@ -0,0 +1,5 @@ +# 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 new file mode 100644 index 0000000..e4a56e9 --- /dev/null +++ b/lib/activitypub/types.ml @@ -0,0 +1,245 @@ +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/dune b/lib/dune new file mode 100644 index 0000000..f04ae9a --- /dev/null +++ b/lib/dune @@ -0,0 +1,18 @@ +(library + (name ann_bloop) + (libraries uri + cohttp-lwt-unix + containers + base64 + mirage-crypto + x509 + lwt + cohttp + dream + calendar + ptime + decoders-yojson + ) + (preprocess (pps lwt_ppx ppx_yojson_conv ppx_inline_test )) + (inline_tests) + ) diff --git a/lib/http_date.ml b/lib/http_date.ml new file mode 100644 index 0000000..38bda02 --- /dev/null +++ b/lib/http_date.ml @@ -0,0 +1,37 @@ +(* 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/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 new file mode 100644 index 0000000..ba802c0 --- /dev/null +++ b/lib/user.ml @@ -0,0 +1,31 @@ +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 -- cgit v1.2.3