introduction of Archive and Entry submodules
This commit is contained in:
Stavros Polymenis
parent
94291e6ae5
commit
ebbe005719
@ -25,5 +25,5 @@ let entry url logarion ymd =
|
||||
let feed url logarion articles =
|
||||
"<?xml version=\"1.0\" encoding=\"utf-8\"?><feed xmlns=\"http://www.w3.org/2005/Atom\">"
|
||||
^ header logarion
|
||||
^ List.fold_left (fun body (f,ymd) -> body ^ entry url logarion ymd) "" articles
|
||||
^ List.fold_left (fun body ymd -> body ^ entry url logarion ymd) "" articles
|
||||
^ "</feed>"
|
||||
|
||||
@ -14,7 +14,7 @@ let create =
|
||||
let create_f title =
|
||||
let cfg = Logarion.Configuration.of_filename "logarion.toml" in
|
||||
let t = match title with "" -> "Draft" | _ -> title in
|
||||
Logarion.to_file cfg Ymd.({ (blank_ymd ()) with meta = { (blank_meta ()) with title = t }})
|
||||
Logarion.Entry.to_file cfg Ymd.({ (blank_ymd ()) with meta = { (blank_meta ()) with title = t }})
|
||||
|> Lwt_main.run
|
||||
in
|
||||
Term.(const create_f $ title),
|
||||
|
||||
13
src/html.ml
13
src/html.ml
@ -38,20 +38,21 @@ let of_ymd ?(header_tpl=None) ?(text_tpl=None) blog_url lgrn ymd =
|
||||
(logarion_text ~text_tpl ymd)
|
||||
|> to_string
|
||||
|
||||
let article_link (file, meta) =
|
||||
li [a ~a:[a_href (uri_of_string ("/text/" ^ Filename.chop_extension file))]
|
||||
[Unsafe.data (Ymd.(meta.title) ^ Ymd.Date.(pretty_date @@ last meta.Ymd.date)) ]
|
||||
let article_link entry =
|
||||
let module E = Logarion.Entry in
|
||||
li [a ~a:[a_href (uri_of_string ("/text/" ^ Filename.chop_extension (Filename.basename entry.E.filepath)))]
|
||||
[Unsafe.data (Ymd.(entry.meta.title) ^ Ymd.Date.(pretty_date @@ last entry.meta.date)) ]
|
||||
]
|
||||
|
||||
let of_file_meta_pairs ?(header_tpl=None) ?(listing_tpl=None) ?(entry_tpl=None) blog_url lgrn file_meta_pairs =
|
||||
let of_entries ?(header_tpl=None) ?(listing_tpl=None) ?(entry_tpl=None) blog_url lgrn (entries : Logarion.Entry.t list) =
|
||||
let t = Logarion.Configuration.(lgrn.title) in
|
||||
logarion_page
|
||||
~header_tpl
|
||||
blog_url
|
||||
t t
|
||||
(match listing_tpl with
|
||||
| Some (Template.Listing s) -> Unsafe.data Template.(fold_index ~entry_tpl file_meta_pairs s)
|
||||
| None -> (div [ h2 [pcdata "Articles"]; ul (List.map article_link file_meta_pairs); ]))
|
||||
| Some (Template.Listing s) -> Unsafe.data Template.(fold_index ~entry_tpl entries s)
|
||||
| None -> (div [ h2 [pcdata "Articles"]; ul (List.map article_link entries); ]))
|
||||
|> to_string
|
||||
|
||||
let form ?(header_tpl=None) blog_url lgrn ymd =
|
||||
|
||||
132
src/logarion.ml
132
src/logarion.ml
@ -35,83 +35,95 @@ module Configuration = struct
|
||||
}
|
||||
end
|
||||
|
||||
module File = struct
|
||||
let load f =
|
||||
let ic = open_in f in
|
||||
let n = in_channel_length ic in
|
||||
let s = Bytes.create n in
|
||||
really_input ic s 0 n;
|
||||
close_in ic;
|
||||
(s)
|
||||
end
|
||||
|
||||
let titledir ymddir = ymddir ^ "/title/"
|
||||
let uuiddir ymddir = ymddir ^ "/uuid/"
|
||||
let extension = ".ymd"
|
||||
let title_path repo title = titledir repo ^ Ymd.filename_of_title title ^ extension
|
||||
let uuid_path repo ymd = uuiddir repo ^ Ymd.(Id.to_string ymd.meta.uuid) ^ extension
|
||||
|
||||
let load_file f =
|
||||
let ic = open_in f in
|
||||
let n = in_channel_length ic in
|
||||
let s = Bytes.create n in
|
||||
really_input ic s 0 n;
|
||||
close_in ic;
|
||||
(s)
|
||||
module Entry = struct
|
||||
type t = { filepath : string; meta : Ymd.meta; body : string option }
|
||||
|
||||
let of_file s =
|
||||
let segments = Re_str.(split (regexp "^---$")) (load_file s) in
|
||||
let open Ymd in
|
||||
if List.length segments = 2 then
|
||||
let yaml_str = List.nth segments 0 in
|
||||
let md_str = List.nth segments 1 in
|
||||
let m = meta_of_yaml yaml_str in
|
||||
{ meta = m; body = md_str }
|
||||
else
|
||||
{ (blank_ymd ()) with body = "Error parsing file" }
|
||||
let of_file s =
|
||||
let segments = Re_str.(split (regexp "^---$")) (File.load s) in
|
||||
let open Ymd in
|
||||
if List.length segments = 2 then
|
||||
let yaml_str = List.nth segments 0 in
|
||||
let md_str = List.nth segments 1 in
|
||||
let m = meta_of_yaml yaml_str in
|
||||
{ filepath = s; meta = m; body = Some md_str }
|
||||
else
|
||||
{ filepath = s; meta = blank_meta (); body = Some "Error parsing file" }
|
||||
|
||||
let file_meta_pairs titles =
|
||||
let files = Array.to_list @@ Sys.readdir titles in
|
||||
let ymd_list a e = if BatString.ends_with e extension then List.cons e a else a in
|
||||
let ymds = List.fold_left ymd_list [] files in
|
||||
let t y = (y, (of_file (titles ^ y)).Ymd.meta) in
|
||||
List.map t ymds
|
||||
let to_file config ymd =
|
||||
let repo = Configuration.(config.repository) in
|
||||
let uuid_path = uuid_path repo ymd in
|
||||
let write_ymd out = Lwt_io.write out (Ymd.to_string ymd) in
|
||||
Lwt_io.with_file ~mode:Lwt_io.output uuid_path write_ymd
|
||||
|
||||
let file_ymd_pairs titles =
|
||||
let files = Array.to_list @@ Sys.readdir titles in
|
||||
let ymd_list a e = if BatString.ends_with e extension then List.cons e a else a in
|
||||
let ymds = List.fold_left ymd_list [] files in
|
||||
let t y = (y, (of_file (titles ^ y))) in
|
||||
List.map t ymds
|
||||
let to_ymd entry = { Ymd.meta = entry.meta; Ymd.body = match entry.body with Some b -> b | None -> "" }
|
||||
end
|
||||
|
||||
let slug_of_filename filename = List.hd @@ BatString.split_on_char '.' filename
|
||||
|
||||
let rec next_semantic_filepath ?(version=0) titles ymd =
|
||||
let candidate = titles ^ (Ymd.filename ymd) ^ "." ^ (string_of_int version) ^ extension in
|
||||
if Sys.file_exists candidate then next_semantic_filepath ~version:(version+1) titles ymd
|
||||
else candidate
|
||||
|
||||
let slug_of_filename filename = List.hd @@ BatString.split_on_char '.' filename
|
||||
module Archive = struct
|
||||
type t = Entry.t list
|
||||
|
||||
let to_file config ymd =
|
||||
let open Lwt.Infix in
|
||||
let repo = Configuration.(config.repository) in
|
||||
let uuid_path = uuid_path repo ymd in
|
||||
let write_ymd out = Lwt_io.write out (Ymd.to_string ymd) in
|
||||
Lwt_io.with_file ~mode:Lwt_io.output uuid_path write_ymd;
|
||||
>>= fun () ->
|
||||
let open Ymd in
|
||||
if not (categorised [Category.Draft] ymd) && ymd.meta.title <> "" then
|
||||
let fmp = file_meta_pairs repo in
|
||||
begin try
|
||||
let (file, m) = List.find (fun (_, meta) -> meta.uuid = ymd.meta.uuid) fmp in
|
||||
if slug_of_filename file <> (Ymd.filename ymd) then
|
||||
let found_filepath = titledir repo ^ file in
|
||||
Lwt_unix.rename found_filepath (next_semantic_filepath repo ymd);
|
||||
else Lwt.return ()
|
||||
with Not_found ->
|
||||
Lwt_unix.link uuid_path (next_semantic_filepath repo ymd);
|
||||
end
|
||||
else
|
||||
Lwt.return ()
|
||||
let of_repo ?(bodies=false) repo =
|
||||
let files = Array.to_list @@ Sys.readdir (titledir repo) in
|
||||
let ymd_list a e = if BatString.ends_with e extension then List.cons e a else a in
|
||||
let ymds = List.fold_left ymd_list [] files in
|
||||
let t y =
|
||||
let entry = Entry.of_file (titledir repo ^ y) in
|
||||
Entry.({ entry with body = if bodies then entry.body else None })
|
||||
in
|
||||
List.map t ymds
|
||||
|
||||
let latest_file_meta_pair config fragment =
|
||||
let open Ymd in
|
||||
let add config ymd =
|
||||
let open Lwt.Infix in
|
||||
Entry.to_file config ymd >>= fun () ->
|
||||
let open Ymd in
|
||||
if not (categorised [Category.Draft] ymd) && ymd.meta.title <> "" then
|
||||
let archive_path = config.Configuration.repository in
|
||||
let archive = of_repo archive_path in
|
||||
let dir = titledir archive_path in
|
||||
begin try
|
||||
let entry = List.find (fun entry -> entry.Entry.meta.uuid = ymd.meta.uuid) archive in
|
||||
if slug_of_filename entry.filepath <> (Ymd.filename ymd) then
|
||||
let found_filepath = dir ^ entry.filepath in
|
||||
Lwt_unix.rename found_filepath (next_semantic_filepath dir ymd);
|
||||
else Lwt.return ()
|
||||
with Not_found ->
|
||||
Lwt_unix.link (uuid_path archive_path ymd) (next_semantic_filepath dir ymd);
|
||||
end
|
||||
else
|
||||
Lwt.return ()
|
||||
end
|
||||
|
||||
let latest_entry config fragment =
|
||||
let repo = Configuration.(config.repository) in
|
||||
let latest p (path', meta') =
|
||||
if not @@ BatString.exists (meta'.title) fragment then None
|
||||
let latest p entry' =
|
||||
let open Entry in
|
||||
if not @@ BatString.exists (entry'.meta.title) fragment then None
|
||||
else
|
||||
match p with
|
||||
| Some (path, meta) ->
|
||||
if meta.date.Date.published < meta'.date.Date.published
|
||||
then Some (path', meta') else p
|
||||
| None -> Some (path', meta') in
|
||||
ListLabels.fold_left ~f:latest ~init:(None) (file_meta_pairs repo)
|
||||
| Some entry ->
|
||||
if entry.meta.date.Ymd.Date.published < entry'.meta.date.Ymd.Date.published
|
||||
then Some entry' else p
|
||||
| None -> Some entry' in
|
||||
ListLabels.fold_left ~f:latest ~init:(None) (Archive.of_repo repo)
|
||||
|
||||
@ -9,7 +9,7 @@ type listing_entry = Listing_entry of t
|
||||
type text = Text of t
|
||||
|
||||
let of_string = Mustache.of_string
|
||||
let of_file f = Logarion.load_file f |> of_string
|
||||
let of_file f = Logarion.File.load f |> of_string
|
||||
|
||||
let header f = Header (of_file f)
|
||||
let listing f = Listing (of_file f)
|
||||
@ -42,9 +42,10 @@ let fold_text ymd =
|
||||
| _ -> prerr_endline ("unknown tag: " ^ e); "" in
|
||||
Mustache.fold ~string ~section ~escaped ~unescaped ~partial ~comment ~concat
|
||||
|
||||
let fold_entry (file, meta) =
|
||||
let fold_entry (entry : Logarion.Entry.t) =
|
||||
let meta = entry.meta in
|
||||
let escaped e = match e with
|
||||
| "url" -> "text/" ^ Filename.chop_extension file
|
||||
| "url" -> "text/" ^ Filename.chop_extension entry.Logarion.Entry.filepath
|
||||
| "title" -> meta.title
|
||||
| "abstract" -> meta.abstract
|
||||
| "author_name" -> meta.author.Author.name
|
||||
@ -68,17 +69,18 @@ let fold_header blog_url title =
|
||||
| _ -> prerr_endline ("unknown tag: " ^ e); "" in
|
||||
Mustache.fold ~string ~section ~escaped ~unescaped ~partial ~comment ~concat
|
||||
|
||||
let fold_index ?(entry_tpl=None) ymd_meta_pairs =
|
||||
let simple (file, meta) =
|
||||
"<li><a href=\"/text/" ^ Filename.chop_extension file ^ "\">"
|
||||
^ meta.title ^ " ~ " ^ Ymd.Date.(pretty_date @@ last meta.date) ^ "</a></li>" in
|
||||
let fold_entry tpl (file, meta) = fold_entry (file, meta) tpl in
|
||||
let fold_index ?(entry_tpl=None) entries =
|
||||
let simple entry =
|
||||
"<li><a href=\"/text/" ^ Filename.chop_extension entry.Logarion.Entry.filepath ^ "\">"
|
||||
^ entry.meta.title ^ " ~ " ^ Ymd.Date.(pretty_date @@ last entry.meta.date) ^ "</a></li>" in
|
||||
let fold_entry tpl entry = fold_entry entry tpl in
|
||||
let entry = match entry_tpl with Some (Listing_entry e) -> fold_entry e | None -> simple in
|
||||
let escaped e = match e with
|
||||
| "recent_texts_listing" ->
|
||||
(ListLabels.fold_left
|
||||
~init:("<ul>")
|
||||
~f:(fun a (file, meta) -> a ^ (entry (file, meta)))
|
||||
ymd_meta_pairs) ^ "</ul>"
|
||||
~init:("<ul>")
|
||||
~f:(fun a e -> a ^ (entry e))
|
||||
entries)
|
||||
^ "</ul>"
|
||||
| _ -> prerr_endline ("unknown tag: " ^ e); "" in
|
||||
Mustache.fold ~string ~section ~escaped ~unescaped ~partial ~comment ~concat
|
||||
|
||||
33
src/web.ml
33
src/web.ml
@ -64,7 +64,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 unpublished_entry = Logarion.Entry.({ filepath = ""; meta = Ymd.blank_meta (); body = Some "No such published entry"; })
|
||||
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"
|
||||
@ -74,7 +75,7 @@ let () =
|
||||
let (>>=) = Lwt.(>>=)
|
||||
and (>|=) = Lwt.(>|=) in
|
||||
let module L = Logarion in
|
||||
let ymd f = L.of_file f |> (fun ymd -> if Ymd.(categorised [Category.Published]) ymd then ymd else Ymd.blank_ymd ()) in
|
||||
let ymd f = L.Entry.of_file f |> (fun entry -> if Ymd.(CategorySet.categorised [Category.Published]) entry.meta.categories then entry else 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 option_load tpl o = match o with Some f -> Some (tpl f) | None -> None in
|
||||
@ -85,25 +86,21 @@ let () =
|
||||
let blog_url = Configuration.(webcfg.url) 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_file_meta_pairs ~header_tpl ~listing_tpl ~entry_tpl blog_url lgrn in
|
||||
let latest_listed_meta fmp =
|
||||
fmp
|
||||
|> List.filter Ymd.(fun (_,a) -> not @@ CategorySet.categorised [Category.Unlisted] a.categories)
|
||||
|> List.fast_sort Ymd.(fun (_,b) (_,a) -> compare (Date.last a.date) (Date.last b.date))
|
||||
in
|
||||
let latest_listed_ymd fyp =
|
||||
fyp
|
||||
|> List.filter Ymd.(fun (_,a) -> not @@ CategorySet.categorised [Category.Unlisted] a.meta.categories)
|
||||
|> List.fast_sort Ymd.(fun (_,b) (_,a) -> compare (Date.last a.meta.date) (Date.last b.meta.date))
|
||||
let list_of_ymds = Html.of_entries ~header_tpl ~listing_tpl ~entry_tpl blog_url lgrn in
|
||||
let latest_listed_entries es =
|
||||
es
|
||||
|> List.filter Ymd.(fun a -> not @@ CategorySet.categorised [Category.Unlisted] a.L.Entry.meta.categories)
|
||||
|> List.fast_sort Ymd.(fun b a -> compare (Date.last a.L.Entry.meta.date) (Date.last b.L.Entry.meta.date))
|
||||
in
|
||||
let repo = lgrn.L.Configuration.repository in
|
||||
App.empty
|
||||
|> App.port webcfg.Configuration.port
|
||||
|> middleware @@ Middleware.static ~local_path:"./share/static" ~uri_prefix:"/static"
|
||||
|> post "/post" (fun req -> ymd_of_req req >>= fun ymd -> L.to_file lgrn ymd >>= fun () -> html_response (page_of_ymd ymd))
|
||||
|> get "/edit/:ttl" (fun r -> ret_param "ttl" r >>= ymdpath >|= ymd >|= form_of_ymd >>= html_response)
|
||||
|> post "/post" (fun req -> ymd_of_req req >>= fun ymd -> L.Entry.to_file lgrn ymd >>= fun () -> html_response (page_of_ymd ymd))
|
||||
|> get "/edit/:ttl" (fun r -> ret_param "ttl" r >>= ymdpath >|= ymd >|= L.Entry.to_ymd >|= form_of_ymd >>= html_response)
|
||||
|> get "/new" (fun _ -> Lwt.return (Ymd.blank_ymd ()) >|= form_of_ymd >>= html_response)
|
||||
|> get "/text/:ttl" (fun req -> ret_param "ttl" req >>= ymdpath >|= ymd >|= page_of_ymd >>= html_response)
|
||||
|> get "/!/:ttl" (fun req -> ret_param "ttl" req >|= L.latest_file_meta_pair lgrn >|= ymd_or_error >|= page_of_ymd >>= html_response)
|
||||
|> get "/feed.atom" (fun _ -> Lwt.return L.(file_ymd_pairs (titledir lgrn.Configuration.repository)) >|= latest_listed_ymd >|= Atom.feed webcfg.url lgrn >>= html_response)
|
||||
|> get "/" (fun _ -> Lwt.return L.(file_meta_pairs (titledir lgrn.Configuration.repository)) >|= latest_listed_meta >|= list_of_ymds >>= html_response)
|
||||
|> get "/text/:ttl" (fun req -> ret_param "ttl" req >>= ymdpath >|= ymd >|= L.Entry.to_ymd >|= page_of_ymd >>= html_response)
|
||||
|> get "/!/:ttl" (fun req -> ret_param "ttl" req >|= L.latest_entry lgrn >|= entry_option >|= L.Entry.to_ymd >|= page_of_ymd >>= html_response)
|
||||
|> get "/feed.atom" (fun _ -> Lwt.return L.Archive.(of_repo ~bodies:true repo) >|= latest_listed_entries >|= List.map L.Entry.to_ymd >|= Atom.feed webcfg.url lgrn >>= html_response)
|
||||
|> get "/" (fun _ -> Lwt.return L.Archive.(of_repo repo) >|= latest_listed_entries >|= list_of_ymds >>= html_response)
|
||||
|> App.run_command
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user