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

implemented file path types and refactored some functions

Browse Source
This commit is contained in:
Stavros Polymenis 2017-01-15 00:55:11 +00:00
parent bf1703bebe
commit 20780c2d76
5 changed files with 69 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/command.ml
View File

@ -12,9 +12,9 @@ let create =
If `title` is not provided, 'Draft' is used."]
in
let create_f title =
let cfg = Logarion.Configuration.of_filename "logarion.toml" in
let repo = Logarion.Configuration.((of_filename "logarion.toml").repository) in
let t = match title with "" -> "Draft" | _ -> title in
Logarion.Entry.to_file cfg Ymd.({ (blank ()) with meta = { (Meta.blank ()) with Meta.title = t }})
Logarion.Entry.to_filename repo Ymd.({ (blank ()) with meta = { (Meta.blank ()) with Meta.title = t }})
|> Lwt_main.run
in
Term.(const create_f $ title),

2
src/html.ml
View File

@ -40,7 +40,7 @@ let of_ymd ?(header_tpl=None) ?(text_tpl=None) blog_url lgrn ymd =
let article_link entry =
let open Logarion.Entry in
let u = "/text/" ^ Filename.(entry.filepath |> basename |> chop_extension) in
let u = "/text/" ^ slug entry in
li [a ~a:[a_href (uri_of_string u)]
[Unsafe.data (title entry ^ (Ymd.Date.pretty_date (entry |> date |> Ymd.Date.last))) ]
]

93
src/logarion.ml
View File

