include Bindings
include Babillard
open Db
let pp_post fmt t =
let thread_data_opt, post =
match t with
| Op (data, post) -> (Some data, post)
| Post post -> (None, post)
in
let { id
; parent_id = _parent_id
; date
; nick
; comment
; image_info
; tags
; replies
; citations = _citations
} =
post
in
let image_view fmt () =
match image_info with
| Some (_image_name, image_alt) ->
Format.fprintf fmt
{|
|}
id id image_alt image_alt
| None -> Format.fprintf fmt ""
in
let pp_print_reply fmt reply =
Format.fprintf fmt {|>>%s|} reply
reply
in
let pp_print_replies fmt replies =
Format.fprintf fmt {|
%a
|}
(Format.pp_print_list ~pp_sep:Format.pp_print_space pp_print_reply)
replies
in
let replies_view fmt () =
if Option.is_some thread_data_opt then
(* TODO put thread_posts count in thread_info ? *)
let res_nb = Db.find Q.count_thread_posts id in
match res_nb with
| Error _ -> Format.fprintf fmt ""
| Ok ((1 | 2) as nb) ->
Format.fprintf fmt {|
%d reply
|} (nb - 1)
| Ok nb ->
Format.fprintf fmt {|
%d replies
|} (nb - 1)
else pp_print_replies fmt replies
in
let post_links_view fmt () =
if Option.is_some thread_data_opt then
Format.fprintf fmt {|
%a
|} replies_view ()
else
Format.fprintf fmt
{|
%a
|}
id id replies_view ()
in
let post_info_view fmt () =
Format.fprintf fmt
{|
|}
nick date id id id post_links_view ()
in
let pp_print_tag fmt tag =
Format.fprintf fmt {|%s|} tag
in
let pp_print_tags fmt tags =
Format.fprintf fmt {|
%a
|}
(Format.pp_print_list ~pp_sep:Format.pp_print_space pp_print_tag)
tags
in
let tags = List.sort String.compare tags in
let tags_view fmt () = pp_print_tags fmt tags in
let subject =
Option.fold ~none:""
~some:(fun thread_data -> thread_data.subject)
thread_data_opt
in
(* put a link in if its a preview *)
let link fmt () =
if Option.is_some thread_data_opt then
Format.fprintf fmt
{||} id
in
Format.fprintf fmt
{|
%s
%a
%a
%a
%s
%a
|}
id subject link () post_info_view () image_view () comment tags_view ()
let view_post id =
let* post = get_post id in
Ok (Format.asprintf "%a" pp_post (Post post))
let pp_thread_preview fmt op =
let thread_data, post = op in
let thread_preview =
Format.fprintf fmt
{|
%a
|}
pp_post
(Op (thread_data, post))
in
thread_preview
let catalog_content () =
let^ ids = Db.collect_list Q.get_threads () in
let* ops = get_ops ids in
Ok
(Format.asprintf "%a"
(Format.pp_print_list ~pp_sep:Format.pp_print_space pp_thread_preview)
ops )
let pp_report fmt post report request =
let url = "/admin" in
let nick, reason, _date, id = report in
let input_post_id fmt id =
Format.fprintf fmt
{||} id
in
let button fmt value =
Format.fprintf fmt
{||}
value
(String.uppercase_ascii value)
in
let form fmt value =
Format.fprintf fmt {|%s %a %a |}
(Dream.form_tag ~action:url request)
input_post_id id button value
in
Format.fprintf fmt
{|
%a
From: %s Reason: %s
%a
%a
%a
|}
pp_post (Post post) nick reason form "ignore" form "delete" form "banish"
let admin_page_content posts reports request =
let posts_reports = List.combine posts reports in
Format.asprintf "%a"
(Format.pp_print_list ~pp_sep:Format.pp_print_space
(fun fmt (post, report) -> pp_report fmt post report request) )
posts_reports
let pp_thread fmt op posts =
let thread_data, _post = op in
(*order by date *)
let posts = List.sort (fun a b -> compare a.date b.date) posts in
let posts_view fmt () =
Format.pp_print_list ~pp_sep:Format.pp_print_space
(fun fmt post -> pp_post fmt (Post post))
fmt posts
in
Format.fprintf fmt
{|
%s
%a
|}
thread_data.subject posts_view ()
let view_thread thread_id =
let* op = get_op thread_id in
let^ ids = Db.collect_list Q.get_thread_posts thread_id in
let* posts = get_posts ids in
let s =
(Format.asprintf "%a" (fun fmt (op, posts) -> pp_thread fmt op posts))
(op, posts)
in
Ok s
let pp_marker fmt op =
let thread_data, post = op in
let content = Format.asprintf "%a" pp_thread_preview op in
(* geojson use lng lat, and not lat lng*)
let json =
`Assoc
[ ("type", `String "Feature")
; ( "geometry"
, `Assoc
[ ("type", `String "Point")
; ( "coordinates"
, `List [ `Float thread_data.lng; `Float thread_data.lat ] )
] )
; ( "properties"
, `Assoc
[ ("content", `String content); ("thread_id", `String post.id) ] )
]
in
Yojson.pretty_print fmt json
let get_markers () =
let^ ids = Db.collect_list Q.get_threads () in
let* ops = get_ops ids in
let markers =
Format.asprintf "[%a]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",")
pp_marker )
ops
in
Ok markers
(* TODO get from config file? *)
let server_url = "http://localhost:3696"
(* RFC-3339 date-time *)
let pp_date fmt date =
let date = Unix.gmtime date in
Format.fprintf fmt "%04d-%02d-%02dT%02d:%02d:%02dZ" (1900 + date.tm_year)
(1 + date.tm_mon) date.tm_mday date.tm_hour date.tm_min date.tm_sec
let pp_feed_entry fmt post =
Format.fprintf fmt
{|
Atom-Powered Robots Run Amokurn:uuid:%s%a%s%s
|}
post.id pp_date post.date post.nick
(Dream.html_escape post.comment)
server_url post.parent_id post.id
let feed thread_id =
let* thread_data, op_post = get_op thread_id in
let^ ids = Db.collect_list Q.get_thread_posts thread_id in
let* posts = get_posts ids in
let posts = List.sort (fun a b -> compare b.date a.date) posts in
let last_update = (List.nth posts 0).date in
let entries fmt () =
(Format.pp_print_list ~pp_sep:Format.pp_print_space pp_feed_entry) fmt posts
in
(*TODO different uuid for op and thread ..?*)
let feed =
Format.asprintf
{|
%s | Permap %a%surn:uuid:%s
%a
|}
thread_data.subject server_url thread_id pp_date last_update op_post.nick
op_post.id entries ()
in
Ok feed
