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

Abstracts store (back-end) using the Archive functor

Browse Source 
Introduces Store module type.

Logarion module:

* Removed Entry submodule, it mostly duplicated Meta
* Make functor for creating archives given a Store compatible module
  The output Archive module contains functions for sorting, ordering, selecting
  and accumulating (storing) notes.

Meta module:

* Function Path.basename_of_title has been renamed to Meta.string_of_slug
  This is because slugs are now defined explicitely by 'slug' field or derived from
  'title' field. Counting numbers can't be used anymore.
  Slug has an optional, dedicated field.
  Function Meta.slug should be used on a Meta to get the appropriate slug (title or slug).
* Introduces StringSet type (Set of Strings)
  Topics, keywords and series are now StringSets
* Adds SlugMap and IdMap aliases

Note module:

* Automatically scan for Markdown heading to use as title in the absence of one

File module:

* File has a Store compatible signature
  The implementation has an Lwt hack; Lwt will be fully supported in the future

Web module:

* Uses new Logarion.Configuration, File store and Archive.t

Template module:

* Adapted for new types
* Currently disabled topics substitution, because this framework needs reconsideration

Finally:

* Adapts command line interface to work with new store
* Adapts Atom feed to work with new store

Path module renamed to Lpath to avoid clash with OCaml system module.

(Squashed commits from dev)
This commit is contained in:
Stavros Polymenis 2017-05-17 00:16:44 +01:00
parent d425e2f78b
commit 1962203237
11 changed files with 301 additions and 216 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
src/atom.ml
View File

@ -1,12 +1,13 @@
let esc = Xml_print.encode_unsafe_char
let header logarion url =
let open Logarion.Configuration in
"<title>" ^ logarion.title ^ "</title>"
let header config url =
let open Logarion in
let open Configuration in
"<title>" ^ config.title ^ "</title>"
(* ^ "<subtitle>A subtitle.</subtitle>"*)
^ "<link rel=\"alternate\" type=\"text/html\" href=\"" ^ url ^ "\"/>"
^ "<link rel=\"self\" type=\"application/atom+xml\" href=\"" ^ url ^ "feed.atom\" />"
^ "<id>urn:uuid:" ^ Logarion.Id.to_string logarion.id ^ "</id>"
^ "<id>urn:uuid:" ^ Id.to_string config.id ^ "</id>"
^ "<updated>" ^ Ptime.(to_rfc3339 (Ptime_clock.now ())) ^ "</updated>"
let opt_element tag_name content body =
@ -14,13 +15,12 @@ let opt_element tag_name content body =
then body ^ "<" ^ tag_name ^ ">" ^ content ^ "</" ^ tag_name ^ ">"
else body
let entry repo url logarion note =
let entry config url node_fn note =
let open Logarion in
let file = File.note note.Entry.path in
let meta = note.Note.meta in
let u = "note/" ^ Meta.slug meta in
let open Meta in
let open Author in
let u = "note/" ^ Entry.slug note in
let meta = file.Note.meta in
("<entry>"
^ "<title>" ^ meta.title ^ "</title>"
^ "<id>urn:uuid:" ^ Meta.Id.to_string meta.uuid ^ "</id>"
@ -32,12 +32,16 @@ let entry repo url logarion note =
|> opt_element "summary" @@ esc meta.abstract)
^ "</author>"
^ "<content type=\"xhtml\"><div xmlns=\"http://www.w3.org/1999/xhtml\">"
^ (Omd.to_html @@ Omd.of_string @@ esc file.Note.body)
^ (Omd.to_html @@ Omd.of_string @@ esc note.Note.body)
^ "</div></content>"
^ "</entry>"
let feed repo url logarion articles =
let feed config url note_fn articles =
let fold_valid feed m = match note_fn m.Meta.uuid with
| Some note -> feed ^ "\n" ^ entry config url note_fn note
| None -> feed
in
"<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<feed xmlns=\"http://www.w3.org/2005/Atom\">\n"
^ header logarion url
^ List.fold_left (fun feed note -> feed ^ "\n" ^ entry repo url logarion note) "" articles
^ header config url
^ List.fold_left fold_valid "" articles
^ "</feed>"

10
src/command.ml
View File

