introduction of Archive and Entry submodules

src/atom.ml

@@ -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>"

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),

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) =
+let article_link entry =
-  li [a ~a:[a_href (uri_of_string ("/text/" ^ Filename.chop_extension file))]
+  let module E = Logarion.Entry in
-        [Unsafe.data (Ymd.(meta.title) ^ Ymd.Date.(pretty_date @@ last meta.Ymd.date)) ]
+  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)
+     | Some (Template.Listing s) -> Unsafe.data Template.(fold_index ~entry_tpl entries s)
-     | None -> (div [ h2 [pcdata "Articles"]; ul (List.map article_link file_meta_pairs); ]))
+     | None -> (div [ h2 [pcdata "Articles"]; ul (List.map article_link entries); ]))
   |> to_string
 
 let form ?(header_tpl=None) blog_url lgrn ymd =

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 =
+module Entry = struct
-  let ic = open_in f in
+  type t = { filepath : string; meta : Ymd.meta; body : string option }
-  let n = in_channel_length ic in
-  let s = Bytes.create n in
-  really_input ic s 0 n;
-  close_in ic;
-  (s)
 
-let of_file s =
+  let of_file s =
-  let segments = Re_str.(split (regexp "^---$")) (load_file s) in
+    let segments = Re_str.(split (regexp "^---$")) (File.load s) in
-  let open Ymd in
+    let open Ymd in
-  if List.length segments = 2 then
+    if List.length segments = 2 then
-    let yaml_str = List.nth segments 0 in
+      let yaml_str = List.nth segments 0 in
-    let md_str = List.nth segments 1 in
+      let md_str = List.nth segments 1 in
-    let m = meta_of_yaml yaml_str in
+      let m = meta_of_yaml yaml_str in
-    { meta = m; body = md_str }
+      { filepath = s; meta = m; body = Some md_str }
-  else
+    else
-    { (blank_ymd ()) with body = "Error parsing file" }
+      { filepath = s; meta = blank_meta (); body = Some "Error parsing file" }
 
-let file_meta_pairs titles =
+  let to_file config ymd =
-  let files = Array.to_list @@ Sys.readdir titles in
+    let repo = Configuration.(config.repository) in
-  let ymd_list a e = if BatString.ends_with e extension then List.cons e a else a in
+    let uuid_path = uuid_path repo ymd in
-  let ymds = List.fold_left ymd_list [] files in
+    let write_ymd out = Lwt_io.write out (Ymd.to_string ymd) in
-  let t y = (y, (of_file (titles ^ y)).Ymd.meta) in
+    Lwt_io.with_file ~mode:Lwt_io.output uuid_path write_ymd
-  List.map t ymds
 
-let file_ymd_pairs titles =
+  let to_ymd entry = { Ymd.meta = entry.meta; Ymd.body = match entry.body with Some b -> b | None -> "" }
-  let files = Array.to_list @@ Sys.readdir titles in
+end
-  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 slug_of_filename filename = List.hd @@ BatString.split_on_char '.' filename
-  let t y = (y, (of_file (titles ^ y))) in
-  List.map t ymds
 
 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 of_repo ?(bodies=false) repo =
-  let open Lwt.Infix in
+    let files = Array.to_list @@ Sys.readdir (titledir repo) in
-  let repo = Configuration.(config.repository) in
+    let ymd_list a e = if BatString.ends_with e extension then List.cons e a else a in
-  let uuid_path = uuid_path repo ymd in
+    let ymds = List.fold_left ymd_list [] files in
-  let write_ymd out = Lwt_io.write out (Ymd.to_string ymd) in
+    let t y =
-  Lwt_io.with_file ~mode:Lwt_io.output uuid_path write_ymd;
+      let entry = Entry.of_file (titledir repo ^ y) in
-  >>= fun () ->
+      Entry.({ entry with body = if bodies then entry.body else None })
-  let open Ymd in
+    in
-  if not (categorised [Category.Draft] ymd) && ymd.meta.title <> "" then 
+    List.map t ymds
-    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 latest_file_meta_pair config fragment =
+  let add config ymd =
-  let open Ymd in
+    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') =
+  let latest p entry' =
-    if not @@ BatString.exists (meta'.title) fragment then None
+    let open Entry in
+    if not @@ BatString.exists (entry'.meta.title) fragment then None
     else
       match p with
-      | Some (path, meta) ->
+      | Some entry ->
-         if meta.date.Date.published < meta'.date.Date.published
+         if entry.meta.date.Ymd.Date.published < entry'.meta.date.Ymd.Date.published
-         then Some (path', meta') else p
+         then Some entry' else p
-      | None -> Some (path', meta') in
+      | None -> Some entry' in
-  ListLabels.fold_left ~f:latest ~init:(None) (file_meta_pairs repo)
+  ListLabels.fold_left ~f:latest ~init:(None) (Archive.of_repo repo)

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 fold_index ?(entry_tpl=None) entries =
-  let simple (file, meta) =
+  let simple entry =
-    "<li><a href=\"/text/" ^ Filename.chop_extension file ^ "\">"
+    "<li><a href=\"/text/" ^ Filename.chop_extension entry.Logarion.Entry.filepath ^ "\">"
-    ^ meta.title ^ " ~ " ^ Ymd.Date.(pretty_date @@ last meta.date) ^ "</a></li>" in
+    ^ entry.meta.title ^ " ~ " ^ Ymd.Date.(pretty_date @@ last entry.meta.date) ^ "</a></li>" in
-  let fold_entry tpl (file, meta) = fold_entry (file, meta) tpl 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>")
+          ~init:("<ul>")
-         ~f:(fun a (file, meta) -> a ^ (entry (file, meta)))
+          ~f:(fun a e -> a ^ (entry e))
-         ymd_meta_pairs) ^ "</ul>"
+          entries)
+       ^ "</ul>"
     | _ -> prerr_endline ("unknown tag: " ^ e); "" in
   Mustache.fold ~string ~section ~escaped ~unescaped ~partial ~comment ~concat

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 list_of_ymds = Html.of_entries ~header_tpl ~listing_tpl ~entry_tpl blog_url lgrn in
-  let latest_listed_meta fmp =
+  let latest_listed_entries es =
-    fmp
+    es
-    |> List.filter Ymd.(fun (_,a) -> not @@ CategorySet.categorised [Category.Unlisted] a.categories)
+    |> 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.date) (Date.last b.date))
+    |> List.fast_sort Ymd.(fun b a -> compare (Date.last a.L.Entry.meta.date) (Date.last b.L.Entry.meta.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))
   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))
+  |> 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 >|= form_of_ymd >>= html_response)
+  |> 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 "/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_file_meta_pair lgrn >|= ymd_or_error >|= 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.(file_ymd_pairs  (titledir lgrn.Configuration.repository)) >|= latest_listed_ymd  >|= Atom.feed webcfg.url lgrn >>= 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.(file_meta_pairs (titledir lgrn.Configuration.repository)) >|= latest_listed_meta >|= list_of_ymds >>= html_response)
+  |> get "/"          (fun _   -> Lwt.return L.Archive.(of_repo repo) >|= latest_listed_entries >|= list_of_ymds >>= html_response)
   |> App.run_command