diff --git a/src/atom.ml b/src/atom.ml index 8cb2964..e4718a1 100644 --- a/src/atom.ml +++ b/src/atom.ml @@ -9,7 +9,8 @@ let header logarion = let entry url logarion ymd = let open Ymd in - let open Ymd.Author in + let open Meta in + let open Author in "" ^ "" ^ ymd.meta.title ^ "" ^ "" diff --git a/src/command.ml b/src/command.ml index c0bd4da..0028e60 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.Entry.to_file cfg Ymd.({ (blank_ymd ()) with meta = { (blank_meta ()) with title = t }}) + Logarion.Entry.to_file cfg Ymd.({ (blank ()) with meta = { (Meta.blank ()) with Meta.title = t }}) |> Lwt_main.run in Term.(const create_f $ title), diff --git a/src/html.ml b/src/html.ml index 57ab981..44c4f78 100644 --- a/src/html.ml +++ b/src/html.ml @@ -24,8 +24,8 @@ let logarion_text ?(text_tpl=None) ymd = let ymd_body = Omd.to_html (Omd.of_string Ymd.(ymd.body)) in article [ details - (summary [Unsafe.data Ymd.(ymd.meta.abstract)]) - [time ~a:[a_datetime Ymd.(Date.(pretty_date @@ last ymd.meta.date))] []]; + (summary [Unsafe.data Ymd.(ymd.meta.Meta.abstract)]) + [time ~a:[a_datetime Ymd.(Date.(pretty_date @@ last ymd.meta.Meta.date))] []]; Unsafe.data ymd_body; ] @@ -33,7 +33,7 @@ let of_ymd ?(header_tpl=None) ?(text_tpl=None) blog_url lgrn ymd = logarion_page ~header_tpl blog_url - Ymd.(ymd.meta.title ^ " by " ^ ymd.meta.author.Author.name) + Ymd.(Meta.(ymd.meta.title ^ " by " ^ ymd.meta.Meta.author.Author.name)) Logarion.Configuration.(lgrn.title) (logarion_text ~text_tpl ymd) |> to_string @@ -42,7 +42,7 @@ let article_link entry = let open Logarion.Entry in let u = "/text/" ^ Filename.(entry.filepath |> basename |> chop_extension) in li [a ~a:[a_href (uri_of_string u)] - [Unsafe.data (entry.meta.title ^ Date.(pretty_date @@ last entry.meta.date)) ] + [Unsafe.data (title entry ^ (Ymd.Date.pretty_date (entry |> date |> Ymd.Date.last))) ] ] let of_entries ?(header_tpl=None) ?(listing_tpl=None) ?(entry_tpl=None) blog_url lgrn = @@ -63,8 +63,11 @@ let form ?(header_tpl=None) blog_url lgrn ymd = let input_set title input = p [ label [ pcdata title; input ] ] in let either a b = if a <> "" then a else b in let open Ymd in - let auth_name = either ymd.meta.author.Author.name Logarion.Configuration.(lgrn.owner) in - let auth_addr = either ymd.meta.author.Author.email Logarion.Configuration.(lgrn.email) in + let open Meta in + let open Author in + let auth = ymd.meta.author in + let auth_name = either auth.name Logarion.Configuration.(lgrn.owner) in + let auth_addr = either auth.email Logarion.Configuration.(lgrn.email) in [ input ~a:[a_name "uuid"; a_value (Id.to_string ymd.meta.uuid); a_input_type `Hidden] (); input_set diff --git a/src/logarion.ml b/src/logarion.ml index 97e3951..18b0b38 100644 --- a/src/logarion.ml +++ b/src/logarion.ml @@ -43,28 +43,27 @@ module File = struct really_input ic s 0 n; close_in ic; (s) + + let ymd f = Ymd.of_string (load f) 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 uuid_path repo ymd = uuiddir repo ^ Ymd.(Id.to_string ymd.meta.Meta.uuid) ^ extension module Entry = struct - include Ymd - type t = { filepath : string; meta : Ymd.meta; body : string option } + open Ymd.Meta + type t = { filepath : string; attributes : Ymd.Meta.t } [@@deriving lens] + + let title entry = entry.attributes.title + let date entry = entry.attributes.date + let published entry = entry.attributes.date.Ymd.Date.published 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 ymd = File.ymd s in + { filepath = s; attributes = ymd.Ymd.meta } let to_file config ymd = let repo = Configuration.(config.repository) in @@ -72,7 +71,7 @@ module Entry = struct 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 to_ymd entry = { Ymd.meta = entry.meta; Ymd.body = match entry.body with Some b -> b | None -> "" } + let to_ymd entry = File.ymd entry.filepath end let slug_of_filename filename = List.hd @@ BatString.split_on_char '.' filename @@ -85,31 +84,33 @@ let rec next_semantic_filepath ?(version=0) titles ymd = module Archive = struct type t = Entry.t list - let latest = List.fast_sort Ymd.(fun b a -> compare (Date.last a.Entry.meta.date) (Date.last b.Entry.meta.date)) - let listed = List.filter Ymd.(fun a -> not @@ CategorySet.categorised [Category.Unlisted] a.Entry.meta.categories) + let latest = List.fast_sort (fun b a -> Ymd.Date.compare (Entry.date a) (Entry.date b)) + let listed = List.filter Ymd.(fun a -> not @@ CategorySet.categorised [Category.Unlisted] (a.Entry.attributes.Meta.categories)) - let of_repo ?(bodies=false) repo = + let of_repo 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 }) + let to_entry y = Entry.of_file (titledir repo ^ y) in + let fold_file a file = + if BatString.ends_with file extension + then try List.cons (to_entry file) a with + Ymd.Syntax_error str -> prerr_endline str; a + else a in - List.map t ymds + List.fold_left fold_file [] files let add config ymd = let open Lwt.Infix in - let open Entry in - to_file config ymd >>= fun () -> - if not (categorised [Category.Draft] ymd) && ymd.meta.title <> "" then + Entry.to_file config ymd >>= fun () -> + let open Ymd in + if not (categorised [Category.Draft] ymd) && ymd.meta.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.meta.uuid = ymd.meta.uuid) archive in - if slug_of_filename entry.filepath <> filename ymd then - let found_filepath = dir ^ entry.filepath in + let uuid x = x.Ymd.Meta.uuid in + let entry = List.find (fun entry -> uuid entry.Entry.attributes = uuid ymd.meta) archive in + if slug_of_filename entry.Entry.filepath <> filename ymd then + let found_filepath = dir ^ entry.Entry.filepath in Lwt_unix.rename found_filepath (next_semantic_filepath dir ymd); else Lwt.return () with Not_found -> @@ -125,7 +126,7 @@ module Archive = struct if not (List.exists p ts) then unique_entry (List.cons h ts) t else unique_entry ts t | [] -> ts in - let unique_topics ts x = unique_entry ts Entry.(x.meta.topics) in + let unique_topics ts x = unique_entry ts x.Entry.attributes.Ymd.Meta.topics in List.fold_left unique_topics [] archive let latest_listed entries = entries |> listed |> latest @@ -135,28 +136,26 @@ let latest_entry config fragment = let repo = Configuration.(config.repository) in let latest last_match entry = let open Entry in - if not @@ BatString.exists entry.meta.title fragment then last_match + if not @@ BatString.exists (title entry) fragment then last_match else match last_match with | Some last_entry -> - if last_entry.meta.date.Date.published >= entry.meta.date.Date.published - then last_match else Some entry + if published last_entry >= published entry then last_match else Some entry | None -> Some entry in ListLabels.fold_left ~f:latest ~init:(None) (Archive.of_repo repo) let entry_with_slug config slug = let repo = Archive.of_repo @@ Configuration.(config.repository) in let split_slug = BatString.split_on_char '.' slug in - if List.length split_slug > 2 then Some (Entry.of_file slug) + let open Entry in + if List.length split_slug > 2 then Some (of_file slug) else let slug = List.hd split_slug in let slugged last_match entry = - let open Entry in - if slug <> Ymd.filename_of_title entry.meta.title then last_match + if slug <> Ymd.filename_of_title (title entry) then last_match else match last_match with | Some last_entry -> - if last_entry.meta.date.Date.published >= entry.meta.date.Date.published - then last_match else Some entry + if published last_entry >= published entry then last_match else Some entry | None -> Some entry in ListLabels.fold_left ~f:slugged ~init:(None) repo diff --git a/src/template.ml b/src/template.ml index 01a7620..ed37800 100644 --- a/src/template.ml +++ b/src/template.ml @@ -25,6 +25,7 @@ let concat l = String.concat "" l let fold_text ymd = let open Ymd in + let open Ymd.Meta in let escaped e = match e with | "title" -> ymd.meta.title | "abstract" -> ymd.meta.abstract @@ -45,7 +46,9 @@ let fold_text ymd = let fold_entry (entry : Logarion.Entry.t) = let open Logarion.Entry in - let meta = entry.meta in + let meta = entry.attributes in + let open Ymd in + let open Ymd.Meta in let escaped e = match e with | "url" -> "/text/" ^ Filename.(entry.filepath |> basename |> chop_extension) | "title" -> meta.title @@ -72,10 +75,11 @@ let fold_header blog_url title = Mustache.fold ~string ~section ~escaped ~unescaped ~partial ~comment ~concat let fold_index ?(entry_tpl=None) lgrn = + let open Ymd in let open Logarion.Entry in let simple entry = "
  • basename |> chop_extension) ^ "\">" - ^ entry.meta.title ^ " ~ " ^ Date.(pretty_date @@ last entry.meta.date) ^ "
    • " in + ^ entry.attributes.Meta.title ^ " ~ " ^ Date.(pretty_date (entry |> date |> last)) ^ "" 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 diff --git a/src/web.ml b/src/web.ml index 33739f6..111a24b 100644 --- a/src/web.ml +++ b/src/web.ml @@ -55,8 +55,8 @@ end let ymd_of_body_pairs pairs = let open Ymd in let open Lens.Infix in - ListLabels.fold_left ~f:(fun a (k,vl) -> with_kv a (k, List.hd vl) ) ~init:(blank_ymd ()) pairs - |> ((ymd_meta |-- meta_date |-- Date.edited) ^= Some (Ptime_clock.now ())) + ListLabels.fold_left ~f:(fun a (k,vl) -> with_kv a (k, List.hd vl) ) ~init:(blank ()) pairs + |> ((ymd_meta |-- Meta.lens_date |-- Date.edited) ^= Some (Ptime_clock.now ())) let ymd_of_req req = Lwt.map ymd_of_body_pairs (App.urlencoded_pairs_of_body req) @@ -64,7 +64,7 @@ let ymd_of_req req = let string_response s = `String s |> respond' let html_response h = `Html h |> respond' -let unpublished_entry = Logarion.Entry.({ filepath = ""; meta = Ymd.blank_meta (); body = Some "No such published entry"; }) +let unpublished_entry = Logarion.Entry.({ filepath = ""; attributes = Ymd.Meta.blank () }) let entry_option y = match y with Some entry -> entry | None -> unpublished_entry let webcfg = Configuration.of_filename "web.toml" @@ -78,7 +78,7 @@ let () = let ymd f = try L.Entry.of_file f - |> (fun entry -> if Ymd.(CategorySet.categorised [Category.Published]) entry.L.Entry.meta.Ymd.categories + |> (fun entry -> if Ymd.(CategorySet.categorised [Category.Published]) entry.L.Entry.attributes.Ymd.Meta.categories then entry else unpublished_entry) with Sys_error _ -> unpublished_entry in @@ -99,9 +99,9 @@ let () = |> middleware @@ Middleware.static ~local_path:"./share/static" ~uri_prefix:"/static" |> post "/post" (fun req -> ymd_of_req req >>= fun ymd -> L.Archive.add 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 "/new" (fun _ -> Lwt.return (Ymd.blank ()) >|= form_of_ymd >>= html_response) |> get "/text/:ttl" (fun req -> ret_param "ttl" req >|= L.entry_with_slug lgrn >|= entry_option >|= 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) >|= L.Archive.latest_listed >|= List.map L.Entry.to_ymd >|= Atom.feed webcfg.Configuration.url lgrn >>= html_response) + |> get "/feed.atom" (fun _ -> Lwt.return L.Archive.(of_repo repo) >|= L.Archive.latest_listed >|= List.map L.Entry.to_ymd >|= Atom.feed webcfg.Configuration.url lgrn >>= html_response) |> get "/" (fun _ -> Lwt.return list_of_ymds >>= html_response) |> App.run_command diff --git a/src/ymd.ml b/src/ymd.ml index 2b62bd2..25eadea 100644 --- a/src/ymd.ml +++ b/src/ymd.ml @@ -16,6 +16,8 @@ module Date = struct let last date = match date.published with Some t -> Some t | None -> date.edited + let compare a b = compare (last a) (last b) + let pretty_date = function | Some t -> Ptime.to_date t |> fun (y, m, d) -> Printf.sprintf "%04d-%02d-%02d" y m d @@ -63,33 +65,35 @@ module CategorySet = struct let categorised categs cs = of_list categs |> (fun s -> subset s cs) end -type meta = { - title: string; - author: Author.t; - date: Date.t; - categories: CategorySet.t; - topics: string list; - keywords: string list; - series: string list; - abstract: string; - uuid: Id.t - } [@@deriving lens] +module Meta = struct + type t = { + title: string; + author: Author.t; + date: Date.t; + categories: CategorySet.t; + topics: string list; + keywords: string list; + series: string list; + abstract: string; + uuid: Id.t + } [@@deriving lens { prefix = true }] + + let blank ?(uuid=(Id.generate ())) () = { + title = ""; + author = Author.({ name = ""; email = "" }); + date = Date.({ edited = None; published = None }); + categories = CategorySet.empty; topics = []; keywords = []; series = []; + abstract = ""; + uuid; + } +end type ymd = { - meta: meta; + meta: Meta.t; body: string; } [@@deriving lens] -let blank_meta ?(uuid=(Id.generate ())) () = { - title = ""; - author = Author.({ name = ""; email = "" }); - date = Date.({ edited = None; published = None }); - categories = CategorySet.empty; topics = []; keywords = []; series = []; - abstract = ""; - uuid; - } - -let blank_ymd ?(uuid=(Id.generate ())) () = { meta = blank_meta ~uuid (); body = "" } +let blank ?(uuid=(Id.generate ())) () = { meta = Meta.blank ~uuid (); body = "" } let filename_of_title t = let is_reserved = function @@ -106,32 +110,33 @@ let filename_of_title t = else Char.lowercase_ascii head :: (filter dash tail) in Batteries.String.of_list @@ filter drop (Batteries.String.to_list t) -let filename ymd = filename_of_title ymd.meta.title +let filename ymd = filename_of_title ymd.meta.Meta.title let trim_str v = v |> String.trim let of_str y k v = Lens.Infix.(k ^= trim_str v) y -let categorised categs ymd = CategorySet.categorised categs ymd.meta.categories +let categorised categs ymd = CategorySet.categorised categs ymd.meta.Meta.categories let with_meta_kv meta (k,v) = let list_of_csv = Re_str.(split (regexp " *, *")) in let of_str_list y k v = Lens.Infix.(k ^= list_of_csv (trim_str v)) y in let open Lens.Infix in + let open Meta in match k with - | "title" -> of_str meta (meta_title) v - | "name" -> of_str meta (meta_author |-- Author.name ) v - | "email" -> of_str meta (meta_author |-- Author.email) v - | "abstract" -> of_str meta meta_abstract v - | "published" -> ((meta_date |-- Date.published) ^= Date.of_string v) meta - | "edited" -> ((meta_date |-- Date.edited ) ^= Date.of_string v) meta - | "topics" -> of_str_list meta meta_topics v - | "keywords" -> of_str_list meta meta_keywords v + | "title" -> of_str meta lens_title v + | "name" -> of_str meta (lens_author |-- Author.name ) v + | "email" -> of_str meta (lens_author |-- Author.email) v + | "abstract" -> of_str meta lens_abstract v + | "published" -> ((lens_date |-- Date.published) ^= Date.of_string v) meta + | "edited" -> ((lens_date |-- Date.edited ) ^= Date.of_string v) meta + | "topics" -> of_str_list meta lens_topics v + | "keywords" -> of_str_list meta lens_keywords v | "categories"-> let list = trim_str v |> list_of_csv in let list = List.map Category.of_string list in - (meta_categories ^= CategorySet.of_list list) meta - | "series" -> of_str_list meta meta_series v + (lens_categories ^= CategorySet.of_list list) meta + | "series" -> of_str_list meta lens_series v | "uuid" -> - (match Id.of_string v with Some id -> (meta_uuid ^= id) meta | None -> meta) + (match Id.of_string v with Some id -> (lens_uuid ^= id) meta | None -> meta) | _ -> meta let with_kv ymd (k,v) = @@ -149,21 +154,21 @@ let meta_pair_of_string line = let meta_of_yaml yaml = let fields = List.map meta_pair_of_string (BatString.nsplit yaml "\n") in let open Lens.Infix in - List.fold_left with_meta_kv (blank_meta ()) fields + List.fold_left with_meta_kv (Meta.blank ()) fields + +exception Syntax_error of string let of_string s = let segments = Re_str.(split (regexp "^---$")) s 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" } + if List.length segments <> 2 + then raise @@ Syntax_error ("Invalid number of segments in " ^ s); + let yaml_str = List.nth segments 0 in + { meta = meta_of_yaml yaml_str; body = List.nth segments 1 } let make ?(author_name="") ?(author_email="") ?(date_published=None) ?(date_edited=None) ?(abstract="") ?(topics=[]) ?(keywords=[]) ?(categories=CategorySet.empty) ?(series=[]) title body = + let open Meta in { meta = { title; @@ -188,6 +193,7 @@ let make ?(author_name="") ?(author_email="") ?(date_published=None) ?(date_edit let to_string ymd = let buf = Buffer.create (String.length ymd.body + 256) in let buf_acc = Buffer.add_string buf in + let open Meta in List.iter buf_acc [ "---\n"; "title: "; ymd.meta.title;