aboutsummaryrefslogtreecommitdiff
path: root/lib/activitypub
diff options
context:
space:
mode:
Diffstat (limited to 'lib/activitypub')
-rw-r--r--lib/activitypub/activitypub.ml5
-rw-r--r--lib/activitypub/common.ml47
-rw-r--r--lib/activitypub/constants.ml49
-rw-r--r--lib/activitypub/decode.ml352
-rw-r--r--lib/activitypub/dune3
-rw-r--r--lib/activitypub/encode.ml303
-rw-r--r--lib/activitypub/readme.md5
-rw-r--r--lib/activitypub/types.ml245
8 files changed, 1009 insertions, 0 deletions
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