aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMarc Coquand <marcc@fastmail.fr>2023-12-02 11:25:36 -0600
committerMarc Coquand <marcc@fastmail.fr>2023-12-02 11:25:36 -0600
commit189179574d847e8e9662cf78804ce9371fac988d (patch)
tree0cc2b8c27fe8cf59d4724100d8b95085fab6432d
parent4fe8c79ce03e12be04b0d928b65b1a7d475f4458 (diff)
downloadwormhole-189179574d847e8e9662cf78804ce9371fac988d.tar.gz
wormhole-189179574d847e8e9662cf78804ce9371fac988d.tar.bz2
wormhole-189179574d847e8e9662cf78804ce9371fac988d.zip
Add user
-rw-r--r--bin/main.ml24
-rw-r--r--http/inbox.hurl6
-rw-r--r--lib/dune3
-rw-r--r--lib/post.ml21
-rw-r--r--lib/post.mli31
-rw-r--r--lib/user.ml29
-rw-r--r--readme.md4
-rw-r--r--wormhole.opam3
8 files changed, 73 insertions, 48 deletions
diff --git a/bin/main.ml b/bin/main.ml
index dcd24aa..67c9786 100644
--- a/bin/main.ml
+++ b/bin/main.ml
@@ -21,7 +21,7 @@ let (fake_post_2 : Post.t) =
let webfinger =
{|
{
- "subject": "acct:blackhole@galaxy.mccd.space",
+ "subject": "acct:wormhole@galaxy.mccd.space",
"links": [
{
@@ -43,7 +43,7 @@ let actor =
"id": "https://galaxy.mccd.space/actor",
"type": "Person",
- "preferredUsername": "blackhole",
+ "preferredUsername": "wormhole",
"inbox": "https://galaxy.mccd.space/inbox",
"publicKey": {
@@ -86,8 +86,20 @@ let () =
let message_object =
Yojson.Safe.from_string body |> Post.mastodon_post_of_yojson
in
- message_object |> Post.yojson_of_mastodon_post
- |> Yojson.Safe.to_string |> Dream.log "Added post %s";
- message_object |> Post.post_of_mastodon_post |> Post.add;
- Dream.json "{}");
+ let%lwt actor =
+ User.get_user (Post.mastodon_actor message_object)
+ in
+ match actor with
+ | Error e ->
+ Dream.log "User not found %s" (Printexc.to_string e);
+ let code = Some 400 in
+ Dream.json ?code "User not found"
+ | Ok actor ->
+ Dream.log "User found";
+ message_object
+ |> Post.post_of_mastodon_post (User.name actor)
+ |> Post.add;
+ message_object |> Post.yojson_of_mastodon_post
+ |> Yojson.Safe.to_string |> Dream.log "Added post %s";
+ Dream.json "{}");
]
diff --git a/http/inbox.hurl b/http/inbox.hurl
index adb2d0e..be3da70 100644
--- a/http/inbox.hurl
+++ b/http/inbox.hurl
@@ -38,16 +38,16 @@ POST http://localhost:8080/inbox
"atomUri": "https://fosstodon.org/users/marcc/statuses/111506250224920551",
"inReplyToAtomUri": null,
"conversation": "tag:fosstodon.org,2023-12-01:objectId=165401029:objectType=Conversation",
- "content": "<p><span class=\"h-card\" translate=\"no\"><a href=\"https://galaxy.mccd.space/actor\" class=\"u-url mention\">@<span>blackhole</span></a></span> </p><p><a href=\"https://google.com\" target=\"_blank\" rel=\"nofollow noopener noreferrer\" translate=\"no\"><span class=\"invisible\">https://</span><span class=\"\">google.com</span><span class=\"invisible\"></span></a></p><p>This is a place on the web where you can search for things</p><p><a href=\"https://fosstodon.org/tags/goodie\" class=\"mention hashtag\" rel=\"tag\">#<span>goodie</span></a> <a href=\"https://fosstodon.org/tags/othergoodie\" class=\"mention hashtag\" rel=\"tag\">#<span>othergoodie</span></a></p>",
+ "content": "<p><span class=\"h-card\" translate=\"no\"><a href=\"https://galaxy.mccd.space/actor\" class=\"u-url mention\">@<span>wormhole</span></a></span> </p><p><a href=\"https://google.com\" target=\"_blank\" rel=\"nofollow noopener noreferrer\" translate=\"no\"><span class=\"invisible\">https://</span><span class=\"\">google.com</span><span class=\"invisible\"></span></a></p><p>This is a place on the web where you can search for things</p><p><a href=\"https://fosstodon.org/tags/goodie\" class=\"mention hashtag\" rel=\"tag\">#<span>goodie</span></a> <a href=\"https://fosstodon.org/tags/othergoodie\" class=\"mention hashtag\" rel=\"tag\">#<span>othergoodie</span></a></p>",
"contentMap": {
- "en": "<p><span class=\"h-card\" translate=\"no\"><a href=\"https://galaxy.mccd.space/actor\" class=\"u-url mention\">@<span>blackhole</span></a></span> </p><p><a href=\"https://google.com\" target=\"_blank\" rel=\"nofollow noopener noreferrer\" translate=\"no\"><span class=\"invisible\">https://</span><span class=\"\">google.com</span><span class=\"invisible\"></span></a></p><p>This is a place on the web where you can search for things</p><p><a href=\"https://fosstodon.org/tags/goodie\" class=\"mention hashtag\" rel=\"tag\">#<span>goodie</span></a> <a href=\"https://fosstodon.org/tags/othergoodie\" class=\"mention hashtag\" rel=\"tag\">#<span>othergoodie</span></a></p>"
+ "en": "<p><span class=\"h-card\" translate=\"no\"><a href=\"https://galaxy.mccd.space/actor\" class=\"u-url mention\">@<span>wormhole</span></a></span> </p><p><a href=\"https://google.com\" target=\"_blank\" rel=\"nofollow noopener noreferrer\" translate=\"no\"><span class=\"invisible\">https://</span><span class=\"\">google.com</span><span class=\"invisible\"></span></a></p><p>This is a place on the web where you can search for things</p><p><a href=\"https://fosstodon.org/tags/goodie\" class=\"mention hashtag\" rel=\"tag\">#<span>goodie</span></a> <a href=\"https://fosstodon.org/tags/othergoodie\" class=\"mention hashtag\" rel=\"tag\">#<span>othergoodie</span></a></p>"
},
"attachment": [],
"tag": [
{
"type": "Mention",
"href": "https://galaxy.mccd.space/actor",
- "name": "@blackhole@galaxy.mccd.space"
+ "name": "@wormhole@galaxy.mccd.space"
},
{
"type": "Hashtag",
diff --git a/lib/dune b/lib/dune
index 2bcd146..441cc53 100644
--- a/lib/dune
+++ b/lib/dune
@@ -1,5 +1,4 @@
(library
(name wormhole)
- (libraries uri)
- (modules Post)
+ (libraries uri cohttp cohttp-lwt-unix)
(preprocess (pps lwt_ppx ppx_yojson_conv)))
diff --git a/lib/post.ml b/lib/post.ml
index 232d9a7..3b63a11 100644
--- a/lib/post.ml
+++ b/lib/post.ml
@@ -25,10 +25,25 @@ type mastodon_post = {
}
[@@deriving yojson] [@@yojson.allow_extra_fields]
-let post_of_mastodon_post = function
+let mastodon_actor post = post.actor
+
+let post_of_mastodon_post actor_name = function
| { actor; published; obj = { tag } } ->
- let tags = List.map (fun { name; _ } -> name) tag in
- { link = actor; summary = published; tags; published; author = actor }
+ let tags =
+ List.filter_map
+ (fun { name; kind; _ } ->
+ (* This would normally be filtered with yojson, but I couldn't get
+ it to work *)
+ if kind = "Hashtag" then Some name else None)
+ tag
+ in
+ {
+ link = actor;
+ summary = published;
+ tags;
+ published;
+ author = actor_name;
+ }
let get_tld (link : string) =
Uri.of_string link |> Uri.host_with_default ~default:""
diff --git a/lib/post.mli b/lib/post.mli
deleted file mode 100644
index 9bf32ae..0000000
--- a/lib/post.mli
+++ /dev/null
@@ -1,31 +0,0 @@
-type t = {
- link : string;
- summary : string;
- tags : string list;
- published : string;
- author : string;
-}
-
-type mastodon_tag = { kind : string; name : string; href : string }
-
-val mastodon_tag_of_yojson : Yojson.Safe.t -> mastodon_tag
-val yojson_of_mastodon_tag : mastodon_tag -> Yojson.Safe.t
-
-type mastodon_object = { tag : mastodon_tag list }
-
-val mastodon_object_of_yojson : Yojson.Safe.t -> mastodon_object
-val yojson_of_mastodon_object : mastodon_object -> Yojson.Safe.t
-
-type mastodon_post = {
- actor : string;
- published : string;
- obj : mastodon_object;
-}
-
-val mastodon_post_of_yojson : Yojson.Safe.t -> mastodon_post
-val yojson_of_mastodon_post : mastodon_post -> Yojson.Safe.t
-val post_of_mastodon_post : mastodon_post -> t
-val get_tld : string -> string
-val db : t list ref
-val add : t -> unit
-val get_all : unit -> t list
diff --git a/lib/user.ml b/lib/user.ml
new file mode 100644
index 0000000..00cd33f
--- /dev/null
+++ b/lib/user.ml
@@ -0,0 +1,29 @@
+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_prem : 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 =
+ try%lwt
+ 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
+ Ok body
+ with exn -> Lwt.return (Error exn)
+
+let name user = user.name
diff --git a/readme.md b/readme.md
index 0a29cde..fd9087c 100644
--- a/readme.md
+++ b/readme.md
@@ -17,13 +17,13 @@ You'll need `libev` and `openssl`.
## Running
```
-dune exec --watch --root . ./server.exe
+dune exec --watch --root . wormhole
```
## Build
```
-opam build
+opam install . --deps-only
opam exec -- dune build
```
diff --git a/wormhole.opam b/wormhole.opam
index 77342ae..f26a552 100644
--- a/wormhole.opam
+++ b/wormhole.opam
@@ -11,9 +11,10 @@ doc: "https://url/to/documentation"
bug-reports: "https://github.com/username/reponame/issues"
depends: [
"ocaml"
- "dream"
"dune" {>= "3.11"}
"ppx_yojson_conv"
+ "cohttp"
+ "cohttp-lwt-unix"
"odoc" {with-doc}
]
build: [