include Bindings
include Babillard
open Db
let view_post ?is_thread_preview post_id =
let^ nick = Db.find Q.get_post_nick post_id in
let^ comment = Db.find Q.get_post_comment post_id in
let^ date = Db.find Q.get_post_date post_id in
let^ image_info = Db.find_opt Q.get_post_image_info post_id in
let^ tags = Db.fold Q.get_post_tags (fun tag acc -> tag :: acc) post_id [] in
let^ replies =
Db.fold Q.get_post_replies (fun reply_id acc -> reply_id :: acc) post_id []
in
let image_view =
match image_info with
| Some (_image_name, image_alt) ->
(*TODO thumbnails *)
(*TODO image info like file name and size on top of image*)
Format.sprintf
{|
|}
post_id post_id image_alt image_alt
| None -> ""
in
let pp_print_reply fmt reply =
Format.fprintf fmt {|>>%s|} reply
reply
in
let pp_print_replies replies =
Format.asprintf {|%a
|}
(Format.pp_print_list ~pp_sep:Format.pp_print_space pp_print_reply)
replies
in
let replies_view =
match is_thread_preview with
| None -> pp_print_replies replies
| Some () -> (
let res_nb = Db.find Q.count_thread_posts post_id in
match res_nb with
| Error _ -> ""
| Ok ((1 | 2) as nb) ->
Format.sprintf {|%d reply
|} (nb - 1)
| Ok nb ->
Format.sprintf {|%d replies
|} (nb - 1) )
in
let post_links_view =
match is_thread_preview with
| None ->
Format.sprintf
{|
#
%s
%s
|}
post_id post_id post_id replies_view
| Some () -> Format.sprintf {|
%s
|} replies_view
in
let post_info_view =
Format.sprintf
{|
%s
%s
|}
nick date post_links_view
in
let pp_print_tag fmt tag =
Format.fprintf fmt {|%s|} tag
in
let pp_print_tags tags =
Format.asprintf {|%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 = pp_print_tags tags in
let post_view =
Format.sprintf
{|
|}
post_id post_info_view image_view comment tags_view
in
Ok post_view
let preview_thread thread_id =
let* post = view_post ~is_thread_preview:() thread_id in
let^? subject = Db.find_opt Q.get_post_subject thread_id in
let thread_preview =
Format.sprintf
{|
|}
subject post
in
Ok thread_preview
let view_thread thread_id =
let^ is_thread = Db.find Q.is_thread thread_id in
if not is_thread then
Error "This thread doesn't exists"
else
let^? subject = Db.find_opt Q.get_post_subject thread_id in
let^ thread_posts = Db.fold Q.get_thread_posts List.cons thread_id [] in
(*order by date *)
let dates =
List.map (fun post_id -> Db.find Q.get_post_date post_id) thread_posts
in
match List.find_opt Result.is_error dates with
| Some (Error e) ->
Error (Format.sprintf "db error: %s" (Caqti_error.show e))
| Some (Ok _) -> assert false
| None -> (
let dates = List.map Result.get_ok dates in
let posts_dates = List.combine thread_posts dates in
let sorted_posts_dates =
List.sort (fun (_, a) (_, b) -> compare a b) posts_dates
in
let posts, _ = List.split sorted_posts_dates in
let view_posts = List.map view_post posts in
match List.find_opt Result.is_error view_posts with
| Some (Error e) -> Error e
| Some (Ok _) -> assert false
| None ->
let posts =
List.map Result.get_ok (List.filter Result.is_ok view_posts)
in
let posts =
Format.asprintf "%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\r\n")
Format.pp_print_string )
posts
in
let thread_view =
Format.sprintf
{|
|}
subject posts
in
Ok thread_view )
let get_markers () =
let^ thread_id_list = Db.fold Q.get_threads List.cons () [] in
let markers_res =
List.map
(fun thread_id ->
let^? lat, lng = Db.find_opt Q.get_post_gps thread_id in
match preview_thread thread_id with
| Ok content -> Ok (lat, lng, content, thread_id)
| Error e -> Error e )
thread_id_list
in
let markers = List.map Result.get_ok (List.filter Result.is_ok markers_res) in
let pp_marker fmt (lat, lng, content, thread_id) =
Format.fprintf fmt
{|{
"type": "Feature",
"geometry": {
"type": "Point",
"coordinates": [%s,%s]
},
"properties": {
"content": "%s",
"thread_id": "%s"
}}|}
(* geojson use lng lat, and not lat lng*)
(Float.to_string lng)
(Float.to_string lat) (String.escaped content) thread_id
in
let markers =
Format.asprintf "[%a]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",")
pp_marker )
markers
in
Ok markers