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

Refactors Logarion module; Path types, File functions, adding notes

Browse Source 
Reinvented Path types, now in a new module Path.
Moves file functions to module File, including Lwt implementations.
Experimental Logarion.Archive.delta_of for compounding (adding) notes.
Fixes scope warnings.
Fixes a command's documentation.
This commit is contained in:
Stavros Polymenis 2017-04-17 16:45:44 +01:00
parent ef25c2f366
commit a6595499a7
8 changed files with 118 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/atom.ml
View File

@ -16,11 +16,11 @@ let opt_element tag_name content body =
let entry repo url logarion note =
let open Logarion in
let file = Entry.to_note repo note in
let file = File.note note.Entry.path in
let open Meta in
let open Author in
let u = "note/" ^ Entry.slug note in
let meta = file.meta in
let meta = file.Note.meta in
("<entry>"
^ "<title>" ^ meta.title ^ "</title>"
^ "<id>urn:uuid:" ^ Meta.Id.to_string meta.uuid ^ "</id>"
@ -32,7 +32,7 @@ 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.body)
^ (Omd.to_html @@ Omd.of_string @@ esc file.Note.body)
^ "</div></content>"
^ "</entry>"

9
src/command.ml
View File

@ -5,7 +5,7 @@ let init =
let f force =
let repo =
C.((try of_filename "logarion.toml" with Sys_error _ -> default ()).repository)
|> Logarion.repo_path |> Fpath.to_string
|> Path.string_of_repo
in
let make_dir d =
let open Unix in
@ -27,14 +27,13 @@ let init =
let create =
let title =
Arg.(value & pos 0 string "" & info [] ~docv:"TITLE" ~doc:"(Optional) title for new article")
Arg.(value & pos 0 string "" & info [] ~docv:"TITLE" ~doc:"Title for new article")
in
let f title =
let repo = C.((of_filename "logarion.toml").repository) in
let t = match title with "" -> "Draft" | _ -> title in
Logarion.Archive.add repo Note.({ (blank ()) with meta = { (Meta.blank ()) with Meta.title = t }})
|> Lwt_main.run;
()
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)
in
Term.(const f $ title),
Term.info "create"

34
src/file.ml
View File

@ -1,4 +1,30 @@
let of_filename f =
let open Lwt in
Lwt_io.(open_file ~mode:(Input) f >|= read_lines)
>|= (fun stream -> Lwt_stream.fold (^) stream "")
let load f =
let ic = open_in (Fpath.to_string 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)
let note path = Path.fpath_of_note path |> load |> Note.of_string
let notes_of_repo repo =
Path.(notes_of_repo repo |> string_of_notes)
|> Sys.readdir
|> Array.to_list
module Lwt = struct
let of_filename f =
let open Lwt in
Lwt_io.(open_file ~mode:(Input) f >|= read_lines)
>|= (fun stream -> Lwt_stream.fold (^) stream "")
let with_note note (previous, filepath) =
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;
end

8
src/html.ml
View File

@ -20,11 +20,13 @@ let logarion_text ?(text_tpl=None) ymd =
match text_tpl with
| Some (Template.Text s) -> Unsafe.data Template.(fold_text ymd s)
| None ->
let ymd_body = Omd.to_html (Omd.of_string ymd.Note.body) in
let open Note in
let open Meta in
let ymd_body = Omd.to_html (Omd.of_string ymd.body) in
article [
details
(summary [Unsafe.data ymd.Note.meta.Meta.abstract])
[time ~a:[a_datetime Meta.(Date.(pretty_date @@ last ymd.meta.Meta.date))] []];
(summary [Unsafe.data ymd.meta.abstract])
[time ~a:[a_datetime Date.(pretty_date @@ last ymd.meta.date)] []];
Unsafe.data ymd_body;
]

129
src/logarion.ml
View File

