software-archive/logarion-2016
2
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

implemented partial text queries and fixed routing bugs

Browse Source
This commit is contained in:
Stavros Polymenis 2016-10-03 22:00:29 +01:00
parent 2f86b81d4f
commit f243f48a21
3 changed files with 23 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/html.ml
View File

@ -19,14 +19,14 @@ let of_ymd ymd =
])
|> Format.asprintf "%a" (Tyxml.Html.pp ())
let of_titled_files titles =
let link_item (y,t) = li [a ~a:[a_href ("/" ^ Filename.chop_extension y)] [Unsafe.data t]] in
let of_file_meta_pairs file_metas =
let link_item (y,m) = li [a ~a:[a_href ("/" ^ Filename.chop_extension y)] [Unsafe.data Ymd.(m.title)]] in
html (logarion_head "Homepage")
(body [
header [ h1 [pcdata "Homepage"] ];
div [
h2 [pcdata "Articles"];
ul (List.map link_item titles);
ul (List.map link_item file_metas);
];
])
|> Format.asprintf "%a" (Tyxml.Html.pp ())

15
src/logarion.ml
View File

@ -25,9 +25,20 @@ let to_file ymd =
Lwt_io.write out (to_string ymd)
)
let titled_files () =
let file_meta_pairs () =
let files = Array.to_list @@ Sys.readdir "ymd/" in
let ymd_list a e = if BatString.ends_with e ".ymd" then List.cons e a else a in
let ymds = List.fold_left ymd_list [] files in
let t y = (y, (of_file ("ymd/" ^ y)).meta.title) in
let t y = (y, (of_file ("ymd/" ^ y)).meta) in
List.map t ymds
let latest_file_meta_pair fragment =
let latest p (path', meta') =
if not @@ BatString.exists (meta'.title) fragment then None
else
match p with
| Some (path, meta) ->
if meta.date.published < meta'.date.published
then Some (path', meta') else p
| None -> Some (path', meta') in
ListLabels.fold_left ~f:latest ~init:(None) (file_meta_pairs ())

12
src/web.ml
View File

@ -14,6 +14,8 @@ let ymd_of_req req =
let string_response s = `String s |> respond'
let html_response h = `Html h |> respond'
let ymd_or_error y = match y with Some (path, meta) -> Logarion.of_file ("ymd/" ^ path) | None -> Ymd.blank_ymd
let () =
let (>>=) = Lwt.(>>=)
and (>|=) = Lwt.(>|=) in
@ -22,10 +24,10 @@ let () =
let ret_param name req = return (param req name) in
App.empty
|> post "/text/post" (fun req -> ymd_of_req req >>= fun ymd -> L.to_file ymd >>= fun () -> html_response (Html.of_ymd ymd))
|> get "/text/:ttl/edit" (fun req -> ret_param "ttl") >>= ymdpath >|= ymd >|= Html.form >>= html_response)
|> get "/text/:ttl/edit" (fun r -> ret_param "ttl" r >>= ymdpath >|= ymd >|= Html.form >>= html_response)
|> get "/text/new" (fun _ -> return Ymd.blank_ymd >|= Html.form >>= html_response)
|> get "/text/:ttl" (fun req -> ret_param "ttl" >>= ymdpath >|= ymd >|= Html.of_ymd >>= html_response)
|> get "/!/:ttl" (fun req -> ret_param "ttl" >>= ymdpath >|= ymd >|= Html.of_ymd >>= html_response)
|> get "/style.css" (fun _ -> return ("ymd/style.css") >|= L.load_file >>= string_response)
|> get "/" (fun req -> return (L.titled_files ()) >|= Html.of_titled_files >>= html_response)
|> get "/text/:ttl" (fun req -> ret_param "ttl" req >>= ymdpath >|= ymd >|= Html.of_ymd >>= html_response)
|> get "/!/:ttl" (fun req -> ret_param "ttl" req >|= L.latest_file_meta_pair >|= ymd_or_error >|= Html.of_ymd >>= html_response)
|> get "/style.css" (fun _ -> return "ymd/style.css" >|= L.load_file >>= string_response)
|> get "/" (fun _ -> return (L.file_meta_pairs ()) >|= Html.of_file_meta_pairs >>= html_response)
|> App.run_command