From 262f161f42c4e59beec41c6f440336c38385426a Mon Sep 17 00:00:00 2001
From: Marc Coquand <marc@mccd.space>
Date: Wed, 20 Dec 2023 20:46:00 -0600
Subject: Initial commit

---
 lib/activitypub/decode.ml | 352 ----------------------------------------------
 1 file changed, 352 deletions(-)
 delete mode 100644 lib/activitypub/decode.ml

(limited to 'lib/activitypub/decode.ml')

diff --git a/lib/activitypub/decode.ml b/lib/activitypub/decode.ml
deleted file mode 100644
index 4074e68..0000000
--- a/lib/activitypub/decode.ml
+++ /dev/null
@@ -1,352 +0,0 @@
-open Containers
-open Common
-
-let decode_string enc vl = D.decode_string enc vl |> Result.map_err D.string_of_error
-
-let id = D.(one_of ["string", string; "id", field "id" string])
-
-let ordered_collection_page obj =
-  let open D in
-  let* () = field "type" @@ constant ~msg:"Expected OrderedCollectionPage (received %s)" "OrderedCollectionPage"
-  and* id = field "id" string
-  and* next = field_opt "next" id
-  and* prev = field_opt "prev" id
-  and* part_of = field_opt "partOf" string
-  and* total_items = field_opt "totalItems" int
-  and* (is_ordered, items) = items obj in
-  succeed ({id; next; prev; part_of; total_items; is_ordered; items}: _ Types.ordered_collection_page)
-
-let ordered_collection obj =
-  let open D in
-  let* () = field "type" @@ constant ~msg:"Expected OrderedCollection (received %s)" "OrderedCollection"
-  and* id = field_opt "id" string
-  and* total_items = field "totalItems" int
-  and* contents =
-    one_of [
-      "items", map (fun v -> `Items v) (items obj);
-      "first", map (fun v -> `First v) (field "first" (ordered_collection_page obj))
-    ] in
-  succeed ({id; total_items; contents}: _ Types.ordered_collection)
-
-let mention =
-  let open D in
-  let* () = field "type" @@ constant ~msg:"expected Mention (received %s)" "Mention"
-  and* href = field "href" string
-  and* name = field "name" string in
-  succeed ({ty=`Mention; href;name} : Types.tag)
-
-let hashtag =
-  let open D in
-  let* () = field "type" @@ constant ~msg:"expected Hashtag (received %s)" "Hashtag"
-  and* href = field "href" string
-  and* name = field "name" string in
-  succeed ({ty=`Hashtag; href;name}: Types.tag)
-
-let tag =
-  let open D in
-  let* ty = field "type" string in
-  match ty with
-  | "Mention" -> mention
-  | "Hashtag" -> hashtag
-  | _ -> fail (Printf.sprintf "unknown tag %s" ty)
-
-let undo obj =
-  let open D in
-  let* () = field "type" @@ constant ~msg:"expected Undo (received %s)" "Undo"
-  and* id = field "id" string
-  and* actor = field "actor" id
-  and* published = field_opt "published" timestamp
-  and* obj = field "object" obj
-  and* raw = value in
-  succeed ({id;published;actor;obj;raw}: _ Types.undo)
-
-let like =
-  let open D in
-  let* () = field "type" @@ constant ~msg:"expected Like (received %s)" "Like"
-  and* id = field "id" string
-  and* actor = field "actor" id
-  and* published = field_opt "published" timestamp
-  and* obj = field "object" id
-  and* raw = value in
-  succeed ({id; actor; published; obj; raw}: Types.like)
-
-let tombstone =
-  let open D in
-  let* () = field "type" @@ constant ~msg:"expected Tombstone (received %s)" "Tombstone"
-  and* id = field "id" string in
-  succeed id
-
-let delete obj =
-  let open D in
-  let* () = field "type" @@ constant ~msg:"expected Delete (received %s)" "Delete"
-  and* id = field "id" string
-  and* actor = field "actor" id
-  and* published = field_opt "published" timestamp
-  and* obj = field "object" obj
-  and* raw = value in
-  succeed ({id;published;actor;obj;raw}: _ Types.delete)
-
-let block =
-  let open D in
-  let* () = field "type" @@ constant ~msg:"expected Block (received %s)" "Block"
-  and* id = field "id" string
-  and* obj = field "object" string
-  and* published = field_opt "published" timestamp
-  and* actor = field "actor" id
-  and* raw = value in
-  succeed ({id;published;obj;actor;raw}: Types.block)
-
-let accept obj =
-  let open D in
-  let* () = field "type" @@ constant ~msg:"expected Accept (received %s)" "Accept"
-  and* id = field "id" string
-  and* actor = field "actor" id
-  and* published = field_opt "published" timestamp
-  and* obj = field "object" obj
-  and* raw = value in
-  succeed ({id;published;actor;obj;raw}: _ Types.accept)
-
-let public_key =
-  let open D in
-  let* id = field "id" string
-  and* owner = field "owner" string
-  and* pem = field "publicKeyPem" string in
-  succeed ({id;owner;pem}: Types.public_key)
-
-let attachment =
-  let open D in
-  let* media_type = field_opt "mediaType" string
-  and* name = field_opt "name" string
-  and* type_ = field_opt "type" string
-  and* url = field "url" string in
-  succeed ({media_type;name;type_;url}: Types.attachment)
-
-
-let person =
-  let open D in
-  let* () = field "type" @@ constant ~msg:"expected Person (received %s)" "Person"
-  and* id = field "id" string
-  and* name = field_opt "name" string
-  and* url = field_or_default "url" (nullable string) None
-  and* preferred_username = field_opt "preferredUsername" string
-  and* inbox = field "inbox" string
-  and* outbox = field "outbox" string
-  and* summary = field_opt "summary" string
-  and* public_key = field "publicKey" public_key
-  and* manually_approves_followers =
-    field_or_default "manuallyApprovesFollowers" bool false
-  and* discoverable = field_or_default "discoverable" bool false
-  and* followers = field_opt "followers" string
-  and* following = field_opt "following" string
-  and* icon = maybe (at ["icon";"url"] string)
-  and* raw = value in
-  succeed ({
-    id;
-    name;
-    url;
-
-    preferred_username;
-
-    inbox;
-    outbox;
-
-    summary;
-
-    public_key;
-
-    manually_approves_followers;
-
-    discoverable;
-    followers;
-    following;
-    icon;
-    raw;
-  }: Types.person)
-
-let note = 
-  let open D in
-  let* () = field "type" @@ constant ~msg:"expected Note (received %s)" "Note"
-  and* id = field "id" string
-  and* actor = one_of ["actor", field "actor" id; "attributed_to", field "attributedTo" id]
-  and* attachment = field_or_default "attachment" (singleton_or_list attachment) []
-  and* to_ = field "to" (singleton_or_list string)
-  and* in_reply_to = field_or_default "inReplyTo" (nullable string) None
-  and* cc = field_or_default "cc" (singleton_or_list string) []
-  and* content = field "content" string
-  and* source = field_opt "source"
-                  (one_of ["string", string; "multi-encode", field "content" string])
-  and* summary = field_or_default "summary" (nullable string) None
-  and* sensitive = field_or_default "sensitive" (nullable bool) None
-  and* published = field_opt "published" timestamp
-  and* tags = field_or_default "tag" (lossy_list_of tag) []
-  and* raw = value in
-  succeed ({ id; actor; attachment; in_reply_to; to_; cc;
-             sensitive=Option.value ~default:false sensitive;
-             content; source; summary; tags; published; raw }: Types.note)
-
-let follow =
-  let open D in
-  let* () = field "type" @@ constant ~msg:"expected create object (received %s)" "Follow"
-  and* actor = field "actor" id
-  and* cc = field_or_default "cc" (singleton_or_list string) []
-  and* to_ = field_or_default "to" (singleton_or_list string) []
-  and* id = field "id" string
-  and* object_ = field "object" id
-  and* state = field_opt "state" (string >>= function "pending" -> succeed `Pending
-                                                    | "cancelled" -> succeed `Cancelled
-                                                    | _ -> fail "unknown status")
-  and* raw = value in
-  succeed ({actor; cc; to_; id; object_; state; raw}: Types.follow)
-
-let announce obj =
-  let open D in
-  let* () = field "type" @@ constant ~msg:"expected create object (received %s)" "Announce"
-  and* actor = field "actor" id
-  and* id = field "id" string
-  and* published = field_opt "published" timestamp
-  and* to_ = field "to" (singleton_or_list string)
-  and* cc = field_or_default "cc" (singleton_or_list string) []
-  and* obj = field "object" obj
-  and* raw = value in
-  succeed ({id; published; actor; to_; cc; obj; raw}: _ Types.announce)
-
-let create obj =
-  let open D in
-  let* () = field "type" @@ constant ~msg:"expected create object (received %s)" "Create"
-  and* id = field "id" string
-  and* actor = field "actor" id
-  and* direct_message = field_or_default "direct" bool false
-  and* published = field_opt "published" timestamp
-  and* to_ = field_or_default "to" (singleton_or_list string) []
-  and* cc = field_or_default "cc" (singleton_or_list string) []
-  and* obj = field "object" obj
-  and* raw = value in
-
-  succeed ({
-    id; actor; published;
-    to_; cc;
-    direct_message;
-    obj;
-    raw;
-  }: _ Types.create)
-
-let core_obj () =
-  let open D in
-  let* ty = field_opt "type" string in
-  match ty with
-  | Some "Person" -> person >|= fun v -> `Person v
-  | Some "Follow" -> follow >|= fun v -> `Follow v
-  | Some "Note" -> note >|= fun v -> `Note v
-  | Some "Block" -> block >|= fun v -> `Block v
-  | Some "Like" -> like >|= fun v -> `Like v
-  | None -> string >|= fun v -> `Link v
-  | Some ev -> fail ("unsupported event" ^ ev)
-
-let core_obj = core_obj ()
-
-let event (enc: Types.core_obj D.decoder) : Types.obj D.decoder =
-  let open D in
-  let* ty = field "type" string in
-  match ty with
-  | "Create" -> create enc >|= fun v -> `Create v
-  | "Accept" -> accept enc >|= fun v -> `Accept v
-  | "Undo" -> undo enc >|= fun v -> `Undo v
-  | "Delete" -> delete enc >|= fun v -> `Delete v
-  | "Announce" -> announce enc >|= fun v -> `Announce v
-  | _ -> fail "unsupported event"
-
-let obj : Types.obj D.decoder =
-  D.one_of [
-    "core_obj", core_obj;
-    "core_obj event", (event core_obj)
-  ]
-
-module Webfinger = struct
-
-  let ty =
-    let open D in
-    string >>= function
-    | str when String.prefix ~pre:Constants.ContentType.html str ->
-      succeed `Html
-    | str when String.prefix ~pre:Constants.ContentType.plain_json str ->
-      succeed `Json
-    | str when String.prefix ~pre:Constants.ContentType.activity_json str ->
-      succeed `ActivityJson
-    | str when String.prefix ~pre:Constants.ContentType.ld_json_activity_streams str ->
-      succeed `ActivityJsonLd
-    | _ ->
-      fail "unsupported self link type"
-
-  let self =
-    let open D in
-    let* ty = field "type" ty
-    and* href = field "href" string in
-    succeed @@ Types.Webfinger.Self (ty, href)
-
-  let profile_page =
-    let open D in
-    let* ty = field "type" ty
-    and* href = field "href" string in
-    succeed @@ Types.Webfinger.ProfilePage (ty, href)
-
-  let ostatus_subscribe =
-    let open D in
-    let* template = field "template" string in
-    succeed @@ Types.Webfinger.OStatusSubscribe template
-
-  let link =
-    let open D in
-    let* rel = field "rel" string in
-    match rel with
-    | "self" -> self
-    | str when String.equal str Constants.Webfinger.ostatus_rel ->
-      ostatus_subscribe
-    | str when String.equal str Constants.Webfinger.profile_page ->
-      profile_page
-    | _ -> fail "unsupported link relation"
-
-  let query_result =
-    let open D in
-    let* subject = field "subject" string
-    and* aliases = field "aliases" (list string)
-    and* links = field "links" (list_ignoring_unknown link) in
-
-    succeed Types.Webfinger.{subject;aliases;links}
-
-end
-
-module Nodeinfo = struct
-
-  let software =
-    let open D in
-    let* name = field "name" string
-    and* version = field "version" string in
-    succeed @@ Types.Nodeinfo.{name;version}
-
-  let usage_users =
-    let open D in
-    let* total = field_or_default "total" int 0
-    and* active_month = field_or_default "activeMonth" int 0
-    and* active_half_year = field_or_default "activeHalfyear" int 0 in
-    succeed @@ Types.Nodeinfo.{total; active_month; active_half_year}
-
-  let usage =
-    let open D in
-    let* users = field "users" usage_users 
-    and* local_posts = field_or_default "localPosts" int 0 in
-    succeed @@ Types.Nodeinfo.{users; local_posts}
-
-  let t =
-    let open D in
-    let* software = field "software" software
-    and* protocols = field_or_default "protocols" (list string) []
-    and* inbound_services = field_or_default "services" (field_or_default "inbound" (list string) []) []
-    and* outbound_services = field_or_default "services" (field_or_default "outbound" (list string) []) []
-    and* usage = field "usage" usage
-    and* open_registrations = field_or_default "openRegistrations" bool false 
-    and* metadata = field_opt "metadata" value
-    and* raw = value in
-    succeed @@ Types.Nodeinfo.{software;protocols;inbound_services;outbound_services;usage;open_registrations;metadata;raw}
-
-
-end
-- 
cgit v1.2.3