Skip to content
Permalink
Browse files

JSON Feed + Webmention progress

  • Loading branch information...
tsileo committed Apr 29, 2019
1 parent 09e6d37 commit 4fdc753ff8ffd4c35a3601acc1c836d6c5e67dea
Showing with 206 additions and 79 deletions.
  1. +1 −1 .drone.yml
  2. +3 −0 atom.xml
  3. +52 −23 bin/app.ml
  4. +3 −1 lib/dune
  5. +17 −9 lib/entry.ml
  6. +15 −24 lib/microformats.ml
  7. +7 −11 lib/micropub.ml
  8. +17 −6 lib/utils.ml
  9. +89 −2 lib/webmention.ml
  10. +2 −2 lib/websub.ml
@@ -9,7 +9,7 @@ steps:
- sudo chown -R opam .
- git -C /home/opam/opam-repository pull origin && opam update
- opam pin add ssl 0.5.5
- opam install -y dolog alcotest yurt lwt irmin-unix odate omd mustache yaml lwt_ssl lambdasoup dune
- opam install -y stdint dolog alcotest yurt lwt irmin-unix odate omd mustache yaml lwt_ssl lambdasoup dune
- eval $(opam config env)
- export CONDUIT_TLS=openssl
# Build the entriespub binary
@@ -16,6 +16,9 @@
</author>
<id>{{url}}</id>
<summary type="html"><![CDATA[{{{content}}}]]></summary>
{{#category }}
<category term="{{ . }}" />
{{/category}}
</entry>
{{/entries}}
</feed>
@@ -62,14 +62,48 @@ let open Server in
server "127.0.0.1" 7888

>| post "/atom.xml" (fun req params body ->
Log.info "%s" (new_id ());
log_req req; string "")

(* TODO JSON feed *)
(* JSON feed *)
>| get "/feed.json" (fun req params body ->
log_req req;
Entry.iter (fun item ->
let uid = jform_field item ["properties"; "uid"] "" in
let published = jform_field item ["properties"; "published"] "" in
let content = jform_field item ["properties"; "content"] "" in
let title = jform_field item ["properties"; "name"] "" in
let slug = title |> slugify in
let tags = jform_strings item ["properties"; "category"] in
`O [
"id", `String (build_url uid slug);
"url", `String (build_url uid slug);
"date_published", `String published;
"content_html", `String (Omd.of_string content |> Omd.to_html);
"title", `String title;
"tags", Ezjsonm.(strings tags);

]
) >>= fun items ->
let headers = Header.init ()
|> set_content_type "application/json"
|> add_header "Link" ("<" ^ base_url ^ "/feed.json>; rel=\"self\"")
|> add_header "Link" ("<" ^ websub_endpoint ^ ">; rel=\"hub\"") in
json (`O [
(* TODO author avatar *)
"author", `O ["name", `String author_name; "url", `String (base_url ^ "/")];
"version", `String "https://jsonfeed.org/version/1";
"title", `String blog_name;
"home_page_url", `String (base_url ^ "/");
"feed_url", `String (base_url ^ "/feed.json");
"items", `A items;
"hubs", `A [`String websub_endpoint];
]) ~headers)

(* Atom feed *)
>| get "/atom.xml" (fun req params body ->
log_req req;
Entry.iter () >>= fun entries ->
Entry.iter entry_tpl_data >>= fun entries ->
(* Compute the "updated" field *)
let updated = if List.length entries > 0 then
let last_one = List.hd entries in
@@ -85,23 +119,23 @@ server "127.0.0.1" 7888
let out = Mustache.render atom_tpl dat in
let headers = Header.init ()
|> set_content_type "application/xml"
|> fun h -> Header.add h "Link" ("<" ^ base_url ^ "/atom.xml>; rel=\"self\"")
|> fun h -> Header.add h "Link" ("<" ^ websub_endpoint ^ ">; rel=\"hub\"") in
|> add_header "Link" ("<" ^ base_url ^ "/atom.xml>; rel=\"self\"")
|> add_header "Link" ("<" ^ websub_endpoint ^ ">; rel=\"hub\"") in
string out ~headers)

(* HEAD index *)
>| head "/" (fun req params body ->
log_req req;
let headers = Header.init ()
|> add_links base_url in
|> add_micropub_header base_url in
string "" ~headers)

(* Index *)
>| get "/" (fun req params body ->
log_req req;
Entry.iter () >>= fun dat ->
Entry.iter entry_tpl_data >>= fun dat ->
let dat = `O [
"entries", `A (List.sort compare_entry_data dat);
"entries", `A dat;
"base_url", `String base_url;
"is_index", `Bool true;
"is_entry", `Bool false;
@@ -110,20 +144,12 @@ server "127.0.0.1" 7888
let out = Mustache.render html_tpl dat in
let headers = Header.init ()
|> set_content_type text_html
|> add_links base_url in
|> add_micropub_header base_url in
string out ~headers)

(* Micropub endpoint *)
>| post "/webmention" (fun req params body ->
(*
test_mf2 >>= fun out ->
json out)
Webmention.discover_webmention "http://google.com" >>= fun res ->
let v = Yurt_util.unwrap_option_default res "" in
string v)
*)
Entriespub.Websub.ping (base_url ^ "/atom.xml") >>= fun res ->
if res then string "yes" else string "no")
Webmention.process_webmention body)

(* Handle Micropub queries *)
>| get "/micropub" (fun req params body ->
@@ -149,9 +175,11 @@ server "127.0.0.1" 7888
let uid = Route.string params "uid" in
Entry.get uid >>= fun some_stored ->
match some_stored with
| Some stored ->
| Some _ ->
let headers = Header.init ()
|> add_links base_url in
|> set_content_type text_html
|> add_micropub_header base_url
|> add_webmention_header base_url in
string "" ~headers
| None ->
(* 404 *)
@@ -160,13 +188,13 @@ server "127.0.0.1" 7888
(* Post/entry page *)
>| get "/<uid:string>/<slug:string>" (fun req params body ->
log_req req;
let slug = Route.string params "slug" in
(* TODO check slug let slug = Route.string params "slug" in *)
let uid = Route.string params "uid" in
Entry.get uid >>= fun some_stored ->
match some_stored with
| Some stored ->
(* Render the entry *)
let nstored = stored |> Ezjsonm.from_string |> entry_tpl_data in
let nstored = stored |> entry_tpl_data in
let dat = `O [
"is_index", `Bool false;
"is_entry", `Bool true;
@@ -177,7 +205,8 @@ server "127.0.0.1" 7888
let out = Mustache.render html_tpl dat in
let headers = Header.init ()
|> set_content_type text_html
|> add_links base_url in
|> add_micropub_header base_url
|> add_webmention_header base_url in
(string out ~headers)
| None ->
(* Return a 404 *)
@@ -190,7 +219,7 @@ server "127.0.0.1" 7888
let out = Mustache.render html_tpl dat in
let headers = Header.init ()
|> set_content_type text_html
|> add_links base_url in
|> add_micropub_header base_url in
string out ~headers ~status:404)

(* Run it *)
@@ -1,4 +1,6 @@
(library
(name entriespub)
(flags (-w -3-6-27-32-33-35-50))
(libraries dolog yurt lwt.unix irmin-unix odate omd mustache yaml lwt_ssl lambdasoup))
(preprocess (pps lwt.ppx))
(libraries lwt.ppx stdint dolog yurt lwt.unix irmin-unix odate omd mustache yaml lwt_ssl lambdasoup))

@@ -26,6 +26,7 @@ let entry_tpl_data jdata =
let content = jform_field jdata ["properties"; "content"] "" in
let published = jform_field jdata ["properties"; "published"] "" in
let uid = jform_field jdata ["properties"; "uid"] "" in
let tags = jform_strings jdata ["properties"; "category"] in
let slug = slugify name in
`O [
"name", `String name;
@@ -37,35 +38,43 @@ let entry_tpl_data jdata =
"author_email", `String author_email;
"url", `String (base_url ^ "/" ^ uid ^ "/" ^ slug);
"uid", `String uid;
"category", Ezjsonm.(strings tags);
]

let path_to_slug str =
if str = "" then "" else
String.sub str 1 ((String.length str) - 1)

let iter () =
let iter map =
Store.Repo.v config >>=
Store.master >>= fun t ->
Store.list t ["entries"] >>= fun keys ->
(Lwt_list.map_s (fun (s, c) ->
Store.get t ["entries"; s] >>= fun stored ->
stored |> Ezjsonm.from_string |> entry_tpl_data |> Lwt.return
stored |> Ezjsonm.from_string |> map |> Lwt.return
) keys)

let get uid =
Store.Repo.v config >>=
Store.master >>= fun t ->
Store.find t ["entries"; uid]
Store.find t ["entries"; uid] >>= fun entry ->
match entry with
| Some e ->
(* Render the entry *)
let v = e |> Ezjsonm.from_string in
Some v |> Lwt.return
| None ->
Lwt.return None

let remove uid =
Store.Repo.v config >>=
Store.master >>= fun t ->
Store.remove t ~info:(info "Deleting entry") ["entries"; uid]
Store.remove t ~info:(info "Deleting entry %s" uid) ["entries"; uid]

let set uid js =
let set uid entry =
Store.Repo.v config >>=
Store.master >>= fun t ->
Store.set t ~info:(info "Updating entry") ["entries"; uid] js
Store.set t ~info:(info "Updating entry %s" uid) ["entries"; uid] Ezjsonm.(to_string entry)

(* Save a new entry *)
let save uid slug entry_type entry_content entry_name entry_published entry_category =
@@ -82,7 +91,6 @@ let save uid slug entry_type entry_content entry_name entry_published entry_cate
]
] in
(* JSON serialize *)
let js = Ezjsonm.to_string obj in
Log.info "%s" js;
Log.info "%s" Ezjsonm.(to_string obj);
(* Save to repo *)
set uid js
set uid obj
@@ -1,25 +1,21 @@
open Lwt.Infix
open Yurt
include Cohttp
include Cohttp.Link
open Cohttp
include Soup

open Utils


(* Basic microformats2 parser for Webmention, returns JSON mf2 *)
let parse url soup target =
let title = try
soup $ "title" |> (fun node ->
node |> R.leaf_text |> String.trim
)
with _ -> "" in
let hcard_soup = try
soup $ ".h-card"
with _ ->
failwith "ok"
(*
let u = Uri.of_string url in
`O [
"url", `String url;
"type", `String "related";
]
*)
(* TODO support no hcard *)
failwith "no hcard"
in
let photo = try
hcard_soup $ ".u-photo" |> (fun node ->
@@ -33,40 +29,40 @@ let parse url soup target =
in
let url = try
hcard_soup $ ".u-url" |> (fun node ->
node |> R.attribute "href"
node |> R.attribute "href" |> String.trim
)
with _ ->
let u = Uri.of_string url in
Uri.with_path u "/" |> Uri.to_string
in
let name = try
hcard_soup $ ".p-name" |> (fun node ->
node |> R.leaf_text
node |> R.leaf_text |> String.trim
)
with _ -> Uri.of_string url |> Uri.host |> fun x -> Yurt_util.unwrap_option_default x ""
in
let like_of = try
hcard_soup $ "a.u-like-of" |> (fun node ->
node |> R.attribute "href"
node |> R.attribute "href" |> String.trim
)
with _ -> ""
in
let repost_of = try
hcard_soup $ "a.u-repost-of" |> (fun node ->
node |> R.attribute "href"
node |> R.attribute "href" |> String.trim
)
with _ -> ""
in
let in_reply_to = try
hcard_soup $ "a.u-in-reply-to" |> (fun node ->
node |> R.attribute "href"
node |> R.attribute "href" |> String.trim
)
with _ -> ""
in
let mtype = if like_of = target then
"like"
else if repost_of = target then
"report"
"repost"
else if in_reply_to = target then
"reply"
else
@@ -78,10 +74,5 @@ let parse url soup target =
"author_name", `String name;
"url", `String url;
"type", `String mtype;
"title", `String title;
]


let test_mf2 =
Client.get "https://google.com" >>= fun (resp, body) ->
let soup = body |> Soup.parse in
(parse "https://google.com" soup "http://google.com") |> Lwt.return

0 comments on commit 4fdc753

Please sign in to comment.
You can’t perform that action at this time.