Initial commit

1 files changed, 303 insertions, 0 deletions

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 *)