@ -2,9 +2,19 @@ module Id = struct
include Ymd.Id
end
type repodir_t = Repodir of string
type uuiddir_t = UUIDdir of string
type titledir_t = Titledir of string
type articlefilename_t = Articlefilename of string
let repodir_string = function Repodir path -> path
let uuiddir_string = function UUIDdir path -> path
let titledir_string = function Titledir path -> path
let articlefilename_string = function Articlefilename path -> path
module Configuration = struct
type t = {
repository : string;
repository : repodir_t;
title : string;
owner : string;
email : string;
@ -12,7 +22,7 @@ module Configuration = struct
}
let default ?(id=(Id.generate ())) () = {
repository = Sys.getenv "HOME" ^ "/ymd";
repository = Repodir (Sys.getenv "HOME" ^ "/ymd");
title = "Logarion journal";
owner = "";
email = "";
@ -27,7 +37,7 @@ module Configuration = struct
let str = Logarion_toml.str toml "general" in
let default = default () in
{
repository = str "repository" default.repository;
repository = Repodir (str "repository" (repodir_string default.repository));
title = str "title" default.title;
owner = str "owner" default.owner;
email = str "email" default.email;
@ -47,37 +57,50 @@ module File = struct
let ymd f = Ymd.of_string (load f)
end
let titledir ymddir = ymddir ^ "/title/"
let uuiddir ymddir = ymddir ^ "/uuid/"
let titledir (dir : repodir_t) = Titledir (repodir_string dir ^ "/title/")
let uuiddir (dir : repodir_t) = UUIDdir (repodir_string dir ^ "/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.Meta.uuid) ^ extension
let article_path (repo : repodir_t) articlepath =
let titledir = titledir_string (titledir repo) in
Articlefilename (titledir ^ articlefilename_string articlepath)
let title_path (repo : repodir_t) title =
let titledir = titledir_string (titledir repo) in
Articlefilename (titledir ^ Ymd.filename_of_title title ^ extension)
let uuid_path (repo : repodir_t) ymd =
let uuiddir = uuiddir_string (uuiddir repo) in
Articlefilename (uuiddir ^ Ymd.(Id.to_string ymd.meta.Meta.uuid) ^ extension)
let slug string = Filename.(string |> basename |> chop_extension)
module Entry = struct
open Ymd.Meta
type t = { filepath : string; attributes : Ymd.Meta.t } [@@deriving lens]
type t = { filename : articlefilename_t; 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 ymd = File.ymd s in
{ filepath = s; attributes = ymd.Ymd.meta }
let of_filename repo (s : articlefilename_t) =
let ymd = File.ymd (articlefilename_string (article_path repo s)) in
{ filename = s; attributes = ymd.Ymd.meta }
let to_file config ymd =
let repo = Configuration.(config.repository) in
let uuid_path = uuid_path repo ymd in
let to_filename repo ymd =
let uuid_path = articlefilename_string @@ 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 to_ymd entry = File.ymd entry.filepath
let to_ymd repo entry = File.ymd (articlefilename_string (article_path repo entry.filename))
let slug entry =
Filename.(entry.filename |> articlefilename_string |> basename |> chop_extension)
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
let candidate = titledir_string 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
@ -88,8 +111,8 @@ module Archive = struct
let listed = List.filter Ymd.(fun a -> not @@ CategorySet.categorised [Category.Unlisted] (a.Entry.attributes.Meta.categories))
let of_repo repo =
let files = Array.to_list @@ Sys.readdir (titledir repo) in
let to_entry y = Entry.of_file (titledir repo ^ y) in
let files = Array.to_list @@ Sys.readdir (titledir_string (titledir repo)) in
let to_entry y = Entry.of_filename repo (Articlefilename y) in
let fold_file a file =
if BatString.ends_with file extension
then try List.cons (to_entry file) a with
@ -98,23 +121,22 @@ module Archive = struct
in
List.fold_left fold_file [] files
let add config ymd =
let add repo ymd =
let open Lwt.Infix in
Entry.to_file config ymd >>= fun () ->
Entry.to_filename repo 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
let entries = of_repo repo in
let titledir = titledir repo in
begin try
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);
let entry = List.find (fun entry -> uuid entry.Entry.attributes = uuid ymd.meta) entries in
if Entry.slug entry <> filename ymd then
let found_filepath = articlefilename_string (article_path repo entry.Entry.filename) in
Lwt_unix.rename found_filepath (next_semantic_filepath titledir ymd);
else Lwt.return ()
with Not_found ->
Lwt_unix.link (uuid_path archive_path ymd) (next_semantic_filepath dir ymd);
Lwt_unix.link (articlefilename_string (uuid_path repo ymd)) (next_semantic_filepath titledir ymd);
end
else
Lwt.return ()
@ -132,8 +154,7 @@ module Archive = struct
let latest_listed entries = entries |> listed |> latest
end
let latest_entry config fragment =
let repo = Configuration.(config.repository) in
let latest_entry repo fragment =
let latest last_match entry =
let open Entry in
if not @@ BatString.exists (title entry) fragment then last_match
@ -144,11 +165,10 @@ let latest_entry config fragment =
| 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 entry_with_slug repo (slug as s) =
let split_slug = BatString.split_on_char '.' slug in
let open Entry in
if List.length split_slug > 2 then Some (of_file slug)
if List.length split_slug > 2 then Some (of_filename repo (Articlefilename s))
else
let slug = List.hd split_slug in
let slugged last_match entry =
@ -158,4 +178,5 @@ let entry_with_slug config slug =
| 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) repo
let entries = Archive.of_repo repo in
ListLabels.fold_left ~f:slugged ~init:(None) entries

4
src/template.ml
View File

@ -50,7 +50,7 @@ let fold_entry (entry : Logarion.Entry.t) =
let open Ymd in
let open Ymd.Meta in
let escaped e = match e with
| "url" -> "/text/" ^ Filename.(entry.filepath |> basename |> chop_extension)
| "url" -> "/text/" ^ slug entry
| "title" -> meta.title
| "abstract" -> meta.abstract
| "author_name" -> meta.author.Author.name
@ -78,7 +78,7 @@ let fold_index ?(entry_tpl=None) lgrn =
let open Ymd in
let open Logarion.Entry in
let simple entry =
"<li><a href=\"/text/" ^ Filename.(entry.filepath |> basename |> chop_extension) ^ "\">"
"<li><a href=\"/text/" ^ slug entry ^ "\">"
^ entry.attributes.Meta.title ^ " ~ " ^ Date.(pretty_date (entry |> date |> last)) ^ "</a></li>" 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

14
src/web.ml
View File

@ -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 = ""; attributes = Ymd.Meta.blank () })
let unpublished_entry = Logarion.(Entry.({ filename = Articlefilename ""; attributes = Ymd.Meta.blank () }))
let entry_option y = match y with Some entry -> entry | None -> unpublished_entry
let webcfg = Configuration.of_filename "web.toml"
@ -77,7 +77,7 @@ let () =
let module L = Logarion in
let ymd f =
try
L.Entry.of_file f
L.Entry.of_filename lgrn.L.Configuration.repository f
|> (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
@ -97,11 +97,11 @@ let () =
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.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)
|> post "/post" (fun req -> ymd_of_req req >>= fun ymd -> L.Archive.add repo ymd >>= fun () -> html_response (page_of_ymd ymd))
|> get "/edit/:ttl" (fun r -> ret_param "ttl" r >>= ymdpath >|= ymd >|= L.Entry.to_ymd repo >|= 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 repo) >|= L.Archive.latest_listed >|= List.map L.Entry.to_ymd >|= Atom.feed webcfg.Configuration.url lgrn >>= html_response)
|> get "/text/:ttl" (fun req -> ret_param "ttl" req >|= L.entry_with_slug repo >|= entry_option >|= L.Entry.to_ymd repo >|= page_of_ymd >>= html_response)
|> get "/!/:ttl" (fun req -> ret_param "ttl" req >|= L.latest_entry repo >|= entry_option >|= L.Entry.to_ymd repo >|= page_of_ymd >>= html_response)
|> get "/feed.atom" (fun _ -> Lwt.return L.Archive.(of_repo repo) >|= L.Archive.latest_listed >|= List.map (L.Entry.to_ymd repo) >|= Atom.feed webcfg.Configuration.url lgrn >>= html_response)
|> get "/" (fun _ -> Lwt.return list_of_ymds >>= html_response)
|> App.run_command