include Bindings
include Babillard
open Db
let view_post ?is_thread_preview id =
let* { id
; parent_id = _parent_id
; date
; nick
; comment
; image_info
; tags
; replies
; citations = _citations
} =
get_post id
in
let image_view fmt () =
match image_info with
| Some (_image_name, image_alt) ->
(*TODO thumbnails *)
(*TODO image info like file name and size on top of image*)
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 () =
match is_thread_preview with
| None -> pp_print_replies fmt replies
| Some () -> (
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) )
in
let post_links_view fmt () =
match is_thread_preview with
| None ->
Format.fprintf fmt
{|
#
%a
|}
id id id replies_view ()
| Some () -> Format.fprintf fmt {|
%a
|} replies_view ()
in
let post_info_view fmt () =
Format.fprintf fmt
{|
%s
%a
|}
nick date 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 post_view =
Format.asprintf
{|
%a
%a
%s
%a
|}
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
{|
%s
%s
|}
subject post
in
Ok thread_preview
let view_thread thread_id =
let^ _is_thread = Db.find Q.get_is_thread thread_id in
let^? subject = Db.find_opt Q.get_post_subject thread_id in
let^ thread_posts = Db.collect_list Q.get_thread_posts thread_id in
(*order by date *)
let dates = List.map (Db.find Q.get_post_date) 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
{|
%s
%s
|}
subject posts
in
Ok thread_view )
let get_markers () =
let^ thread_id_list = Db.collect_list Q.get_threads () 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) =
(* geojson use lng lat, and not lat lng*)
let json =
`Assoc
[ ("type", `String "Feature")
; ( "geometry"
, `Assoc
[ ("type", `String "Point")
; ("coordinates", `List [ `Float lng; `Float lat ])
] )
; ( "properties"
, `Assoc
[ ("content", `String content); ("thread_id", `String thread_id) ]
)
]
in
Yojson.pretty_print fmt json
in
let markers =
Format.asprintf "[%a]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",")
pp_marker )
markers
in
Ok markers