@ -1,18 +1,8 @@
module Id = Meta.Id
type repo_t = Repodir of Fpath.t
type uuid_t = UUIDdir of Fpath.t
type titles_t = Titles of Fpath.t
type article_t = Article of Fpath.t
let repo_path = function Repodir path -> path
let uuiddir_path = function UUIDdir path -> path
let titledir_path = function Titles path -> path
let articlefilename_path = function Article path -> path
module Configuration = struct
type t = {
repository : repo_t;
repository : Path.repo_t;
title : string;
owner : string;
email : string;
@ -20,7 +10,7 @@ module Configuration = struct
}
let default ?(id=(Id.generate ())) () = {
repository = Repodir Fpath.(v (Sys.getcwd ()));
repository = Path.repo_of_string (Sys.getcwd ());
title = "Logarion journal";
owner = "";
email = "";
@ -34,9 +24,9 @@ module Configuration = struct
| `Ok toml ->
let str = Logarion_toml.str toml "general" in
let default = default () in
let default_repo = default.repository |> repo_path |> Fpath.to_string in
let default_repo = default.repository |> Path.string_of_repo in
{
repository = Repodir (str "repository" default_repo |> Fpath.v);
repository = Path.repo_of_string (str "repository" default_repo);
title = str "title" default.title;
owner = str "owner" default.owner;
email = str "email" default.email;
@ -44,51 +34,8 @@ module Configuration = struct
}
end
module File = struct
let load f =
let ic = open_in (Fpath.to_string 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)
let note f = Note.of_string (load f)
let name_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 name note = name_of_title note.Note.meta.Meta.title
end
let titledir (dir : repo_t) = Titles Fpath.(repo_path dir / "title")
let uuiddir (dir : repo_t) = UUIDdir Fpath.(repo_path dir / "uuid")
let extension = ".ymd"
let article_path (repo : repo_t) articlepath =
Article Fpath.(repo_path repo / "title" // articlefilename_path articlepath)
let title_path (repo : repo_t) title =
Article Fpath.(repo_path repo / "title" / (File.name_of_title title ^ extension))
let uuid_path (repo : repo_t) note =
Article Fpath.(repo_path repo / "uuid" / (Meta.Id.to_string note.Note.meta.Meta.uuid ^ extension))
let slug string = Filename.(string |> basename |> chop_extension)
module Entry = struct
type t = { filename : article_t; attributes : Meta.t } [@@deriving lens { submodule = true }]
type t = { path : Path.note_t; attributes : Meta.t } [@@deriving lens { submodule = true }]
open Meta
let title e = e.attributes.title
@ -100,33 +47,15 @@ module Entry = struct
let published e = CategorySet.published e.attributes.categories
let listed e = CategorySet.listed e.attributes.categories
let of_filename repo (filename : article_t) =
let note = File.note (articlefilename_path (article_path repo filename)) in
let attributes = { note.Note.meta with title = Note.title note } in
{ filename; attributes }
let of_path (path : Path.note_t) =
let note = File.note path in
{ path; attributes = { note.Note.meta with title = Note.title note } }
let to_filename repo note =
let uuid_path = Fpath.to_string @@ articlefilename_path @@ uuid_path repo note in
let write_note out = Lwt_io.write out (Note.to_string note) in
Lwt_io.with_file ~mode:Lwt_io.output uuid_path write_note
let to_note repo entry = File.note (articlefilename_path (article_path repo entry.filename))
let slug entry =
Fpath.(entry.filename |> articlefilename_path |> base |> rem_ext |> to_string)
let slug entry = Path.slug_of_note entry.path
let compare_recency a b = Date.compare (date b) (date a)
end
let rec next_semantic_filepath ?(version=0) titles note =
let candidate =
let open Fpath in
titledir_path titles / (File.name note)
|> add_ext (string_of_int version)
|> add_ext extension in
if Sys.file_exists Fpath.(to_string candidate) then next_semantic_filepath ~version:(version+1) titles note
else candidate
module Archive = struct
type t = Entry.t list
@ -135,37 +64,25 @@ module Archive = struct
let published = List.filter Entry.published
let of_repo repo =
let files = Array.to_list @@ Sys.readdir Fpath.(to_string @@ titledir_path (titledir repo)) in
let to_entry y = Entry.of_filename repo (Article (Fpath.v y)) in
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 extension
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 add repo note =
let open Entry in
let open Lwt.Infix in
to_filename repo note >>= fun () ->
let delta_of repo note =
let open Note in
(if not (categorised [Meta.Category.Draft] note) && note.Note.meta.Meta.title <> "" then
let entries = of_repo repo in
let titledir = titledir repo in
begin try
let uuid x = x.Meta.uuid in
let entry = List.find (fun entry -> uuid entry.attributes = uuid note.meta) entries in
if slug entry <> File.name note then
let found_filepath = Fpath.to_string @@ articlefilename_path (article_path repo entry.filename) in
Lwt_unix.rename found_filepath (Fpath.to_string @@ next_semantic_filepath titledir note)
else
Lwt.return_unit
with Not_found ->
Lwt_unix.link (Fpath.to_string @@ articlefilename_path (uuid_path repo note)) (Fpath.to_string @@ next_semantic_filepath titledir note);
end
else
Lwt.return_unit)
>>= fun () -> Lwt.return note
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 topics archive =
let open List in
@ -192,10 +109,10 @@ let latest_entry repo fragment =
let entry_with_slug repo (slug as s) =
let open Entry in
try Some (of_filename repo (Article (Fpath.v @@ s ^ extension)))
try Some (of_path (Path.note_of_slug repo s))
with _ ->
let slugged last_match entry =
if s <> File.name_of_title (title entry) then last_match
if s <> Path.basename_of_title (title entry) then last_match
else
match last_match with
| Some last_entry ->

48
src/path.ml Normal file
View File

@ -0,0 +1,48 @@
open Fpath
type repo_t = Repo of t
type note_t = Note of { repo: repo_t; basename: t }
type notes_t = Notes of t
let extension = ".ymd"
let notes = v "notes"
let fpath_of_repo = function Repo p -> p
let string_of_repo r = fpath_of_repo r |> to_string
let repo_of_string s = Repo (v s)
let fpath_of_notes = function Notes ns -> ns
let string_of_notes ns = fpath_of_notes ns |> to_string
let notes_of_repo r = Notes (fpath_of_repo r // notes)
let fpath_of_note = function Note n -> (fpath_of_repo n.repo // notes // n.basename)
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 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))
then next (succ version)
else note_of_basename repo (to_string candidate)
in
next version

2
src/template.ml
View File

@ -8,7 +8,7 @@ type text = Text of t
type index = Index of t
let of_string = Mustache.of_string
let of_file f = Logarion.File.load f |> of_string
let of_file f = File.load f |> of_string
let header f = Header (of_file f)
let listing f = Listing (of_file f)

7
src/web.ml
View File

@ -93,12 +93,13 @@ let () =
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 >>= L.Archive.add repo >|= page_of_note >>= 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 selector req =
let selector x = try selector repo x with Sys_error _ -> None in
param req par_name |> Lwt.return >|= selector >>=
(function Some entry -> (try L.Entry.to_note repo entry |> Lwt.return >|= converter
with Sys_error _ -> Lwt.return @@ page_of_msg "Failed" "Conversion failure")
(function Some entry ->
(try File.note entry.L.Entry.path |> Lwt.return >|= converter
with Sys_error _ -> Lwt.return @@ page_of_msg "Failed" "Conversion failure")
| None -> Lwt.return @@ page_of_msg "Not found" "Article not found")
>>= html_response
in