@ -2,12 +2,12 @@ open Cmdliner
module C = Logarion.Configuration
let conf () =
try C.of_toml_file (Path.from_config_paths "logarion.toml")
try C.of_toml_file (Lpath.from_config_paths "logarion.toml")
with Not_found -> prerr_endline ("No logarion.toml; using default values"); C.default ()
let init =
let f force =
let repo = Path.string_of_repo @@ (conf ()).C.repository in
let repo = Lpath.string_of_repo @@ (conf ()).C.repository in
prerr_endline repo;
let make_dir d =
let open Unix in
@ -17,7 +17,7 @@ let init =
if not force && Array.length (Sys.readdir repo) > 0 then
prerr_endline @@ "Directory " ^ repo ^ " is it not empty. Call with -f to init anyway."
else
List.iter make_dir [Fpath.to_string Path.notes];
List.iter make_dir [Fpath.to_string Lpath.notes];
in
let force =
Arg.(value & flag & info ["f"; "force"] ~doc:"Initialise repository even if directory is non empty")
@ -35,7 +35,9 @@ let create =
let repo = (conf ()).C.repository in
let t = match title with "" -> "Draft" | _ -> title in
let note = Note.({ (blank ()) with meta = { (Meta.blank ()) with Meta.title = t }}) in
ignore (Logarion.Archive.delta_of repo note |> File.Lwt.with_note note |> Lwt_main.run)
File.Lwt.with_note (File.store repo) note
|> Lwt_main.run
|> ignore
in
Term.(const f $ title),
Term.info "create"

88
src/file.ml
View File

@ -6,12 +6,67 @@ let load f =
close_in ic;
(s)
let note path = Path.fpath_of_note path |> load |> Note.of_string
let note path = Lpath.fpath_of_note path |> load |> Note.of_string
let notes_of_repo repo =
Path.(notes_of_repo repo |> string_of_notes)
type t = { repo_path : Lpath.repo_t }
let to_list ?(order) lens_fn store =
let repo_path = store.repo_path in
let cons_valid_meta list path =
try
let note = note (Lpath.note_of_basename repo_path path) in
lens_fn note :: list
with Note.Syntax_error str -> prerr_endline str; list
in
Lpath.(notes_of_repo repo_path |> string_of_notes)
|> Sys.readdir
|> Array.to_list
|> List.filter (fun file -> BatString.ends_with file Lpath.extension)
|> List.fold_left cons_valid_meta []
|> match order with
| Some fn -> List.fast_sort fn
| None -> (fun x -> x)
let note_with_id store id =
let repo_path = store.repo_path in
let note_of_path path = note (Lpath.note_of_basename repo_path path) in
let with_id path =
try
let note = note_of_path path in
note.Note.meta.Meta.uuid = id
with Note.Syntax_error str -> prerr_endline str; false
in
let notes =
Lpath.(notes_of_repo repo_path |> string_of_notes)
|> Sys.readdir
|> Array.to_list
|> List.filter (fun file -> BatString.ends_with file Lpath.extension)
in
try Some (note_of_path (List.find with_id notes))
with Not_found -> None
let note_with_alias store alias =
let repo_path = store.repo_path in
let cons_valid_meta list path =
try (note (Lpath.note_of_basename repo_path path)) :: list
with Note.Syntax_error str -> prerr_endline str; list
in
let recency_order a b = Meta.(Date.compare b.date a.date) in
let notes =
Lpath.(notes_of_repo repo_path |> string_of_notes)
|> Sys.readdir
|> Array.to_list
|> List.filter (fun file -> BatString.ends_with file Lpath.extension)
|> List.fold_left cons_valid_meta []
|> List.filter (fun note -> Meta.slug note.Note.meta = alias)
|> List.fast_sort (fun a b -> recency_order a.Note.meta b.Note.meta)
in
try Some (List.hd notes)
with Failure _ -> None
let notepath_with_id store id = None
let store repo_path = { repo_path }
module Lwt = struct
let of_filename f =
@ -19,12 +74,25 @@ module Lwt = struct
Lwt_io.(open_file ~mode:(Input) f >|= read_lines)
>|= (fun stream -> Lwt_stream.fold (^) stream "")
let with_note note (previous, filepath) =
let with_note store new_note =
let open Lwt in
let write_note out = Lwt_io.write out (Note.to_string note) in
ignore_result (Lwt_io.with_file ~mode:Lwt_io.output (Path.string_of_note filepath) write_note);
(match previous with
| Some path -> if path <> filepath then ignore_result (Lwt_unix.unlink @@ Path.string_of_note path);
| None -> ());
return note;
let write_note out = Lwt_io.write out (Note.to_string new_note) in
let () = match notepath_with_id store new_note.Note.meta.Meta.uuid with
| Some previous_path ->
let filepath =
let open Note in
let open Meta in
if (note previous_path).meta.title <> new_note.meta.title
then Lpath.versioned_basename_of_title store.repo_path new_note.meta.title
else previous_path
in
ignore_result (Lwt_io.with_file ~mode:Lwt_io.output (Lpath.string_of_note filepath) write_note);
if previous_path <> filepath then ignore_result (Lwt_unix.unlink @@ Lpath.string_of_note previous_path)
| None ->
let filepath = Lpath.versioned_basename_of_title store.repo_path new_note.meta.title in
ignore_result (Lwt_io.with_file ~mode:Lwt_io.output (Lpath.string_of_note filepath) write_note);
in
return new_note;
end
let with_note = Lwt.with_note

