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

implementation with fpath, wip

Browse Source
This commit is contained in:
Stavros Polymenis 2017-02-04 13:56:41 +00:00
parent 117d46456f
commit 54f2190d8e
3 changed files with 35 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
_oasis
View File

@ -14,12 +14,12 @@ Library "logarion"
Path: src
Modules: Logarion
BuildDepends:
toml,uuidm,omd,str,batteries,lens,lwt,lwt.unix,ptime,ptime.clock.os,re.str,lens.ppx_deriving
toml,uuidm,omd,str,batteries,lens,lwt,lwt.unix,ptime,ptime.clock.os,re.str,lens.ppx_deriving,fpath
Executable logarion
Path: src
BuildDepends:
toml,uuidm,omd,str,batteries,lens,lwt,lwt.unix,ptime,ptime.clock.os,re.str,lens.ppx_deriving,
toml,uuidm,omd,str,batteries,lens,lwt,lwt.unix,ptime,ptime.clock.os,re.str,lens.ppx_deriving,fpath,
cmdliner
MainIs: command.ml
CompiledObject: best
@ -27,7 +27,7 @@ Executable logarion
Executable logarion-web
Path: src
BuildDepends:
toml,uuidm,omd,str,batteries,lens,lwt,lwt.unix,ptime,ptime.clock.os,re.str,lens.ppx_deriving,
toml,uuidm,omd,str,batteries,lens,lwt,lwt.unix,ptime,ptime.clock.os,re.str,lens.ppx_deriving,fpath,
opium.unix,tyxml,mustache
MainIs: web.ml
CompiledObject: best

2
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.repodir_string
|> Logarion.repodir_path |> Fpath.to_string
in
let make_dir d =
let open Unix in

64
src/logarion.ml
View File

@ -2,15 +2,15 @@ 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
type repodir_t = Repodir of Fpath.t
type uuiddir_t = UUIDdir of Fpath.t
type titledir_t = Titledir of Fpath.t
type articlefilename_t = Articlefilename of Fpath.t
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
let repodir_path = function Repodir path -> path
let uuiddir_path = function UUIDdir path -> path
let titledir_path = function Titledir path -> path
let articlefilename_path = function Articlefilename path -> path
module Configuration = struct
type t = {
@ -22,7 +22,7 @@ module Configuration = struct
}
let default ?(id=(Id.generate ())) () = {
repository = Repodir (Sys.getcwd ());
repository = Repodir Fpath.(v (Sys.getcwd ()));
title = "Logarion journal";
owner = "";
email = "";
@ -36,8 +36,9 @@ module Configuration = struct
| `Ok toml ->
let str = Logarion_toml.str toml "general" in
let default = default () in
let default_repo = default.repository |> repodir_path |> Fpath.to_string in
{
repository = Repodir (str "repository" (repodir_string default.repository));
repository = Repodir (str "repository" default_repo |> Fpath.v);
title = str "title" default.title;
owner = str "owner" default.owner;
email = str "email" default.email;
@ -47,7 +48,7 @@ end
module File = struct
let load f =
let ic = open_in f in
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;
@ -57,22 +58,17 @@ module File = struct
let ymd f = Ymd.of_string (load f)
end
let titledir (dir : repodir_t) = Titledir (repodir_string dir ^ "/title/")
let uuiddir (dir : repodir_t) = UUIDdir (repodir_string dir ^ "/uuid/")
let titledir (dir : repodir_t) = Titledir Fpath.(repodir_path dir / "title")
let uuiddir (dir : repodir_t) = UUIDdir Fpath.(repodir_path dir / "uuid")
let extension = ".ymd"
let article_path (repo : repodir_t) articlepath =
let titledir = titledir_string (titledir repo) in
Articlefilename (titledir ^ articlefilename_string articlepath)
Articlefilename Fpath.(repodir_path repo / "title" // articlefilename_path articlepath)
let title_path (repo : repodir_t) title =
let titledir = titledir_string (titledir repo) in
Articlefilename (titledir ^ Ymd.filename_of_title title ^ extension)
Articlefilename Fpath.(repodir_path repo / "title" / (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)
Articlefilename Fpath.(repodir_path repo / "uuid" / Ymd.(Id.to_string ymd.meta.Meta.uuid ^ extension))
let slug string = Filename.(string |> basename |> chop_extension)
@ -90,25 +86,27 @@ module Entry = struct
let author_email e = e.attributes.author.Ymd.Author.email
let of_filename repo (s : articlefilename_t) =
let ymd = File.ymd (articlefilename_string (article_path repo s)) in
let ymd = File.ymd (articlefilename_path (article_path repo s)) in
{ filename = s; attributes = ymd.Ymd.meta }
let to_filename repo ymd =
let uuid_path = articlefilename_string @@ uuid_path repo ymd in
let uuid_path = Fpath.to_string @@ articlefilename_path @@ 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 repo entry = File.ymd (articlefilename_string (article_path repo entry.filename))
let to_ymd repo entry = File.ymd (articlefilename_path (article_path repo entry.filename))
let slug entry =
Filename.(entry.filename |> articlefilename_string |> basename |> chop_extension)
Fpath.(entry.filename |> articlefilename_path |> base |> rem_ext |> to_string)
let compare_recency a b = Ymd.Date.compare (date b) (date a)
end
let rec next_semantic_filepath ?(version=0) titles ymd =
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
let candidate =
let open Fpath in
titledir_path titles / (Ymd.filename ymd) |> 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 ymd
else candidate
module Archive = struct
@ -119,8 +117,8 @@ module Archive = struct
let published = List.filter Entry.published
let of_repo repo =
let files = Array.to_list @@ Sys.readdir (titledir_string (titledir repo)) in
let to_entry y = Entry.of_filename repo (Articlefilename y) in
let files = Array.to_list @@ Sys.readdir Fpath.(to_string @@ titledir_path (titledir repo)) in
let to_entry y = Entry.of_filename repo (Articlefilename (Fpath.v 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
@ -140,12 +138,12 @@ module Archive = struct
let uuid x = x.Meta.uuid in
let entry = List.find (fun entry -> uuid entry.attributes = uuid ymd.meta) entries in
if slug entry <> filename ymd then
let found_filepath = articlefilename_string (article_path repo entry.filename) in
Lwt_unix.rename found_filepath (next_semantic_filepath titledir ymd)
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 ymd)
else
Lwt.return_unit
with Not_found ->
Lwt_unix.link (articlefilename_string (uuid_path repo ymd)) (next_semantic_filepath titledir ymd);
Lwt_unix.link (Fpath.to_string @@ articlefilename_path (uuid_path repo ymd)) (Fpath.to_string @@ next_semantic_filepath titledir ymd);
end
else
Lwt.return_unit)
@ -177,7 +175,7 @@ let latest_entry repo fragment =
let entry_with_slug repo (slug as s) =
let open Entry in
try Some (of_filename repo (Articlefilename (s ^ extension)))
try Some (of_filename repo (Articlefilename (Fpath.v @@ s ^ extension)))
with _ ->
let slugged last_match entry =
if s <> Ymd.filename_of_title (title entry) then last_match