diff --git a/src/atom.ml b/src/atom.ml
index 660b599..8cb2964 100644
--- a/src/atom.ml
+++ b/src/atom.ml
@@ -25,5 +25,5 @@ let entry url logarion ymd =
let feed url logarion articles =
""
^ 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
^ ""
diff --git a/src/command.ml b/src/command.ml
index 16aa6c2..c0bd4da 100644
--- a/src/command.ml
+++ b/src/command.ml
@@ -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),
diff --git a/src/html.ml b/src/html.ml
index 9f44ae9..bad34d1 100644
--- a/src/html.ml
+++ b/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 =
diff --git a/src/logarion.ml b/src/logarion.ml
index fe8cb84..1b46644 100644
--- a/src/logarion.ml
+++ b/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)
diff --git a/src/template.ml b/src/template.ml
index 7a26e34..a35e86b 100644
--- a/src/template.ml
+++ b/src/template.ml
@@ -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) =
- ""
- ^ meta.title ^ " ~ " ^ Ymd.Date.(pretty_date @@ last meta.date) ^ "" in
- let fold_entry tpl (file, meta) = fold_entry (file, meta) tpl in
+let fold_index ?(entry_tpl=None) entries =
+ let simple entry =
+ ""
+ ^ entry.meta.title ^ " ~ " ^ Ymd.Date.(pretty_date @@ last entry.meta.date) ^ "" 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:("")
- ~f:(fun a (file, meta) -> a ^ (entry (file, meta)))
- ymd_meta_pairs) ^ "
"
+ ~init:("")
+ ~f:(fun a e -> a ^ (entry e))
+ entries)
+ ^ "
"
| _ -> prerr_endline ("unknown tag: " ^ e); "" in
Mustache.fold ~string ~section ~escaped ~unescaped ~partial ~comment ~concat
diff --git a/src/web.ml b/src/web.ml
index 66ee7b0..ffd7533 100644
--- a/src/web.ml
+++ b/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