41
src/html.ml
View File

@ -36,28 +36,29 @@ let of_note ?(header_tpl=None) ?(note_tpl=None) blog_url lgrn ymd =
~header_tpl
blog_url
(Note.title ymd ^ " by " ^ ymd.Note.meta.Meta.author.Meta.Author.name)
Logarion.Configuration.(lgrn.title)
Logarion.(lgrn.Configuration.title)
(logarion_note ~note_tpl ymd)
|> to_string
let article_link entry =
let open Logarion.Entry in
let u = "/note/" ^ slug entry in
li [a ~a:[a_href (uri_of_string u)]
[Unsafe.data (title entry ^ (Meta.Date.pretty_date (entry |> date |> Meta.Date.last))) ]
]
let article_link meta =
let open Logarion in
let u = "/note/" ^ Meta.slug meta in
let d =
let open Meta in
Unsafe.data Note.(meta.Meta.title ^ (Meta.Date.pretty_date (meta.date |> Meta.Date.last)))
in
li [ a ~a:[ a_href (uri_of_string u) ] [ d ] ]
let of_entries ?(header_tpl=None) ?(list_tpl=None) ?(item_tpl=None) blog_url lgrn =
let t = Logarion.Configuration.(lgrn.title) in
let of_entries ?(header_tpl=None) ?(list_tpl=None) ?(item_tpl=None) blog_url lgrn notes =
let title = Logarion.(lgrn.Configuration.title) in
logarion_page
~header_tpl
blog_url
t t
title
title
(match list_tpl with
| Some (Template.List s) -> Unsafe.data Template.(fold_list ~item_tpl lgrn s)
| None ->
let entries = Logarion.Archive.(of_repo lgrn.Logarion.Configuration.repository |> latest_listed) in
(div [ h2 [pcdata "Articles"]; ul (List.map article_link entries); ]))
| Some (Template.List s) -> Unsafe.data Template.(fold_list ~item_tpl notes s)
| None -> (div [ h2 [pcdata "Articles"]; ul (List.map article_link notes); ]))
|> to_string
let form ?(header_tpl=None) blog_url lgrn ymd =
@ -68,8 +69,8 @@ let form ?(header_tpl=None) blog_url lgrn ymd =
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
let auth_name = either auth.name Logarion.(lgrn.Configuration.owner) in
let auth_addr = either auth.email Logarion.(lgrn.Configuration.email) in
[
input ~a:[a_name "uuid"; a_value (Id.to_string ymd.meta.uuid); a_input_type `Hidden] ();
input_set
@ -83,16 +84,16 @@ let form ?(header_tpl=None) blog_url lgrn ymd =
(input ~a:[a_name "email"; a_value auth_addr; a_input_type `Email] ());
input_set
"Topics"
(input ~a:[a_name "topics"; a_value (String.concat ", " ymd.meta.topics)] ());
(input ~a:[a_name "topics"; a_value (stringset_csv ymd.meta.topics)] ());
input_set
"Categories"
(input ~a:[a_name "categories"; a_value (CategorySet.to_csv ymd.meta.categories)] ());
input_set
"Keywords"
(input ~a:[a_name "keywords"; a_value (String.concat ", " ymd.meta.keywords)] ());
(input ~a:[a_name "keywords"; a_value (stringset_csv ymd.meta.keywords)] ());
input_set
"Series"
(input ~a:[a_name "series"; a_value (String.concat ", " ymd.meta.series)] ());
(input ~a:[a_name "series"; a_value (stringset_csv ymd.meta.series)] ());
input_set
"Abstract"
(input ~a:[a_name "abstract"; a_value ymd.meta.abstract] ());
@ -116,6 +117,6 @@ let of_message ?(header_tpl=None) blog_url lgrn title message =
~header_tpl
blog_url
title
Logarion.Configuration.(lgrn.title)
Logarion.(lgrn.Configuration.title)
(div [pcdata message])
|> to_string

