Initial commit

13 files changed, 1337 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
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