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

fix path configuratibility

Browse Source
This commit is contained in:
Stavros Polymenis 2016-12-24 14:45:07 +00:00
parent 6296523103
commit 94291e6ae5
3 changed files with 32 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/command.ml
View File

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

51
src/logarion.ml
View File

@ -35,10 +35,11 @@ module Configuration = struct
} }
end end
let ymddir = "ymd/" let titledir ymddir = ymddir ^ "/title/"
let titledir = ymddir ^ "title/" let uuiddir ymddir = ymddir ^ "/uuid/"
let uuiddir = ymddir ^ "uuid/"
let extension = ".ymd" 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 load_file f = let load_file f =
let ic = open_in f in let ic = open_in f in
@ -59,54 +60,52 @@ let of_file s =
else else
{ (blank_ymd ()) with body = "Error parsing file" } { (blank_ymd ()) with body = "Error parsing file" }
let file_meta_pairs () = let file_meta_pairs titles =
let files = Array.to_list @@ Sys.readdir titledir in let files = Array.to_list @@ Sys.readdir titles in
let ymd_list a e = if BatString.ends_with e extension then List.cons e a else a 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 ymds = List.fold_left ymd_list [] files in
let t y = (y, (of_file (titledir ^ y)).Ymd.meta) in let t y = (y, (of_file (titles ^ y)).Ymd.meta) in
List.map t ymds List.map t ymds
let file_ymd_pairs () = let file_ymd_pairs titles =
let files = Array.to_list @@ Sys.readdir titledir in let files = Array.to_list @@ Sys.readdir titles in
let ymd_list a e = if BatString.ends_with e extension then List.cons e a else a 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 ymds = List.fold_left ymd_list [] files in
let t y = (y, (of_file (titledir ^ y))) in let t y = (y, (of_file (titles ^ y))) in
List.map t ymds List.map t ymds
let rec next_semantic_filepath ?(version=0) ymd = let rec next_semantic_filepath ?(version=0) titles ymd =
let candidate = titledir ^ (Ymd.filename ymd) ^ "." ^ (string_of_int version) ^ extension in let candidate = titles ^ (Ymd.filename ymd) ^ "." ^ (string_of_int version) ^ extension in
if Sys.file_exists candidate then next_semantic_filepath ~version:(version+1) ymd if Sys.file_exists candidate then next_semantic_filepath ~version:(version+1) titles ymd
else candidate else candidate
let path_of_title title = titledir ^ Ymd.filename_of_title title ^ extension
let uuid_path ymd = uuiddir ^ Ymd.(Id.to_string ymd.meta.uuid) ^ extension
let slug_of_filename filename = List.hd @@ BatString.split_on_char '.' filename let slug_of_filename filename = List.hd @@ BatString.split_on_char '.' filename
let to_file ymd = let to_file config ymd =
let open Lwt.Infix in let open Lwt.Infix in
let uuid_path = uuid_path ymd in let repo = Configuration.(config.repository) in
let uuid_path = uuid_path repo ymd in
let write_ymd out = Lwt_io.write out (Ymd.to_string 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; Lwt_io.with_file ~mode:Lwt_io.output uuid_path write_ymd;
>>= fun () -> >>= fun () ->
let open Ymd in let open Ymd in
if not (categorised [Category.Draft] ymd) && ymd.meta.title <> "" then if not (categorised [Category.Draft] ymd) && ymd.meta.title <> "" then
let fmp = file_meta_pairs () in let fmp = file_meta_pairs repo in
begin try begin try
let (file, m) = List.find (fun (_, meta) -> meta.uuid = ymd.meta.uuid) fmp in let (file, m) = List.find (fun (_, meta) -> meta.uuid = ymd.meta.uuid) fmp in
if slug_of_filename file <> (Ymd.filename ymd) then if slug_of_filename file <> (Ymd.filename ymd) then
let found_filepath = titledir ^ file in let found_filepath = titledir repo ^ file in
Lwt_unix.rename found_filepath (next_semantic_filepath ymd); Lwt_unix.rename found_filepath (next_semantic_filepath repo ymd);
else Lwt.return () else Lwt.return ()
with Not_found -> with Not_found ->
Lwt_unix.link uuid_path (next_semantic_filepath ymd); Lwt_unix.link uuid_path (next_semantic_filepath repo ymd);
end end
else else
Lwt.return () Lwt.return ()
let latest_file_meta_pair fragment = let latest_file_meta_pair config fragment =
let open Ymd in let open Ymd in
let repo = Configuration.(config.repository) in
let latest p (path', meta') = let latest p (path', meta') =
if not @@ BatString.exists (meta'.title) fragment then None if not @@ BatString.exists (meta'.title) fragment then None
else else
@ -115,4 +114,4 @@ let latest_file_meta_pair fragment =
if meta.date.Date.published < meta'.date.Date.published if meta.date.Date.published < meta'.date.Date.published
then Some (path', meta') else p then Some (path', meta') else p
| None -> Some (path', meta') in | None -> Some (path', meta') in
ListLabels.fold_left ~f:latest ~init:(None) (file_meta_pairs ()) ListLabels.fold_left ~f:latest ~init:(None) (file_meta_pairs repo)

11
src/web.ml
View File

@ -52,8 +52,6 @@ module Configuration = struct
} }
end end
let ymdpath title = Lwt.return @@ Logarion.path_of_title title
let ymd_of_body_pairs pairs = let ymd_of_body_pairs pairs =
let open Ymd in let open Ymd in
let open Lens.Infix in let open Lens.Infix in
@ -77,6 +75,7 @@ let () =
and (>|=) = Lwt.(>|=) in and (>|=) = Lwt.(>|=) in
let module L = Logarion in let module L = Logarion in
let ymd f = L.of_file f |> (fun ymd -> if Ymd.(categorised [Category.Published]) ymd then ymd else Ymd.blank_ymd ()) in let ymd f = L.of_file f |> (fun ymd -> if Ymd.(categorised [Category.Published]) ymd then ymd else Ymd.blank_ymd ()) in
let ymdpath title = Lwt.return @@ Logarion.title_path lgrn.L.Configuration.repository title in
let ret_param name req = Lwt.return (param req name) in let ret_param name req = Lwt.return (param req name) in
let option_load tpl o = match o with Some f -> Some (tpl f) | None -> None in let option_load tpl o = match o with Some f -> Some (tpl f) | None -> None in
let header_tpl = option_load Template.header Configuration.(webcfg.template.header) in let header_tpl = option_load Template.header Configuration.(webcfg.template.header) in
@ -100,11 +99,11 @@ let () =
App.empty App.empty
|> App.port webcfg.Configuration.port |> App.port webcfg.Configuration.port
|> middleware @@ Middleware.static ~local_path:"./share/static" ~uri_prefix:"/static" |> middleware @@ Middleware.static ~local_path:"./share/static" ~uri_prefix:"/static"
|> post "/post" (fun req -> ymd_of_req req >>= fun ymd -> L.to_file ymd >>= fun () -> html_response (page_of_ymd ymd)) |> post "/post" (fun req -> ymd_of_req req >>= fun ymd -> L.to_file lgrn ymd >>= fun () -> html_response (page_of_ymd ymd))
|> get "/edit/:ttl" (fun r -> ret_param "ttl" r >>= ymdpath >|= ymd >|= form_of_ymd >>= html_response) |> get "/edit/:ttl" (fun r -> ret_param "ttl" r >>= ymdpath >|= 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_ymd ()) >|= form_of_ymd >>= html_response)
|> get "/text/:ttl" (fun req -> ret_param "ttl" req >>= ymdpath >|= ymd >|= page_of_ymd >>= html_response) |> get "/text/:ttl" (fun req -> ret_param "ttl" req >>= ymdpath >|= ymd >|= page_of_ymd >>= html_response)
|> get "/!/:ttl" (fun req -> ret_param "ttl" req >|= L.latest_file_meta_pair >|= ymd_or_error >|= page_of_ymd >>= html_response) |> get "/!/:ttl" (fun req -> ret_param "ttl" req >|= L.latest_file_meta_pair lgrn >|= ymd_or_error >|= page_of_ymd >>= html_response)
|> get "/feed.atom" (fun _ -> Lwt.return (L.file_ymd_pairs ()) >|= latest_listed_ymd >|= Atom.feed webcfg.url lgrn >>= html_response) |> get "/feed.atom" (fun _ -> Lwt.return L.(file_ymd_pairs (titledir lgrn.Configuration.repository)) >|= latest_listed_ymd >|= Atom.feed webcfg.url lgrn >>= html_response)
|> get "/" (fun _ -> Lwt.return (L.file_meta_pairs ()) >|= latest_listed_meta >|= list_of_ymds >>= html_response) |> get "/" (fun _ -> Lwt.return L.(file_meta_pairs (titledir lgrn.Configuration.repository)) >|= latest_listed_meta >|= list_of_ymds >>= html_response)
|> App.run_command |> App.run_command