117
src/logarion.ml
View File

@ -1,8 +1,9 @@
module Id = Meta.Id
type slug_t = string
module Configuration = struct
type t = {
repository : Path.repo_t;
repository : Lpath.repo_t;
title : string;
owner : string;
email : string;
@ -10,7 +11,7 @@ module Configuration = struct
}
let default ?(id=(Id.generate ())) () = {
repository = Path.repo_of_string (Sys.getcwd ());
repository = Lpath.repo_of_string (Sys.getcwd ());
title = "Logarion journal";
owner = "";
email = "";
@ -18,15 +19,15 @@ module Configuration = struct
}
let of_toml_file path =
let result = Toml.Parser.from_filename (Path.string_of_config path) in
let result = Toml.Parser.from_filename (Lpath.string_of_config path) in
match result with
| `Error (str, loc) -> default ()
| `Ok toml ->
let str = Logarion_toml.str toml "general" in
let default = default () in
let default_repo = default.repository |> Path.string_of_repo in
let default_repo = default.repository |> Lpath.string_of_repo in
{
repository = Path.repo_of_string (str "repository" default_repo);
repository = Lpath.repo_of_string (str "repository" default_repo);
title = str "title" default.title;
owner = str "owner" default.owner;
email = str "email" default.email;
@ -34,88 +35,46 @@ module Configuration = struct
}
end
module Entry = struct
type t = { path : Path.note_t; attributes : Meta.t } [@@deriving lens { submodule = true }]
module SlugMap = Meta.SlugMap
open Meta
let title e = e.attributes.title
let date e = e.attributes.date
let date_edited e = (date e).Date.edited
let date_published e = (date e).Date.published
let author_name e = e.attributes.author.Author.name
let author_email e = e.attributes.author.Author.email
let published e = CategorySet.published e.attributes.categories
let listed e = CategorySet.listed e.attributes.categories
module Make (Store : Store.T) = struct
type t = {
config : Configuration.t;
store : Store.t;
}
let of_path (path : Path.note_t) =
let note = File.note path in
{ path; attributes = { note.Note.meta with title = Note.title note } }
let note_lens note = note
let meta_lens note = note.Note.meta
let slug entry = Path.slug_of_note entry.path
let recency_order a b = Meta.(Date.compare b.date a.date)
let compare_recency a b = Date.compare (date b) (date a)
end
let latest archive =
Store.to_list ~order:recency_order meta_lens archive.store
module Archive = struct
type t = Entry.t list
let listed archive =
let notes = Store.to_list meta_lens archive.store in
List.filter Meta.(fun e -> CategorySet.listed e.categories) notes
let latest = List.fast_sort Entry.compare_recency
let listed = List.filter Entry.listed
let published = List.filter Entry.published
let published archive =
let notes = Store.to_list meta_lens archive.store in
List.filter Meta.(fun e -> CategorySet.published e.categories) notes
let of_repo repo =
let files = File.notes_of_repo repo in
let to_entry basename = Entry.of_path Path.(note_of_basename repo basename) in
let fold_file a file =
if BatString.ends_with file Path.extension
then try List.cons (to_entry file) a with Note.Syntax_error str -> prerr_endline str; a
else a
in
List.fold_left fold_file [] files
let delta_of repo note =
let open Note in
let open Entry in
let open Meta in
let identical entry = entry.attributes.uuid = note.meta.uuid in
let next_basename title = Path.versioned_basename_of_title repo title in
let next entry = if title entry <> note.meta.title then next_basename note.meta.title else entry.path in
match List.find identical (of_repo repo) with
| entry -> Some entry.path, next entry
| exception Not_found -> None, Path.versioned_basename_of_title repo note.meta.title
let latest_listed archive =
let notes = Store.to_list ~order:recency_order meta_lens archive.store in
List.filter Meta.(fun e -> CategorySet.listed e.categories) notes
let topics archive =
let open List in
let rec unique_entry ts = function
| h :: t -> unique_entry (if not (exists (fun x -> x = h) ts) then cons h ts else ts) t
| [] -> ts
in
let unique_topics ts x = unique_entry ts x.Entry.attributes.Meta.topics in
fold_left unique_topics [] archive
let notes = Store.to_list meta_lens archive.store in
List.fold_left Meta.(fun a e -> unique_topics a e) Meta.StringSet.empty notes
let latest_entry archive fragment =
let notes = Store.to_list ~order:recency_order meta_lens archive.store in
try Some (List.find (fun e -> BatString.exists (e.Meta.title) fragment) notes)
with Not_found -> None
let note_with_id archive id = Store.note_with_id archive.store id
let note_with_alias archive alias = Store.note_with_alias archive.store alias
let with_note archive note = Store.with_note archive.store note
let latest_listed entries = entries |> listed |> latest
end
let latest_entry repo fragment =
let latest last_match entry =
let open Entry in
if not @@ BatString.exists (title entry) fragment then last_match
else
match last_match with
| Some last_entry ->
if date_published last_entry >= date_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 repo (slug as s) =
let open Entry in
try Some (of_path (Path.note_of_slug repo s))
with _ ->
let slugged last_match entry =
if s <> Path.basename_of_title (title entry) then last_match
else
match last_match with
| Some last_entry ->
if published last_entry >= published entry then last_match else Some entry
| None -> Some entry in
ListLabels.fold_left ~f:slugged ~init:(None) (Archive.of_repo repo)

