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

refactored web application but a more pervasive redesign is needed

Browse Source
This commit is contained in:
Stavros Polymenis 2017-01-15 21:25:41 +00:00
parent d654204807
commit 51d14df75f
2 changed files with 57 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
src/logarion.ml
View File

@ -133,7 +133,7 @@ module Archive = struct
let open Lwt.Infix in
to_filename repo ymd >>= fun () ->
let open Ymd in
if not (categorised [Category.Draft] ymd) && ymd.meta.Meta.title <> "" then
(if not (categorised [Category.Draft] ymd) && ymd.meta.Meta.title <> "" then
let entries = of_repo repo in
let titledir = titledir repo in
begin try
@ -141,13 +141,16 @@ module Archive = struct
let entry = List.find (fun entry -> uuid entry.attributes = uuid ymd.meta) entries in
if slug entry <> filename ymd then
let found_filepath = articlefilename_string (article_path repo entry.filename) in
Lwt_unix.rename found_filepath (next_semantic_filepath titledir ymd);
else Lwt.return ()
Lwt_unix.rename found_filepath (next_semantic_filepath titledir ymd)
else
Lwt.return_unit
with Not_found ->
Lwt_unix.link (articlefilename_string (uuid_path repo ymd)) (next_semantic_filepath titledir ymd);
end
else
Lwt.return ()
Lwt.return_unit)
>>= fun () -> Lwt.return ymd
let topics archive =
let open List in

63
src/web.ml
View File

@ -64,43 +64,54 @@ let ymd_of_req req =
let string_response s = `String s |> respond'
let html_response h = `Html h |> respond'
let unpublished_entry = Logarion.(Entry.({ filename = Articlefilename ""; attributes = Ymd.Meta.blank () }))
module L = Logarion
let unpublished_entry =
L.(Entry.({ filename = Articlefilename ""; attributes = Ymd.Meta.blank () }))
let entry_option y = match y with Some entry -> entry | None -> unpublished_entry
let webcfg = Configuration.of_filename "web.toml"
let lgrn = Logarion.Configuration.of_filename "logarion.toml"
let ymd repo f =
try L.Entry.of_filename repo f |> (fun entry -> if L.Entry.listed entry then entry else unpublished_entry)
with Sys_error _ -> unpublished_entry
let () =
Random.self_init();
let (>>=) = Lwt.(>>=)
and (>|=) = Lwt.(>|=) in
let module L = Logarion in
let ymd f = try
L.Entry.of_filename lgrn.L.Configuration.repository f
|> (fun entry -> if L.Entry.listed entry
then entry else unpublished_entry)
with Sys_error _ -> unpublished_entry
in
let ymdpath title = Lwt.return @@ Logarion.title_path lgrn.L.Configuration.repository title in
let ret_param name req = Lwt.return (param req name) in
let wcfg = Configuration.of_filename "web.toml" in
let option_load tpl o = match o with Some f -> Some (tpl f) | None -> None in
let header_tpl = option_load Template.header Configuration.(webcfg.template.header) in
let listing_tpl = option_load Template.listing Configuration.(webcfg.template.listing) in
let entry_tpl = option_load Template.listing_entry Configuration.(webcfg.template.listing_entry) in
let text_tpl = option_load Template.text Configuration.(webcfg.template.text) in
let blog_url = Configuration.(webcfg.url) in
let header_tpl = option_load Template.header Configuration.(wcfg.template.header) in
let listing_tpl = option_load Template.listing Configuration.(wcfg.template.listing) in
let entry_tpl = option_load Template.listing_entry Configuration.(wcfg.template.listing_entry) in
let text_tpl = option_load Template.text Configuration.(wcfg.template.text) in
let blog_url = Configuration.(wcfg.url) in
let lgrn = Logarion.Configuration.of_filename "logarion.toml" in
let page_of_ymd = Html.of_ymd ~header_tpl ~text_tpl blog_url lgrn in
let form_of_ymd = Html.form ~header_tpl blog_url lgrn in
let list_of_ymds = Html.of_entries ~header_tpl ~listing_tpl ~entry_tpl blog_url lgrn in
let lwt_param name req = Lwt.return (param req name) in
let lwt_archive repo = Lwt.return L.Archive.(of_repo repo) in
let lwt_blankymd () = Lwt.return (Ymd.blank ()) in
let (>>=) = Lwt.(>>=) and (>|=) = Lwt.(>|=) in
let page_of_slug repo s = entry_option s |> L.Entry.to_ymd repo |> Lwt.return in
let view_page repo slug = page_of_slug repo slug >|= page_of_ymd in
let edit_page repo slug = page_of_slug repo slug >|= form_of_ymd in
let post_page repo ymd = L.Archive.add repo ymd >|= page_of_ymd in
let atom_page repo entries = L.Archive.latest_listed entries |> Lwt.return >|= List.map (L.Entry.to_ymd repo) in
let repo = lgrn.L.Configuration.repository in
App.empty
|> App.port webcfg.Configuration.port
|> App.port wcfg.Configuration.port
|> middleware @@ Middleware.static ~local_path:"./share/static" ~uri_prefix:"/static"
|> post "/post" (fun req -> ymd_of_req req >>= fun ymd -> L.Archive.add repo ymd >>= fun () -> html_response (page_of_ymd ymd))
|> get "/edit/:ttl" (fun r -> ret_param "ttl" r >>= ymdpath >|= ymd >|= L.Entry.to_ymd repo >|= form_of_ymd >>= html_response)
|> get "/new" (fun _ -> Lwt.return (Ymd.blank ()) >|= form_of_ymd >>= html_response)
|> get "/text/:ttl" (fun req -> ret_param "ttl" req >|= L.entry_with_slug repo >|= entry_option >|= L.Entry.to_ymd repo >|= page_of_ymd >>= html_response)
|> get "/!/:ttl" (fun req -> ret_param "ttl" req >|= L.latest_entry repo >|= entry_option >|= L.Entry.to_ymd repo >|= page_of_ymd >>= html_response)
|> get "/feed.atom" (fun _ -> Lwt.return L.Archive.(of_repo repo) >|= L.Archive.latest_listed >|= List.map (L.Entry.to_ymd repo) >|= Atom.feed webcfg.Configuration.url lgrn >>= html_response)
|> post "/post" (fun r -> ymd_of_req r >>= post_page repo >>= html_response)
|> get "/edit/:ttl" (fun r -> lwt_param "ttl" r >|= L.entry_with_slug repo >>= edit_page repo >>= html_response)
|> get "/new" (fun _ -> lwt_blankymd () >|= form_of_ymd >>= html_response)
|> get "/text/:ttl" (fun r -> lwt_param "ttl" r >|= L.entry_with_slug repo >>= view_page repo >>= html_response)
|> get "/!/:ttl" (fun r -> lwt_param "ttl" r >|= L.latest_entry repo >>= view_page repo >>= html_response)
|> get "/feed.atom" (fun _ -> lwt_archive repo >>= atom_page repo >|= Atom.feed wcfg.Configuration.url lgrn >>= html_response)
|> get "/" (fun _ -> Lwt.return list_of_ymds >>= html_response)
|> App.run_command