17
src/path.ml → src/lpath.ml
View File

@ -36,27 +36,12 @@ let fpath_of_note = function Note n -> (fpath_of_repo n.repo // notes // n.basen
let string_of_note n = fpath_of_note n |> to_string
let note_of_basename repo s = Note { repo; basename = v s }
let basename_of_title t =
let is_reserved = function
| '!' | '*' | '\'' | '(' | ')' | ';' | ':' | '@' | '&' | '=' | '+' | '$'
| ',' | '/' | '?' | '#' | '[' | ']' | ' ' | '\t' | '\x00' -> true
| _ -> false in
let drop h t = t in
let dash h t = '-' :: t in
let rec filter fn = function
| [] -> []
| head :: tail ->
if is_reserved head
then fn head (filter drop tail)
else Char.lowercase_ascii head :: (filter dash tail) in
Batteries.String.of_list @@ filter drop (Batteries.String.to_list t)
let slug_of_note = function Note n -> n.basename |> rem_ext |> to_string
let note_of_slug repo slug = note_of_basename repo (slug ^ extension)
let versioned_basename_of_title ?(version=0) repo (title : string) =
let notes_fpath = fpath_of_repo repo // notes in
let basename = v @@ basename_of_title title in
let basename = v @@ Meta.string_slug title in
let rec next version =
let candidate = basename |> add_ext (string_of_int version) |> add_ext extension in
if Sys.file_exists (to_string (notes_fpath // candidate))

78
src/meta.ml
View File

@ -35,6 +35,7 @@ end
module Id = struct
type t = Uuidm.t
let compare = Uuidm.compare
let to_string = Uuidm.to_string
let of_string = Uuidm.of_string
let generate = Uuidm.v4_gen (Random.get_state ())
@ -79,16 +80,38 @@ module CategorySet = struct
let listed cs = not @@ categorised [Category.Unlisted] cs
end
module StringSet = Set.Make(String)
let stringset_csv set =
let f elt a = if a <> "" then a ^ ", " ^ elt else elt in
StringSet.fold f set ""
let string_slug t =
let is_reserved = function
| '!' | '*' | '\'' | '(' | ')' | ';' | ':' | '@' | '&' | '=' | '+' | '$'
| ',' | '/' | '?' | '#' | '[' | ']' | ' ' | '\t' | '\x00' -> true
| _ -> false in
let drop h t = t in
let dash h t = '-' :: t in
let rec filter fn = function
| [] -> []
| head :: tail ->
if is_reserved head
then fn head (filter drop tail)
else Char.lowercase_ascii head :: (filter dash tail) in
Batteries.String.of_list @@ filter drop (Batteries.String.to_list t)
type t = {
title: string;
author: Author.t;
date: Date.t;
categories: CategorySet.t;
topics: string list;
keywords: string list;
series: string list;
topics: StringSet.t;
keywords: StringSet.t;
series: StringSet.t;
abstract: string;
uuid: Id.t
uuid: Id.t;
slug: string;
} [@@deriving lens { submodule = true }]
let blank ?(uuid=(Id.generate ())) () = {
@ -96,13 +119,23 @@ let blank ?(uuid=(Id.generate ())) () = {
author = Author.({ name = ""; email = "" });
date = Date.({ created = None; edited = None; published = None });
categories = CategorySet.empty;
topics = [];
keywords = [];
series = [];
topics = StringSet.empty;
keywords = StringSet.empty;
series = StringSet.empty;
abstract = "";
uuid;
slug = "";
}
let listed e = CategorySet.listed e.categories
let published e = CategorySet.published e.categories
let unique_topics ts x = StringSet.union ts x.topics
module SlugMap = Map.Make(String)
module IdMap = Map.Make(Id)
let slug meta = if meta.slug = "" then string_slug meta.title else meta.slug
let value_with_name (meta as m) = function
| "title" -> m.title
| "abstract" -> m.abstract
@ -113,18 +146,20 @@ let value_with_name (meta as m) = function
| "date_edited" -> Date.(rfc_string m.date.edited)
| "date_published"-> Date.(rfc_string m.date.published)
| "date_human" -> Date.(pretty_date @@ last m.date)
| "topics" -> String.concat ", " m.topics;
| "topics" -> stringset_csv m.topics;
| "categories" -> CategorySet.to_csv m.categories;
| "keywords" -> String.concat ", " m.keywords;
| "series" -> String.concat ", " m.series;
| "keywords" -> stringset_csv m.keywords;
| "series" -> stringset_csv m.series;
| "uuid" -> Id.to_string m.uuid
| "slug" -> slug m
| e -> invalid_arg e
let with_kv meta (k,v) =
let list_of_csv = Re_str.(split (regexp " *, *")) in
let open Infix in
let of_str y k v = (k ^= String.trim v) y in
let of_str_list y k v = (k ^= list_of_csv (String.trim v)) y in
let trim = String.trim in
let of_str y k v = (k ^= trim v) y in
let of_str_list y k v = (k ^= list_of_csv (trim v)) y in
let open Lens in
match k with
| "title" -> of_str meta title v
@ -135,15 +170,15 @@ let with_kv meta (k,v) =
| "date" -> ((date |-- Date.Lens.created) ^= Date.of_string v) meta
| "published" -> ((date |-- Date.Lens.published) ^= Date.of_string v) meta
| "edited" -> ((date |-- Date.Lens.edited ) ^= Date.of_string v) meta
| "topics" -> of_str_list meta topics v
| "keywords" -> of_str_list meta keywords v
| "topics" -> { meta with topics = (trim v |> list_of_csv |> StringSet.of_list) }
| "keywords" -> { meta with keywords = trim v |> list_of_csv |> StringSet.of_list }
| "categories"->
let list = String.trim v |> list_of_csv in
let list = List.map Category.of_string list in
(categories ^= CategorySet.of_list list) meta
| "series" -> of_str_list meta series v
let categories = trim v |> list_of_csv |> List.map Category.of_string |> CategorySet.of_list in
{ meta with categories }
| "series" -> { meta with series = trim v |> list_of_csv |> StringSet.of_list }
| "uuid" ->
(match Id.of_string v with Some id -> (uuid ^= id) meta | None -> meta)
| "slug" -> { meta with slug = v }
| _ -> meta
let to_string (meta as m) =
@ -167,12 +202,13 @@ let to_string (meta as m) =
d "date" m.date.Date.created;
d "edited" m.date.Date.edited;
d "published" m.date.Date.published;
ss "topics" m.topics;
s "topics" (stringset_csv m.topics);
s "categories" (CategorySet.to_csv m.categories);
ss "keywords" m.keywords;
ss "series" m.series;
s "keywords" (stringset_csv m.keywords);
s "series" (stringset_csv m.series);
s "abstract" m.abstract;
s "uuid" (Uuidm.to_string m.uuid);
s "slug" m.slug
]
in
String.concat "" rows

8
src/note.ml
View File

@ -39,9 +39,11 @@ let of_string s =
let (front_matter, body) =
if BatString.starts_with s "---"
then let l = Re_str.(bounded_split (regexp "^---$")) s 2 in List.(nth l 0, nth l 1)
else BatString.split s "\n\n"
else BatString.split s "\n\n" (* scan line for colon to determine front matter *)
in
try { meta = meta_of_string front_matter; body }
with _ -> prerr_endline ("Failed paring" ^ s); blank ()
try
let note = { meta = meta_of_string front_matter; body } in
{ note with meta = { note.meta with title = title note } }
with _ -> prerr_endline ("Failed parsing" ^ s); blank ()
let to_string ymd = Meta.to_string ymd.meta ^ "\n" ^ ymd.body

7
src/store.ml Normal file
View File

@ -0,0 +1,7 @@
module type T = sig
type t
val to_list: ?order:('a -> 'a -> int) -> (Note.t -> 'a) -> t -> 'a list
val note_with_id: t -> Meta.Id.t -> Note.t option
val note_with_alias: t -> string -> Note.t option
val with_note: t -> Note.t -> Note.t Lwt.t
end

40
src/template.ml
View File

@ -69,13 +69,13 @@ let fold_note ymd =
| tag -> Meta.value_with_name ymd.Note.meta tag in
Mustache.fold ~string ~section ~escaped ~unescaped ~partial ~comment ~concat
let fold_entry (entry : Logarion.Entry.t) =
let open Logarion.Entry in
let fold_meta (meta : Meta.t) =
let open Logarion in
let escaped e = match e with
| "url" -> "/note/" ^ slug entry
| "url" -> "/note/" ^ Meta.slug meta
| "date" | "date_created" | "date_edited" | "date_published" | "date_human" ->
"<time>" ^ Meta.value_with_name entry.attributes e ^ "</time>"
| tag -> Meta.value_with_name entry.attributes tag in
"<time>" ^ Meta.value_with_name meta e ^ "</time>"
| tag -> Meta.value_with_name meta tag in
Mustache.fold ~string ~section ~escaped ~unescaped ~partial ~comment ~concat
let fold_header blog_url title =
@ -85,21 +85,25 @@ let fold_header blog_url title =
| _ -> prerr_endline ("unknown tag: " ^ e); "" in
Mustache.fold ~string ~section ~escaped ~unescaped ~partial ~comment ~concat
let fold_list ?(item_tpl=None) lgrn =
let open Logarion.Entry in
let simple entry =
"<li><a href=\"/note/" ^ slug entry ^ "\">"
^ entry.attributes.Meta.title ^ " ~ " ^ Meta.Date.(pretty_date (entry |> date |> last)) ^ "</a></li>" in
let fold_entry tpl entry = fold_entry entry tpl in
let entry = match item_tpl with Some (Item e) -> fold_entry e | None -> simple in
let fold_list ?(item_tpl=None) notes =
let simple meta =
"<li><a href=\"/note/" ^ Meta.slug meta ^ "\">"
^ meta.Meta.title ^ " ~ " ^ Meta.Date.(pretty_date (last meta.Meta.date))
^ "</a></li>"
in
let fold_meta tpl meta = fold_meta meta tpl in
let meta = match item_tpl with Some (Item e) -> fold_meta e | None -> simple in
let escaped e = match e with
| "recent_texts_listing" ->
let entries = Logarion.Archive.(of_repo lgrn.Logarion.Configuration.repository |> latest_listed) in
(ListLabels.fold_left ~init:("<ul>") ~f:(fun a e -> a ^ (entry e)) entries)
^ "</ul>"
| "topics" ->
let entries = Logarion.(Archive.of_repo lgrn.Configuration.repository |> Archive.listed |> Archive.topics) in
(ListLabels.fold_left ~init:("<ul>") ~f:(fun a e -> a ^ "<li>" ^ e ^ "</li>") entries)
let open Logarion in
ListLabels.fold_left ~init:"<ul>" ~f:(fun a e -> a ^ meta e) notes
^ "</ul>"
| "topics" -> ""
(* let topics =
let open Logarion in
listed lgrn |> topics |> Meta.StringSet.elements
in
ListLabels.fold_left ~init:"<ul>" ~f:(fun a e -> a ^ "<li>" ^ e ^ "</li>") topics
^ "</ul>"*)
| _ -> prerr_endline ("unknown tag: " ^ e); "" in
Mustache.fold ~string ~section ~escaped ~unescaped ~partial ~comment ~concat

63
src/web.ml
View File

@ -18,7 +18,7 @@ module Configuration = struct
}
let of_toml_file fn =
let result = Toml.Parser.from_filename (Path.string_of_config fn) in
let result = Toml.Parser.from_filename (Lpath.string_of_config fn) in
match result with
| `Error (str, loc) -> default
| `Ok toml ->
@ -48,11 +48,17 @@ let () =
let module L = Logarion in
Random.self_init();
let wcfg = try Configuration.of_toml_file (Path.from_config_paths "web.toml") with Not_found -> Configuration.default in
let lgrn =
let wcfg =
try Configuration.of_toml_file (Lpath.from_config_paths "web.toml")
with Not_found -> Configuration.default in
let config =
let open L.Configuration in
try of_toml_file (Path.from_config_paths "logarion.toml") with Not_found -> default ()
try of_toml_file (Lpath.from_config_paths "logarion.toml")
with Not_found -> default ()
in
let module L = Logarion.Make(File) in
let store = File.store config.repository in
let lgrn = L.{ config; store; } in
let header_tpl = Template.header wcfg.Configuration.template in
let list_tpl = Template.list wcfg.Configuration.template in
@ -60,41 +66,52 @@ let () =
let note_tpl = Template.note wcfg.Configuration.template in
let blog_url = Configuration.(wcfg.url) in
let page_of_msg = Html.of_message ~header_tpl blog_url lgrn in
let page_of_note = Html.of_note ~header_tpl ~note_tpl blog_url lgrn in
let form_of_note = Html.form ~header_tpl blog_url lgrn in
let list_of_notes = Html.of_entries ~header_tpl ~list_tpl ~item_tpl blog_url lgrn in
let page_of_msg = Html.of_message ~header_tpl blog_url config in
let page_of_note = Html.of_note ~header_tpl ~note_tpl blog_url config in
let form_of_note = Html.form ~header_tpl blog_url config in
let list_of_notes = Html.of_entries ~header_tpl ~list_tpl ~item_tpl blog_url config in
let lwt_archive repo = Lwt.return L.Archive.(of_repo repo) in
let lwt_blanknote () = Lwt.return (Note.blank ()) in
let (>>=) = Lwt.(>>=) and (>|=) = Lwt.(>|=) in
let atom_response repo req =
lwt_archive repo >|= L.Archive.latest_listed
>|= Atom.feed repo wcfg.Configuration.url lgrn >>= html_response in
let post_note repo req = note_of_req req >>= (fun note -> L.Archive.delta_of repo note |> File.Lwt.with_note note) >|= page_of_note >>= html_response in
let some_note converter par_name repo find_note req =
param req par_name |> Lwt.return >|= find_note repo >>=
(function Some entry -> File.note entry.L.Entry.path |> Lwt.return >|= converter
Lwt.return (L.latest_listed repo)
>|= Atom.feed config wcfg.Configuration.url (L.note_with_id lgrn)
>>= html_response
in
let post_note lgrn req =
note_of_req req
>>= L.with_note lgrn
>|= page_of_note
>>= html_response
in
let some_note converter par_name lgrn find_note req =
param req par_name
|> Lwt.return
>|= find_note
>>= (function
| Some note -> Lwt.return note >|= converter
| None -> Lwt.return @@ page_of_msg "Not found" "Article not found")
>>= html_response
in
let edit_note = some_note form_of_note in
let view_note = some_note page_of_note in
let repo = lgrn.L.Configuration.repository in
App.empty
|> App.port wcfg.Configuration.port
|> middleware @@
Middleware.static
~local_path:(Fpath.to_string wcfg.Configuration.static)
~uri_prefix:"/static"
|> get "/:ttl" @@ view_note "ttl" repo L.entry_with_slug
|> post "/post.note" @@ post_note repo
|> get "/edit.note/:ttl" @@ edit_note "ttl" repo L.entry_with_slug
|> get "/:ttl" @@ view_note "ttl" lgrn (L.note_with_alias lgrn)
|> post "/post.note" @@ post_note lgrn
|> get "/edit.note/:ttl" @@ edit_note "ttl" lgrn (L.note_with_alias lgrn)
|> get "/new.note" (fun _ -> lwt_blanknote () >|= form_of_note >>= html_response)
|> get "/note/:ttl" @@ view_note "ttl" repo L.entry_with_slug
|> get "/!/:ttl" @@ view_note "ttl" repo L.latest_entry
|> get "/feed.atom" @@ atom_response repo
|> get "/" (fun _ -> Lwt.return list_of_notes >>= html_response)
|> get "/note/:ttl" @@ view_note "ttl" lgrn (L.note_with_alias lgrn)
|> get "/!/:ttl" @@ view_note "ttl" lgrn (fun t -> match L.latest_entry lgrn t with
| Some meta -> L.note_with_id lgrn meta.Meta.uuid
| None -> None)
|> get "/feed.atom" @@ atom_response lgrn
|> get "/" (fun _ -> Lwt.return (L.latest_listed lgrn) >|= list_of_notes >>= html_response)
|> App.run_command