From 6c27c7c6fbba0a044a0ff16a803a0b2f25752174 Mon Sep 17 00:00:00 2001 From: orbifx Date: Sat, 13 Mar 2021 18:40:07 +0000 Subject: [PATCH] Draft Basic unit renamed from Note to Text. New modular text-parser, internal to Logarion, for generic notation parsing. The default input format is now a much plainer text. Eliminated Meta module and generally lib/ modules. New Store interface, with additional information from Store. For example the converter can now check filesystem dates. Changed to filesystem hardlinks for tracking publications & indexing, instead of categories. New commands `publish [-i]` and `deindex [-u]`. Categories are ignored now. Logarion created texts have part of the UUID instead of a counter in their filename. New -i, --interactive flag for interactive creation & publication. Logarion's index re-written in Messagepack format. Removed `indices` command. They are generated during `convert`. --- CONTRIBUTING.md | 83 ----------- Makefile | 13 +- README | 29 ++++ README.md | 50 ------- app/atom.ml | 37 +++++ app/convert.ml | 80 +++++++++++ app/dune | 5 + app/gemini.ml | 14 ++ app/html.ml | 117 ++++++++++++++++ app/logarion_cli.ml | 111 +++++++++++++++ doc/logarion.odocl | 3 - dune-project | 16 +++ lib/archive.ml | 33 +++++ lib/category.ml | 22 +++ lib/date.ml | 8 ++ lib/dune | 4 + lib/file_store.ml | 183 ++++++++++++++++++++++++ lib/id.ml | 9 ++ lib/person.ml | 31 +++++ lib/store.ml | 17 +++ lib/string_set.ml | 15 ++ lib/text.ml | 101 ++++++++++++++ lib/topic_set.ml | 35 +++++ logarion.opam | 51 +++---- share/config.toml | 16 --- share/sass/fonts/orbitron.sass | 15 -- share/sass/layout.sass | 99 ------------- share/sass/main-dark.sass | 23 ---- share/sass/main-light.sass | 23 ---- share/static/main.css | 131 ------------------ share/template/frontpage.mustache | 3 - share/template/header.mustache | 1 - share/template/item.mustache | 3 - share/template/list.mustache | 7 - share/template/note.mustache | 5 - src/confix/config.ml | 82 ----------- src/confix/confixToml.ml | 23 ---- src/confix/jbuild | 7 - src/converters/atom.ml | 50 ------- src/converters/html.ml | 133 ------------------ src/converters/jbuild | 5 - src/converters/template.ml | 81 ----------- src/core/archive.ml | 89 ------------ src/core/jbuild | 5 - src/core/lpath.ml | 25 ---- src/core/meta.ml | 222 ------------------------------ src/core/note.ml | 47 ------- src/core/store.ml | 7 - src/jbuild | 16 --- src/logarion_cli.ml | 176 ----------------------- src/store/file.ml | 112 --------------- src/store/jbuild | 7 - 52 files changed, 899 insertions(+), 1581 deletions(-) delete mode 100644 CONTRIBUTING.md create mode 100644 README delete mode 100644 README.md create mode 100644 app/atom.ml create mode 100644 app/convert.ml create mode 100644 app/dune create mode 100644 app/gemini.ml create mode 100644 app/html.ml create mode 100644 app/logarion_cli.ml delete mode 100644 doc/logarion.odocl create mode 100644 dune-project create mode 100644 lib/archive.ml create mode 100644 lib/category.ml create mode 100644 lib/date.ml create mode 100644 lib/dune create mode 100644 lib/file_store.ml create mode 100644 lib/id.ml create mode 100644 lib/person.ml create mode 100644 lib/store.ml create mode 100644 lib/string_set.ml create mode 100644 lib/text.ml create mode 100644 lib/topic_set.ml delete mode 100644 share/config.toml delete mode 100644 share/sass/fonts/orbitron.sass delete mode 100644 share/sass/layout.sass delete mode 100644 share/sass/main-dark.sass delete mode 100644 share/sass/main-light.sass delete mode 100644 share/static/main.css delete mode 100644 share/template/frontpage.mustache delete mode 100644 share/template/header.mustache delete mode 100644 share/template/item.mustache delete mode 100644 share/template/list.mustache delete mode 100644 share/template/note.mustache delete mode 100644 src/confix/config.ml delete mode 100644 src/confix/confixToml.ml delete mode 100644 src/confix/jbuild delete mode 100644 src/converters/atom.ml delete mode 100644 src/converters/html.ml delete mode 100644 src/converters/jbuild delete mode 100644 src/converters/template.ml delete mode 100644 src/core/archive.ml delete mode 100644 src/core/jbuild delete mode 100644 src/core/lpath.ml delete mode 100644 src/core/meta.ml delete mode 100644 src/core/note.ml delete mode 100644 src/core/store.ml delete mode 100644 src/jbuild delete mode 100644 src/logarion_cli.ml delete mode 100644 src/store/file.ml delete mode 100644 src/store/jbuild diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md deleted file mode 100644 index 46ef2c1..0000000 --- a/CONTRIBUTING.md +++ /dev/null @@ -1,83 +0,0 @@ -# Contributing to Logarion - -Logarions primary aim is to create a note system, which doesn't waste resources. -The secondary aim is to provide an exemplary OCaml project to demonstrate and promote the language (as it happens with many other "Blogging" systems written in other languages). - -As part of the secondary aim, the source code needs to written in a way that encourages the language's adoption and the participation to the OCaml developer community. - -## Starting with OCaml - -_"OCaml is an industrial strength programming language supporting functional, imperative and object-oriented styles"_ -- https://ocaml.org/ - -OCaml simply rocks. - -If you are unfamiliar with OCaml, consider starting with these resources: - -- Install OCaml: https://ocaml.org/docs/install.html -- Read about OCaml: https://ocaml.org/learn/books.html -- Ask questions & join the community: - - Mailing lists: https://ocaml.org/community/ - - IRC: irc://irc.freenode.net/#ocaml (Web client: https://riot.im/app/#/room/#freenode_#ocaml:matrix.org ) - - Reddit: http://www.reddit.com/r/ocaml/ - - Discourse: https://discuss.ocaml.org/ - - .. other: https://ocaml.org/community/ - -## Design principles - -[Unix philosophy](https://en.wikipedia.org/wiki/Unix_philosophy#Do_One_Thing_and_Do_It_Well) - -1. System simplicity & interoperability. -2. Output quality. -3. Distributed interactivity, like sharing with friends. - -## Developing & contributing - -### Clone - -``` -git clone https://cgit.orbitalfox.eu/logarion/ -``` - -Install dependencies: - -``` -cd logarion -pin add logarion . -n -opam depext --install logarion -``` - -Build the project: - -``` -dune build src/logarion.exe -``` - -This will create `_build/default/src/logarion.exe` (the command line interface). - -### Project structure - -There are three layers: - -- notes -- archive -- interfaces & intermediate formats - -### Core - -- `logarion.ml`: repository related functions (listing, adding/removing, etc). ([src/logarion.ml](https://gitlab.com/orbifx/logarion/blob/master/src/logarion.ml)) -- `note.ml`: parsing from and to note files. ([src/note.ml](https://gitlab.com/orbifx/logarion/blob/master/src/note.ml)) - -### Intermediate formats - -Converters: - -- `html.ml`: archive to HTML pages. -- `atom.ml`: archive to Atom feeds. - -### Servers & utilities - -Logarion's archives can be served over various protocols using servers. -Find related software here: - -- https://logarion.orbitalfox.eu/ -- https://cgit.orbitalfox.eu/ \ No newline at end of file diff --git a/Makefile b/Makefile index 22a969f..41d682c 100644 --- a/Makefile +++ b/Makefile @@ -1,18 +1,13 @@ all: cli cli: - dune build src/logarion_cli.exe + dune build app/logarion_cli.exe clean: dune clean -theme-dark: - sassc share/sass/main-dark.sass > share/static/main.css - -theme-light: - sassc share/sass/main-light.sass > share/static/main.css - tgz: - cp _build/default/src/logarion_cli.exe logarion + cp _build/default/app/logarion_cli.exe logarion strip logarion - tar czvf "logarion-$(shell ./logarion --version)-$(shell uname -s)-$(shell uname -m)-$(shell git rev-parse --short HEAD).tar.gz" share logarion + tar czvf "logarion-$(shell date -r _build/default/src/logarion_cli.exe "+%y-%m-%d")-$(shell uname -s)-$(shell uname -m)-$(shell git rev-parse --short HEAD).tar.gz" share logarion + rm logarion diff --git a/README b/README new file mode 100644 index 0000000..a3d3a28 --- /dev/null +++ b/README @@ -0,0 +1,29 @@ +Logarion is a free and open-source text archive system. A blog-wiki hybrid. + +Download: +EUPL licence: + +Start + +Create a folder and run `logarion init` from within it to produce `.logarion/config` configuration file. +Run `logarion --help` for more options. + +Community & support + +* Website: +* Report an issue: +* Discussion: + or join via + + +Install stable from source + + opam add repo orbifx https://opam.orbitalfox.eu + opam install logarion + + +Install development version + + opam pin add text git://orbitalfox.eu/text-parse-ml + opam pin add logarion git://orbitalfox.eu/logarion + opam install logarion diff --git a/README.md b/README.md deleted file mode 100644 index 370f997..0000000 --- a/README.md +++ /dev/null @@ -1,50 +0,0 @@ -# Logarion - -Logarion is a [free and open-source][Licence] personal note taking, journaling and publication system; a blog-wiki hybrid. - -## Features - -- Plain file system store, where each note is a file. -- Command line & web interfaces. -- Atom feeds -- Static (conversion to files for uploading) & dynamic serving (HTTP, Gopher, ..). - - -## Community & support - -- Website: -- Mailing list: -- Matrix (chat): `#logarion:matrix.org`. Via Riot web-app: -- For issues peferably email to [mailto:logarion@lists.orbitalfox.eu](mailto:logarion@lists.orbitalfox.eu?subject=[Issue] summary-here). - Alternatively - - -## Install - -The following instructions are the quickest way to install Logarion (in the absence of binary releases). - -``` -opam pin add logarion git://orbitalfox.eu/logarion -opam install logarion -``` - -Once installed you will have `logarion` for command line control of the repository. - -## Archives - -### Command line - -Create a folder and run `logarion init` from within it to produce `.logarion/config.toml`, which is the core configuration file. -The archive options are under the `[archive]` section. - -Run `logarion --help` for more options. - - -#### Theme - -Optionally install a [Sass](http://sass-lang.com/) compiler, like [sassc](http://sass-lang.com/libsass#sassc), and then run `make theme-dark` or `make theme-light`, to generate a stylesheet as `share/static/main.css`, using the respective Sass files in `share/sass/`. - -## See also - -- [CONTRIBUTING.md](CONTRIBUTING.md) -- [Licence](https://joinup.ec.europa.eu/software/page/eupl) diff --git a/app/atom.ml b/app/atom.ml new file mode 100644 index 0000000..debad81 --- /dev/null +++ b/app/atom.ml @@ -0,0 +1,37 @@ +let esc = Converter.Html.esc + +let element tag content = "<" ^ tag ^ ">" ^ content ^ "" + +let opt_element tag_name content = + if content <> "" + then element tag_name content + else "" + +module P = Parsers.Plain_text.Make (Converter.Html) + +let entry base_url text = + let open Logarion in + let u = Text.alias text in + let authors elt a = + a ^ "" + ^ (opt_element "name" @@ esc elt.Person.name) + ^ (List.fold_left (fun acc addr -> acc ^ element "uri" (Uri.to_string addr)) "" elt.Person.addresses) + ^ "" + in + "" ^ esc text.title ^ "urn:uuid:" ^ Id.to_string text.uuid ^ "" + ^ Date.(text.date |> listing |> rfc_string) ^ "" + ^ Person.Set.fold authors text.authors "" + ^ (opt_element "summary" @@ esc @@ Text.str "abstract" text) + ^ String_set.fold (fun elt a -> a ^ "") (Text.set "topics" text) "" + ^ "
" + ^ P.of_string text.body "" + ^ "
" + +let feed title archive_id base_url texts = + {||} + ^ title ^ {|urn:uuid:|} ^ Logarion.Id.to_string archive_id ^ "" + ^ Ptime.to_rfc3339 (Ptime_clock.now ()) ^ "" + ^ List.fold_left (fun acc t -> acc ^ entry base_url t) "" texts ^ "" diff --git a/app/convert.ml b/app/convert.ml new file mode 100644 index 0000000..f8c9448 --- /dev/null +++ b/app/convert.ml @@ -0,0 +1,80 @@ +let version = "%%VERSION%%" + +open Logarion +module A = Archive.Make (Logarion.File_store) + +let file_when_changed source dest fn title text = + if (try Unix.((stat dest).st_mtime < (stat source).st_mtime) with _-> true) then + File_store.file dest (fn title text) + +let writer dir name acc (text,store_item) = (* todo: single_parser -> [files] *) + let open Logarion in + match Text.(str "Content-Type" text) with + | "" | "text/plain" -> + let filename = dir ^ "/" ^ Text.alias text in + let idfilename = dir ^ "/" ^ Id.to_string text.Text.uuid ^ ".txt" in + file_when_changed store_item idfilename (fun _title -> Text.to_string) text.title text; + file_when_changed store_item (filename ^ ".html") (Html.page "") name text; + file_when_changed store_item (filename ^ ".gmi") Gemini.page name text; + (acc + 1) + | x -> prerr_endline ("No converter for Content-Type: " ^ x ^ ", for " ^ text.Text.title); acc + +let index_pack archive indexed_texts = + let persons ps = List.rev @@ Person.Set.fold (fun x a -> Msgpck.String (Person.to_string x) :: a) ps [] in + let to_pack a t = + let open Text in + let of_set field t = List.rev @@ String_set.fold (fun x a -> Msgpck.String x :: a) (set field t) [] in + Msgpck.(List [Bytes (Id.to_bytes t.uuid); String t.title; List (persons t.authors); List (of_set "topics" t); List (of_set "keywords" t)]) + :: a + in + let header_pack = Msgpck.List List.(fold_left to_pack [] indexed_texts) in + let columns = Msgpck.(List [String "id"; String "title"; String "authors"; String "topics"; String "keywords"]) in + let archive = Msgpck.(List [Int 0; String archive.A.name; List (persons archive.A.archivists)]) in + Bytes.to_string @@ Msgpck.Bytes.to_string (List [archive; columns; header_pack]) + +let index_writer dir archive topic_roots topic_map indexed_texts = + let name = archive.A.name in + let file path = File_store.file (dir ^ path) in + file "/index.pck" (index_pack archive indexed_texts); + file "/index.html" (Html.topic_main_index name topic_roots indexed_texts); + List.iter + (fun topic -> file ("/index." ^ topic ^ ".htm") (Html.topic_sub_index name topic_map topic indexed_texts)) + topic_roots; + file "/index.date.html" (Html.date_index name indexed_texts); + let base_url = try Store.KV.find "HTTP-URL" archive.File_store.kv + with Not_found -> prerr_endline "Missing `HTTP-URL:` in config"; "" + in + file "/feed.atom" (Atom.feed archive.A.name archive.A.id base_url indexed_texts); + file "/index.date.gmi" (Gemini.date_index name indexed_texts) + +let convert_all dir archive = + let name = archive.A.name in + let published_count = A.(fold ~order:newest (writer dir name) 0 (published archive)) in + let topic_map, indexed_metas = + let topic_map = Logarion.Topic_set.Map.empty in + let fn (ts,ls) (elt,_) = Logarion.(Topic_set.to_map ts (Text.set "topics" elt)), elt::ls in + A.(fold ~order:newest fn (topic_map,[]) (indexed archive)) in + let topic_roots = Logarion.Topic_set.roots topic_map in + index_writer dir archive topic_roots topic_map indexed_metas; + print_endline @@ "Converted: " ^ string_of_int (published_count) ^ "\nIndexed: " ^ string_of_int (List.length indexed_metas); + Ok () + +let convert_dir cmd_dir = + let (>>=) = Result.bind in + let config_dir archive = try Ok (Store.KV.find "Export-Dir" archive.File_store.kv) with Not_found -> Error "unspecified export dir" in + let init dir = + Result.map_error (function `Msg m -> m) Logarion.File_store.Directory.(directory dir |> print ~descr:"export" dir) in + (A.of_path "." + >>= fun archive -> (match cmd_dir with "" -> config_dir archive | x -> Ok x) + >>= fun dir -> init dir + >>= fun _ -> convert_all dir archive) + |> function Ok () -> () | Error x -> prerr_endline x + +open Cmdliner + +let term = + let directory = Arg.(value & pos 0 string "" & info [] ~docv:"target directory" ~doc:"Directory to convert into") in + Term.(const convert_dir $ directory), + Term.info + "convert" ~doc:"convert archive" + ~man:[ `S "DESCRIPTION"; `P "Convert Logarion archive" ] diff --git a/app/dune b/app/dune new file mode 100644 index 0000000..54edd62 --- /dev/null +++ b/app/dune @@ -0,0 +1,5 @@ +(executable + (name logarion_cli) + (public_name logarion) + (modules logarion_cli convert html atom gemini) + (libraries logarion re.str cmdliner bos ptime ptime.clock.os text_parse.converter text_parse.parsers msgpck)) diff --git a/app/gemini.ml b/app/gemini.ml new file mode 100644 index 0000000..472e97f --- /dev/null +++ b/app/gemini.ml @@ -0,0 +1,14 @@ +let page _archive_title text = + let open Logarion.Text in + "# " ^ text.title + ^ "\nAuthors: " ^ Logarion.Person.Set.to_string text.authors + ^ "\nDated: " ^ Logarion.Date.(pretty_date @@ listing text.date) + ^ let module T = Parsers.Plain_text.Make (Converter.Gemini) in + "\n" ^ T.of_string text.body "" + +let date_index title meta_list = + List.fold_left + (fun a m -> + a ^ "=> " ^ Logarion.Text.alias m ^ ".gmi " ^ + Logarion.(Date.(pretty_date (listing m.date)) ^ " " ^ m.title) ^ "\n") + ("# " ^ title ^ "\n") meta_list diff --git a/app/html.ml b/app/html.ml new file mode 100644 index 0000000..d3c9d37 --- /dev/null +++ b/app/html.ml @@ -0,0 +1,117 @@ +let wrap ?(keywords="") (title:string) (subtitle:string) body = + {||} + ^ subtitle ^ " | " ^ title + ^ {|

|} ^ title + ^ "

" ^ body + ^ {||} + +let topic_link root topic = + {||} ^ String.capitalize_ascii topic ^ "" + +let page _topic_roots archive_title text = + let open Logarion in + let open Text in + let module T = Parsers.Plain_text.Make (Converter.Html) in + let sep_append ?(sep=", ") a x = match a,x with "",_ -> x | _, "" -> a | _ -> a ^ sep ^ x in + let opt_kv key value = if String.length value > 0 then "
" ^ key ^ "
" ^ value else "" in +(* let author acc auth = sep_append acc Person.(auth.name ^ " ") in*) + let authors = T.of_string (Person.Set.to_string text.authors ^ " ") "" in + let keywords = str_set "keywords" text in + let header = + let time x = {|" in + let topic_links x = + let to_linked t a = + let ts = Topic_set.of_string t in + sep_append a (List.fold_left (fun a t -> sep_append ~sep:" > " a (topic_link (List.hd ts) t)) "" ts) in + String_set.fold to_linked x "" in + "
" + ^ opt_kv "Title:" text.title + ^ opt_kv "Authors:" authors + ^ opt_kv "Date: " (time (Date.(pretty_date @@ listing text.date))) + ^ opt_kv "Series: " (str_set "series" text) + ^ opt_kv "Topics: " (topic_links (set "topics" text)) + ^ opt_kv "Keywords: " keywords + ^ opt_kv "Id: " (Id.to_string text.uuid) + ^ {|
|} in
+  wrap ~keywords archive_title text.title ((T.of_string text.body header) ^ "
") + +let to_dated_links ?(limit) meta_list = + let meta_list = match limit with + | None -> meta_list + | Some limit-> + let rec reduced acc i = function + | [] -> acc + | h::t -> if i < limit then reduced (h::acc) (i+1) t else acc in + List.rev @@ reduced [] 0 meta_list + in + List.fold_left + (fun a m -> + a ^ Logarion.(Date.(pretty_date (listing m.Text.date)) ^ " ") + ^ {||} ^ m.Logarion.Text.title ^ "
") + "" meta_list + +let date_index ?(limit) title meta_list = + match limit with + | Some limit -> wrap title "Index" (to_dated_links ~limit meta_list) + | None -> wrap title "Index" (to_dated_links meta_list) + +let fold_topic_roots topic_roots = + let list_item root t = "
  • " ^ topic_link root t in + "" + +let fold_topics topic_map topic_roots metas = + let open Logarion in + let rec unordered_list root topic = + List.fold_left (fun a x -> a ^ list_item root x) "
      " topic ^ "
    " + and sub_items root topic = match Topic_set.Map.find_opt topic topic_map with + | None -> "" + | Some (_, subtopics) -> unordered_list root (String_set.elements subtopics) + and list_item root t = + let item = + if List.exists (fun x -> String_set.mem t (String_set.map Topic_set.topic (Text.set "topics" x))) metas + then topic_link root t else t + in + "
  • " ^ item ^ sub_items root t + in + "" + +let text_item path meta = + let open Logarion in + {||} ^ meta.Text.title + ^ "" + +let listing_index topic_map topic_roots path metas = + let rec item_group topics = + List.fold_left (fun acc topic -> acc ^ sub_groups topic ^ "" ^ items topic) "" topics + and sub_groups topic = match Logarion.Topic_set.Map.find_opt topic topic_map with + | None -> "" + | Some (_, subtopics) -> item_group (Logarion.String_set.elements subtopics) + and items topic = + let items = + let open Logarion in + List.fold_left + (fun a e -> + if String_set.mem topic (String_set.map (Logarion.Topic_set.topic) (Text.set "Topics" e)) + then text_item path e ^ a else a) "" metas in + match items with + | "" -> "" + | x -> {||} ^ topic ^ "" ^ x + in + "" + +let topic_main_index title topic_roots metas = + wrap title "Topics" + (fold_topic_roots topic_roots + ^ "|} ) + +let topic_sub_index title topic_map topic_root metas = + wrap title topic_root + (fold_topics topic_map [topic_root] metas + ^ {|Subscribe to |}^ topic_root ^{| feed 📰|} + ^ listing_index topic_map [topic_root] "" metas) diff --git a/app/logarion_cli.ml b/app/logarion_cli.ml new file mode 100644 index 0000000..9e2b372 --- /dev/null +++ b/app/logarion_cli.ml @@ -0,0 +1,111 @@ +let version = "%%VERSION%%" + +open Cmdliner +open Logarion +module A = Logarion.Archive.Make(File_store) + +(* TODO: merge in lib/ so other modules can use (.e.g HTTP pull) *) +let text_list field_opt authors_opt keywords_opt topics_opt = + match A.of_path "." with + | Error msg -> prerr_endline msg + | Ok archive -> + let predicates = + A.predicate A.authored authors_opt + @ A.predicate A.keyworded keywords_opt + @ A.predicate A.topics topics_opt + in + let predicate text = List.fold_left (fun a e -> a && e text) true predicates in + let order = A.newest in + let print_fold ~predicate fn = + let ts = A.fold ~predicate ~order fn String_set.empty archive in + String_set.iter (print_endline) ts + in + match field_opt with + | None -> A.iter ~predicate ~order (fun (n,_) -> print_endline n.Text.title) archive + | Some "keywords"-> print_fold ~predicate (fun a (e,_) -> (String_set.union a (Text.set "keywords" e))) + | Some "topics" -> print_fold ~predicate (fun a (e,_) -> (String_set.union a (Text.set "topics" e))) + | Some "authors" -> + let s = A.fold ~predicate ~order (fun a (e,_) -> Person.Set.union a e.Text.authors) Person.Set.empty archive in + print_endline @@ Person.Set.to_string s + | Some x -> prerr_endline @@ "Unrecognised field: " ^ x + +let list_term = + let field = Arg.(value & opt (some string) None & info ["f"; "field"] ~docv:"FIELD" ~doc:"what to list") in + let authors = Arg.(value & opt (some string) None & info ["a"; "authors"] ~docv:"AUTHORS" ~doc:"texts with authors") in + let keywords= Arg.(value & opt (some string) None & info ["k"; "keywords"] ~docv:"KEYWORDS" ~doc:"texts with keywords") in + let topics = Arg.(value & opt (some string) None & info ["t"; "topics"] ~docv:"TOPICS" ~doc:"texts with topics") in + Term.(const text_list $ field $ authors $ keywords $ topics), + Term.info "list" ~doc:"list texts" ~man:[ `S "DESCRIPTION"; `P "List texts in Logarion archive" ] + +let publish and_index files = match A.of_path "." with + | Error msg -> prerr_endline msg + | Ok archive -> File_store.(list_iter (if and_index then index else publish) archive files) + +let publish_term = + let files = Arg.(value & pos_all string [] & info [] ~doc:"filenames") in + let index = Arg.(value & flag & info ["i"; "index"] ~doc:"Also index") in + let doc = "publish notes; it will become available in exports and for distribution" in + let man = [ `S "DESCRIPTION"; `P doc ] in + Term.(const publish $ index $ files), Term.info "publish" ~doc ~man + +let deindex and_unpub files = match A.of_path "." with + | Error msg -> prerr_endline msg + | Ok archive -> File_store.(list_iter (if and_unpub then unpublish else deindex) archive files) + +let deindex_term = + let files = Arg.(value & pos_all string [] & info [] ~doc:"filenames") in + let unpub = Arg.(value & flag & info ["u"; "unpublish"] ~doc:"Also unpublish") in + let doc = "deindex; it will disappear from indices" in + let man = [ `S "DESCRIPTION"; `P doc ] in + Term.(const deindex $ unpub $ files), Term.info "deindex" ~doc ~man + +let init _force = File_store.init () + +let init_term = + let force = Arg.(value & flag & info ["f"; "force"] ~doc:"Initialise even if directory is not empty") in + let doc = "initialise a logarion repository in present directory" in + let man = [ `S "DESCRIPTION"; `P "Create a repository in current directory" ] in + Term.(const init $ force), Term.info "init" ~doc ~man + +let create_term = + let f title topics_opt interactive = + match A.of_path "." with + | Error m -> prerr_endline m + | Ok archive -> + let t = match title with "" -> "Draft" | _ -> title in + let authors = archive.archivists in + let date = Date.({ created = Some (Ptime_clock.now ()); edited = None }) in + let text = { (Text.blank ()) with title = t; authors; date } in + let text = try Text.with_str_set text "Topics" (Option.get topics_opt) with _ -> text in + match File_store.with_text archive text with + | Error s -> prerr_endline s + | Ok (filepath, _note) -> + match interactive with false -> print_endline filepath + | true -> + print_endline @@ "Created: " ^ filepath; + let rec yn () = match read_line () with "y" -> true | "n" -> false + | _ -> print_string "y or n? "; flush stdout; yn () in + let _code = Sys.command ("$EDITOR " ^ filepath) in + print_string "Publish? [yn]: "; + match yn () with false -> () + | true -> + print_string "Index? [yn]: "; + let and_index = yn () in + File_store.(list_iter (if and_index then index else publish) archive [filepath]) + in + let title = Arg.(value & pos 0 string "" & info [] ~docv:"TITLE" ~doc:"Title for new article") in + let topics= Arg.(value & opt (some string) None & info ["t"; "topics"] ~docv:"TOPICS" ~doc:"Topics for new article") in + let inter = Arg.(value & flag & info ["i"; "interactive"] ~doc:"Prompts through the steps of creation and publication") in + let man = [ `S "DESCRIPTION"; `P "Create a new article, with title 'Draft' when none provided"] in + Term.(const f $ title $ topics $ inter), Term.info "create" ~doc:"create a new article" ~man + +let default_cmd = + let doc = "text archival & publishing" in + let man = [ `S "BUGS"; `P "Submit bugs " ] in + Term.(ret (const (`Help (`Pager, None)))), Term.info "logarion" ~version ~doc ~man + +let cmds = [ init_term; create_term; publish_term; deindex_term; list_term; Convert.term ] + +let () = + Random.self_init(); + match Term.eval_choice default_cmd cmds with `Error _ -> exit 1 | _ -> exit 0 diff --git a/doc/logarion.odocl b/doc/logarion.odocl deleted file mode 100644 index 3f5faf0..0000000 --- a/doc/logarion.odocl +++ /dev/null @@ -1,3 +0,0 @@ -Logarion -Ymd -Web \ No newline at end of file diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..665a396 --- /dev/null +++ b/dune-project @@ -0,0 +1,16 @@ +(lang dune 2.0) +(name logarion) +(homepage "https://logarion.orbitalfox.eu") + +(source (uri git://orbitalfox.eu/logarion)) +(license EUPL) +(authors "orbifx") +(maintainers "fox@orbitalfox.eu") +(bug_reports "mailto:logarion@lists.orbitalfox.eu?subject=Issue:") + +(generate_opam_files true) + +(package + (name logarion) + (synopsis "A texts system") + (depends re cmdliner bos ptime uuidm uri text_parse msgpck)) diff --git a/lib/archive.ml b/lib/archive.ml new file mode 100644 index 0000000..d095fcd --- /dev/null +++ b/lib/archive.ml @@ -0,0 +1,33 @@ +(*let module S = Set.Make (Text) in*) +(*let module M = Map.Make (String) in*) +(*let module I = Map.Make (Id) in*) +(*let aggr = I.empty, M.empty, M.empty, M.empty in*) +(*let fn (id, a, t, k) (n,_) =*) +(* let id = I.add n.Text.uuid n id in*) +(* let a =*) +(* let f e a = M.update (e.Person.name) (function Some v -> Some (S.add n v) | None -> Some (S.singleton n)) a in*) +(* Person.Set.fold f n.Text.authors a in*) +(* let t =*) +(* let f e a = M.update e (function Some v -> Some (S.add n v) | None -> Some (S.singleton n)) a in*) +(* String_set.fold f (Text.set "Topics" n) t in*) +(* let k =*) +(* let f e a = M.update e (function Some v -> Some (S.add n v) | None -> Some (S.singleton n)) a in*) +(* String_set.fold f (Text.set "Keywords" n) k in*) +(* (id, a, t, k)*) + +module Make (Store : Store.T) = struct + include Store + let predicate fn opt = Option.(to_list @@ map fn opt) + + let authored query_string = + let q = Person.Set.of_query @@ String_set.query query_string in + fun n -> Person.Set.predicate q n.Text.authors + + let keyworded query_string = + let q = String_set.query query_string in + fun n -> String_set.(predicate q (Text.set "Keywords" n)) + + let topics query_string = + let q = String_set.query query_string in + fun n -> String_set.(predicate q (Text.set "Topics" n)) +end diff --git a/lib/category.ml b/lib/category.ml new file mode 100644 index 0000000..ac807b6 --- /dev/null +++ b/lib/category.ml @@ -0,0 +1,22 @@ +module Category = struct + type t = Unlisted | Published | Invalid | Custom of string + let compare = Stdlib.compare + let of_string = function "unlisted" | "published" -> Invalid | c -> Custom c + let to_string = function Custom c -> c | _ -> "" +end + +include Category + +module CategorySet = struct + include Set.Make (Category) + let of_stringset s = String_set.fold (fun e a -> add (Category.of_string e) a) s empty + let of_query q = of_stringset (fst q), of_stringset (snd q) + let predicate (inc, exl) set = not (disjoint inc set) && disjoint exl set + let of_string x = of_stringset (String_set.of_string x) + let to_string set = + let f elt a = + let s = Category.to_string elt in + if a <> "" then a ^ ", " ^ s else s + in + fold f set "" +end diff --git a/lib/date.ml b/lib/date.ml new file mode 100644 index 0000000..3902f47 --- /dev/null +++ b/lib/date.ml @@ -0,0 +1,8 @@ +type t = { created: Ptime.t option; edited: Ptime.t option } +let compare = compare +let rfc_string date = match date with Some t -> Ptime.to_rfc3339 t | None -> "" +let of_string (rfc : string) = match Ptime.of_rfc3339 rfc with Ok (t,_,_) -> Some t | Error _ -> None +let listing date = if Option.is_some date.edited then date.edited else date.created +let pretty_date = function + | Some t -> Ptime.to_date t |> fun (y, m, d) -> Printf.sprintf "%04d-%02d-%02d" y m d + | None -> "" diff --git a/lib/dune b/lib/dune new file mode 100644 index 0000000..3f5abd9 --- /dev/null +++ b/lib/dune @@ -0,0 +1,4 @@ +(library + (name logarion) + (public_name logarion) + (libraries ptime uuidm uri re.str bos text_parse text_parse.parsers)) diff --git a/lib/file_store.ml b/lib/file_store.ml new file mode 100644 index 0000000..6269014 --- /dev/null +++ b/lib/file_store.ml @@ -0,0 +1,183 @@ +type t = string +type item_t = string +type archive_t = { name: string; archivists: Person.Set.t; id: Id.t; + kv: string Store.KV.t; store: t } +type record_t = Text.t * item_t + +let extensions = [ ".txt"; ".gmi"; ".md"; ".org" ] +let pubdir = "/.logarion/published/" +let idxdir = "/.logarion/indexed/" + +let to_string f = + let ic = open_in f in + let n = in_channel_length ic in + let s = Bytes.create n in + really_input ic s 0 n; + close_in ic; + Bytes.to_string s + +let (//) a b = a ^ "/" ^ b + +let to_text dir filename = let f = dir // filename in + to_string f |> Text.of_string |> Result.map_error (fun m -> f^": "^m) +let text_filetype dir name = + try Fpath.(let v = v name in mem_ext extensions v || (not (exists_ext v) && not (Sys.is_directory @@ dir^"/"^name))) + with Invalid_argument str -> prerr_endline ("file: " ^ name ^ " invalid (" ^ str ^ ")"); false + +let clean_unlinked dir filepath = + let file = dir ^ filepath in + match (Unix.lstat file).st_nlink with 1 -> Unix.unlink file | _ -> () + | exception Unix.Unix_error(Unix.ENOENT,_,_) -> () + +let purged_substore archive subdir = + let store = archive.store ^ subdir in + Array.iter (clean_unlinked store) @@ Sys.readdir store; + { archive with store } + +let published archive = purged_substore archive pubdir +let indexed archive = purged_substore archive idxdir + +let publish dir text file = + try Unix.link file (dir ^ pubdir ^ Id.to_string text.Text.uuid) + with Unix.Unix_error(Unix.EEXIST,_,_) -> () +let deindex dir text _file = + try Unix.unlink (dir ^ idxdir ^ Id.to_string text.Text.uuid) + with Unix.Unix_error(Unix.ENOENT,_,_) -> () +let unpublish dir text file = + deindex dir text file; + try Unix.unlink (dir ^ pubdir ^ Id.to_string text.Text.uuid) + with Unix.Unix_error(Unix.ENOENT,_,_) -> () +let index dir text file = + publish dir text file; + try Unix.link file (dir ^ idxdir ^ Id.to_string text.Text.uuid) + with Unix.Unix_error(Unix.EEXIST,_,_) -> () + +let newest (a,_pa) (b,_pb) = Text.newest a b +let oldest (a,_pa) (b,_pb) = Text.oldest a b + +let list_iter fn {store;_} paths = + let link f = match to_text store f with Ok t -> fn store t f | Error s -> prerr_endline s in + List.iter link paths + +let iter_valid_text dir pred fn p = + if text_filetype dir p then + match to_text dir p with Error x -> prerr_endline x | Ok t -> if pred t then fn (t, dir^p) + +let fold_valid_text dir pred fn acc p = + if not (text_filetype dir p) then acc else + match to_text dir p with + Error x -> prerr_endline x; acc | Ok t -> if pred t then fn acc (t, dir^p) else acc + +let iter ?(predicate=fun _ -> true) ?order fn {store;_} = + match order with + | None -> Array.iter (iter_valid_text store predicate fn) @@ Sys.readdir store + | Some comp -> + List.iter fn @@ List.fast_sort comp + @@ Array.fold_left (fold_valid_text store predicate (fun a e -> List.cons e a)) [] + @@ Sys.readdir store + +let fold ?(predicate=fun _ -> true) ?order fn acc {store;_} = + match order with + | None -> Array.fold_left (fold_valid_text store predicate fn) acc @@ Sys.readdir store + | Some comp -> + List.fold_left fn acc @@ List.fast_sort comp + @@ Array.fold_left (fold_valid_text store predicate (fun a e -> List.cons e a)) [] + @@ Sys.readdir store + +let with_id { store; _ } id = + let matched acc path = + if not (text_filetype store path) then acc + else + match to_text store path with + | Error x -> prerr_endline x; acc + | Ok text -> + if text.Text.uuid <> id then acc + else + match acc with + | Ok None -> Ok (Some text) + | Ok (Some prev) -> if prev = text then acc else Error [text; prev] + | Error x -> Error (text :: x) + in + Array.fold_left matched (Ok None) @@ Sys.readdir store + +module Directory = struct + let print ?(descr="") dir result = + let () = match result with + | Ok true -> print_endline ("Created " ^ descr ^ " directory " ^ dir) + | Ok false -> print_endline ("Using existing " ^ descr ^ " directory " ^ dir) + | Error (`Msg msg) -> prerr_endline @@ "Failed making " ^ descr ^ ". " ^ msg + in + result + + let directory dir = Result.bind (Fpath.of_string dir) Bos.OS.Dir.create + + let rec directories = function + | [] -> Ok () + | (d, descr)::tl -> + match directory d |> print ~descr d with + | Ok _ -> directories tl + | Error _ -> Error (d, descr) +end + +let copy ?(recursive = false) src dst = + Bos.OS.Cmd.run (Bos.Cmd.(v "cp" %% (on recursive @@ v "-r") % src % dst)) + +let versioned_basename_of_title ?(version=0) repo extension (title : string) = + let basename = Text.string_alias title in + let rec next version = + let candidate = repo // basename ^ "." ^ string_of_int version ^ extension in + if Sys.file_exists candidate then next (succ version) else candidate + in + next version + +let uuid_filename repo extension text = + let basename = Text.alias text in + let candidate = repo // String.sub (Id.to_string text.uuid) 0 6 ^ "." ^ basename ^ extension in + if Sys.file_exists candidate then Error "Name clash, try again" else Ok candidate + +let file path content = let out = open_out path in output_string out content; close_out out + +let with_text {store;_} new_text = + let extension = List.hd extensions in + Result.bind (uuid_filename store extension new_text) @@ + fun path -> + try file path (Text.to_string new_text); Ok (path, new_text) with Sys_error s -> Error s + +let basic_toml_bytes = + "Archive-Name: " + ^ "\nArchive-ID: " ^ Id.(generate () |> to_string) + ^ "\nArchivists: " ^ Bos.OS.Env.opt_var "USER" ~absent:"" + |> Bytes.of_string + +let init ?(dotdir=".logarion/") () = + match Directory.directories [dotdir, "dotdir"; dotdir//"published", "linkdir"; dotdir//"indexed", "link dir"] with + | Error (_dir, _desc) -> () + | Ok () -> + let config_file = + open_out_gen [Open_creat; Open_excl; Open_wronly] + 0o700 (dotdir // "config") in + output_bytes config_file basic_toml_bytes; + close_out config_file + +module Config = struct + type t = archive_t + let key_value k v a = match k with + | "Archive-Name" -> { a with name = String.trim v } + | "Archive-ID" -> { a with id = Option.get (Id.of_string (String.trim v)) } + | "Archivists" -> { a with archivists = Person.Set.of_string v } + | _ -> { a with kv = Store.KV.add k (String.trim v) a.kv } +end + +let of_path store = + let open Text_parse in + let subsyntaxes = [| (module Parsers.Key_value.Make (Config) : Parser.S with type t = Config.t); (module Parsers.Key_value.Make (Config)); |] in + let of_string text acc = Parser.parse subsyntaxes { text; pos = 0; right_boundary = String.length text - 1 } acc in + Ok (of_string (to_string @@ store ^ "/.logarion/config") + { + name = ""; + archivists = Person.Set.empty; + id = Id.nil; + kv = Store.KV.empty; + store = Bos.OS.Env.opt_var "LOGARION_DIR" ~absent:"." + } + ) diff --git a/lib/id.ml b/lib/id.ml new file mode 100644 index 0000000..d79feb4 --- /dev/null +++ b/lib/id.ml @@ -0,0 +1,9 @@ +let random_state = Random.State.make_self_init () +type t = Uuidm.t +let compare = Uuidm.compare +let to_string = Uuidm.to_string +let of_string = Uuidm.of_string +let to_bytes = Uuidm.to_bytes +let of_bytes = Uuidm.of_bytes +let generate ?(random_state=random_state) = Uuidm.v4_gen random_state +let nil = Uuidm.nil diff --git a/lib/person.ml b/lib/person.ml new file mode 100644 index 0000000..876c9e6 --- /dev/null +++ b/lib/person.ml @@ -0,0 +1,31 @@ +module Person = struct + type name_t = string + type address_t = Uri.t + type t = { name: name_t; addresses: address_t list } + let empty = { name = ""; addresses = [] } + let compare = Stdlib.compare + let to_string p = List.fold_left (fun a e -> a^" <"^Uri.to_string e^">") p.name p.addresses + let of_string s = match String.trim s with "" -> empty | s -> + match Re.Str.(split (regexp " *< *") s) with + | [] -> empty + | [n] -> let name = String.trim n in { empty with name } + | n::adds -> + let name = String.trim n in + let addresses = List.map (fun f -> Uri.of_string @@ String.(sub f 0 (length f -1))) adds in + { name; addresses } +end + +include Person + +module Set = struct + include Set.Make(Person) + let to_string ?(pre="") ?(sep=", ") s = + let str = Person.to_string in + let j x a = match a, x with "",_ -> str x | _,x when x = Person.empty -> a | _ -> a^sep^str x in + fold j s pre + let of_string s = of_list (List.map Person.of_string (String_set.list_of_csv s)) + + let of_stringset s = String_set.fold (fun e a -> union (of_string e) a) s empty + let of_query q = of_stringset (fst q), of_stringset (snd q) + let predicate (inc, exl) set = not (disjoint inc set) && disjoint exl set +end diff --git a/lib/store.ml b/lib/store.ml new file mode 100644 index 0000000..b2b5e90 --- /dev/null +++ b/lib/store.ml @@ -0,0 +1,17 @@ +module KV = Map.Make (String) + +module type T = sig + type t + type item_t + type archive_t = { name : string; archivists : Person.Set.t; id : Id.t; kv : string KV.t; store : t } + type record_t = Text.t * item_t + val of_path: string -> (archive_t, string) result + val published: archive_t -> archive_t + val indexed: archive_t -> archive_t + val newest: record_t -> record_t -> int + val oldest: record_t -> record_t -> int + val with_id: archive_t -> Id.t -> (Text.t option, Text.t list) result + val with_text: archive_t -> Text.t -> (string * Text.t, string) result + val iter: ?predicate:(Text.t -> bool) -> ?order:(record_t -> record_t -> int) -> (record_t -> unit) -> archive_t -> unit + val fold: ?predicate:(Text.t -> bool) -> ?order:(record_t -> record_t -> int) -> ('a -> record_t -> 'a) -> 'a -> archive_t -> 'a +end diff --git a/lib/string_set.ml b/lib/string_set.ml new file mode 100644 index 0000000..56f537e --- /dev/null +++ b/lib/string_set.ml @@ -0,0 +1,15 @@ +include Set.Make(String) + +let list_of_csv x = Re.Str.(split (regexp " *, *")) (String.trim x) +let of_string x = of_list (list_of_csv x) +let to_string ?(pre="") ?(sep=", ") s = + let j a x = match a, x with "", _ -> x | _, "" -> a | _ -> a ^ sep ^ x in + fold (fun x acc -> j acc x) s pre + +let query string = + let partition (include_set, exclude_set) elt = + if String.get elt 0 = '!' then (include_set, add String.(sub elt 1 (length elt - 1)) exclude_set) + else (add elt include_set, exclude_set) in + List.fold_left partition (empty, empty) @@ list_of_csv string + +let predicate (inc, exl) set = not (disjoint inc set) && disjoint exl set diff --git a/lib/text.ml b/lib/text.ml new file mode 100644 index 0000000..932c93f --- /dev/null +++ b/lib/text.ml @@ -0,0 +1,101 @@ +module String_map = Map.Make (String) +type t = { + title: string; + uuid: Id.t; + authors: Person.Set.t; + date: Date.t; + string_map: string String_map.t; + stringset_map: String_set.t String_map.t; + body: string; + } + +let blank ?(uuid=(Id.generate ())) () = { + title = ""; + uuid; + authors = Person.Set.empty; + date = Date.({ created = None; edited = None}); + string_map = String_map.empty; + stringset_map = String_map.empty; + body = ""; + } + +let compare = Stdlib.compare +let newest a b = Date.(compare a.date b.date) +let oldest a b = Date.(compare b.date a.date) +let str key m = try String_map.find (String.lowercase_ascii key) m.string_map with Not_found -> "" +let set key m = try String_map.find (String.lowercase_ascii key) m.stringset_map with Not_found -> String_set.empty +let str_set key m = String_set.to_string @@ set key m +let with_str_set m key str = { m with stringset_map = String_map.add (String.lowercase_ascii key) (String_set.of_string str) m.stringset_map } + +let with_kv x (k,v) = + let trim = String.trim in + match String.lowercase_ascii k with + | "body" -> { x with body = String.trim v } + | "title"-> { x with title = trim v } + | "id" -> (match Id.of_string v with Some id -> { x with uuid = id } | None -> x) + | "author" + | "authors" -> { x with authors = Person.Set.of_string (trim v)} + | "date" -> { x with date = Date.{ x.date with created = Date.of_string v }} + | "date-edited"-> { x with date = Date.{ x.date with edited = Date.of_string v }} + | "licences" | "topics" | "keywords" | "series" as k -> with_str_set x k v + | k -> { x with string_map = String_map.add k (trim v) x.string_map } + +let kv_of_string line = match Re.Str.(bounded_split (regexp ": *")) line 2 with + | [ key; value ] -> Re.Str.(replace_first (regexp "^#\\+") "" key), value + | [ key ] -> Re.Str.(replace_first (regexp "^#\\+") "" key), "" + | _ -> "","" + +let of_header front_matter = + let fields = List.map kv_of_string (Re.Str.(split (regexp "\n")) front_matter) in + List.fold_left with_kv (blank ~uuid:Id.nil ()) fields + +let front_matter_body_split s = + if Re.Str.(string_match (regexp ".*:.*")) s 0 + then match Re.Str.(bounded_split (regexp "^$")) s 2 with + | front::body::[] -> (front, body) + | _ -> ("", s) + else ("", s) + +let of_string s = + let front_matter, body = front_matter_body_split s in + try + let note = { (of_header front_matter) with body } in + if note.uuid <> Id.nil then Ok note else Error "Missing ID header" + with _ -> Error ("Failed parsing" ^ s) + +let to_string x = + let has_len v = String.length v > 0 in + let s field value = if has_len value then field ^ ": " ^ value ^ "\n" else "" in + let a value = if Person.Set.is_empty value then "" else "Authors: " ^ Person.Set.to_string value ^ "\n" in + let d field value = match value with Some _ -> field ^ ": " ^ Date.rfc_string value ^ "\n" | None -> "" in + let rows = + [ s "Title" x.title; + a x.authors; + d "Date" x.date.Date.created; + d "Edited" x.date.Date.edited; + s "Licences" (str_set "licences" x); + s "Topics" (str_set "topics" x); + s "Keywords" (str_set "keywords" x); + s "Series" (str_set "series" x); + s "Abstract" (str "abstract" x); + s "ID" (Uuidm.to_string x.uuid); + s "Alias" (str "Alias" x) ] + in + String.concat "" rows ^ "\n" ^ x.body + +let string_alias t = + let is_reserved = function + | '!' | '*' | '\'' | '(' | ')' | ';' | ':' | '@' | '&' | '=' | '+' | '$' + | ',' | '/' | '?' | '#' | '[' | ']' | ' ' | '\t' | '\x00' -> true + | _ -> false + in + let b = Buffer.create (String.length t) in + let filter char = + let open Buffer in + if is_reserved char then (try (if nth b (pred (length b)) <> '-' then add_char b '-') with Invalid_argument _ -> prerr_endline "reserved") + else add_char b char + in + String.(iter filter (lowercase_ascii t)); + Buffer.contents b + +let alias t = match str "alias" t with "" -> string_alias t.title | x -> x diff --git a/lib/topic_set.ml b/lib/topic_set.ml new file mode 100644 index 0000000..d15ad5e --- /dev/null +++ b/lib/topic_set.ml @@ -0,0 +1,35 @@ +let of_string x = Re.Str.(split (regexp " *> *")) (String.trim x) + +let topic x = + let path = of_string x in + try List.nth path (List.length path - 1) with _ -> "" + +module Map = Map.Make(String) + +let edges x map = try Map.find x map with Not_found -> (String_set.empty, String_set.empty) + +let edges_with_context context (contexts, subtopics) = (String_set.add context contexts, subtopics) +let edges_with_subtopic subtopic (contexts, subtopics) = (contexts, String_set.add subtopic subtopics) + +let rec list_to_map map = function + | [] -> map + | [topic] -> + let edges = edges topic map in + Map.add topic edges map + | context :: topic :: tail -> + let context_edges = edges context map in + let topic_edges = edges topic map in + let map = + map + |> Map.add context (edges_with_subtopic topic context_edges) + |> Map.add topic (edges_with_context context topic_edges) + in + list_to_map map (topic :: tail) + +let to_map map set = + List.fold_left (fun acc elt -> list_to_map acc (of_string elt)) map @@ String_set.elements set + +let roots map = + let root_keys acc (key, (contexts, _topics)) = if String_set.is_empty contexts then key :: acc else acc in + List.fold_left root_keys [] @@ Map.bindings map + diff --git a/logarion.opam b/logarion.opam index 72adce5..e5aec68 100644 --- a/logarion.opam +++ b/logarion.opam @@ -1,29 +1,34 @@ -opam-version: "1.2" -name: "logarion" -version: "0.5.0" -homepage: "https://logarion.orbitalfox.eu" -dev-repo: "git://orbitalfox.eu/logarion" -bug-reports: "mailto:logarion@lists.orbitalfox.eu?subject=[Issue]" -maintainer: "Stavros Polymenis " -authors: "Stavros Polymenis " +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "A texts system" +maintainer: ["fox@orbitalfox.eu"] +authors: ["orbifx"] license: "EUPL" -build: [ - ["dune" "build" "--root" "." "-j" jobs "@install"] -] +homepage: "https://logarion.orbitalfox.eu" +bug-reports: "mailto:logarion@lists.orbitalfox.eu?subject=Issue:" depends: [ - "dune" {build} + "dune" {>= "2.0"} + "re" + "cmdliner" + "bos" "ptime" "uuidm" "uri" - "re" - "emile" - "omd" - "lwt" - "mustache" - "tyxml" - - "cmdliner" - "bos" - "toml" - "fpath" + "text_parse" + "msgpck" ] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git://orbitalfox.eu/logarion" diff --git a/share/config.toml b/share/config.toml deleted file mode 100644 index a29b1a6..0000000 --- a/share/config.toml +++ /dev/null @@ -1,16 +0,0 @@ -#This is an exemplar config file. Use `logarion_cli init` to have one generated. - -[archive] -title = "Logarion" -owner = "Name" -email = "name@example.com" -uuid = "" # Generate UUID using `uuidgen` or https://www.uuidgenerator.net/ - -[web] -static_dir = ".logarion/static" -stylesheets = ["main.css"] -url = "http://localhost:3666" - -[gopher] -static_dir = ".logarion/static" -url = "gopher://localhost" \ No newline at end of file diff --git a/share/sass/fonts/orbitron.sass b/share/sass/fonts/orbitron.sass deleted file mode 100644 index 4d66840..0000000 --- a/share/sass/fonts/orbitron.sass +++ /dev/null @@ -1,15 +0,0 @@ -@font-face - font-family: "Orbitron Medium" - src: url('#{$font-url}/orbitron/orbitron-medium.otf') - -@font-face - font-family: "Orbitron Light" - src: url('#{$font-url}/orbitron/orbitron-light.otf') - -@font-face - font-family: "Orbitron Bold" - src: url('#{$font-url}/orbitron/orbitron-bold.otf') - -@font-face - font-family: "Orbitron Black" - src: url('#{$font-url}/orbitron/orbitron-black.otf') diff --git a/share/sass/layout.sass b/share/sass/layout.sass deleted file mode 100644 index 7274841..0000000 --- a/share/sass/layout.sass +++ /dev/null @@ -1,99 +0,0 @@ -$font-url: "fonts" - -@import fonts/orbitron.sass - -$font-face: "DejaVu Sans" - -body - font-family: $font-face - font-weight: 400 - -main, article - margin: auto - padding: 2pt - -main, article, p, img, h1, h2, h3, h4, h5 - max-width: 75ch - -pre - display: block - overflow: auto - padding-left: 1ch - -blockquote - font-style: italic - -article > .meta - margin: auto 2ch - -article > h1 - text-align: center - -header > h1 - font-family: "Orbitron Light" - -header, footer - text-align: center - -li a, header a, header a:hover - text-decoration: none - -a:hover - text-decoration: underline - -h1, h2, h3, h4, h5 - font-family: "Orbitron Medium" - -footer - clear: both - margin-top: 2em - border-top: 1px dotted - padding: 1em 0 - -fieldset - border: .5mm dashed - -fieldset > p - margin: .5em auto - padding: .5em - float: left - -label - margin: .2em - display: block - -input, textarea - display: block - border: none - border-bottom: .5mm solid - min-width: 100% - -textarea - border: .5mm solid - width: 80ch - height: 40ch - display: block-inline - clear: both - -button - clear: both - display: block - margin: 1em auto - border: .5mm solid - -.topics > li - list-style-type: none - text-transform: capitalize - -ul.listing - padding: 0 1ch - -.listing > li - list-style-type: none - text-transform: none - padding: 4px - margin-bottom: .5em - -.listing p - padding: 0 - margin: 0 diff --git a/share/sass/main-dark.sass b/share/sass/main-dark.sass deleted file mode 100644 index 762faa3..0000000 --- a/share/sass/main-dark.sass +++ /dev/null @@ -1,23 +0,0 @@ -@import layout.sass - -body - background-color: #191b22 - -body, a, header a:visited - color: #f2f2f2 - -pre - border-left: 1mm solid #f2f2f233 - -a - color: PaleTurquoise - -.abstract, .meta - color: #909090 - -article, .listing > li - background-color: rgba(100,100,100,.1) - border: 1px solid rgba(100,100,100,.2) - -.pipe - opacity: .3 diff --git a/share/sass/main-light.sass b/share/sass/main-light.sass deleted file mode 100644 index 94dda39..0000000 --- a/share/sass/main-light.sass +++ /dev/null @@ -1,23 +0,0 @@ -@import layout.sass - -body - background-color: WhiteSmoke - -body, a, header a:visited - color: #191B22 - -pre - border-left: 1mm solid #191B22 - -a - color: SteelBlue - -.abstract, .meta - color: #909090 - -article, .listing > li - background-color: rgba(100,100,100,.1) - border: 1px solid rgba(100,100,100,.2) - -.pipe - opacity: .3 diff --git a/share/static/main.css b/share/static/main.css deleted file mode 100644 index f2a5656..0000000 --- a/share/static/main.css +++ /dev/null @@ -1,131 +0,0 @@ -@font-face { - font-family: "Orbitron Medium"; - src: url("fonts/orbitron/orbitron-medium.otf"); } - -@font-face { - font-family: "Orbitron Light"; - src: url("fonts/orbitron/orbitron-light.otf"); } - -@font-face { - font-family: "Orbitron Bold"; - src: url("fonts/orbitron/orbitron-bold.otf"); } - -@font-face { - font-family: "Orbitron Black"; - src: url("fonts/orbitron/orbitron-black.otf"); } - -body { - font-family: "DejaVu Sans"; - font-weight: 400; } - -main, article { - margin: auto; - padding: 2pt; } - -main, article, p, img, h1, h2, h3, h4, h5 { - max-width: 75ch; } - -pre { - display: block; - overflow: auto; - padding-left: 1ch; } - -blockquote { - font-style: italic; } - -article > .meta { - margin: auto 2ch; } - -article > h1 { - text-align: center; } - -header > h1 { - font-family: "Orbitron Light"; } - -header, footer { - text-align: center; } - -li a, header a, header a:hover { - text-decoration: none; } - -a:hover { - text-decoration: underline; } - -h1, h2, h3, h4, h5 { - font-family: "Orbitron Medium"; } - -footer { - clear: both; - margin-top: 2em; - border-top: 1px dotted; - padding: 1em 0; } - -fieldset { - border: .5mm dashed; } - -fieldset > p { - margin: .5em auto; - padding: .5em; - float: left; } - -label { - margin: .2em; - display: block; } - -input, textarea { - display: block; - border: none; - border-bottom: .5mm solid; - min-width: 100%; } - -textarea { - border: .5mm solid; - width: 80ch; - height: 40ch; - display: block-inline; - clear: both; } - -button { - clear: both; - display: block; - margin: 1em auto; - border: .5mm solid; } - -.topics > li { - list-style-type: none; - text-transform: capitalize; } - -ul.listing { - padding: 0 1ch; } - -.listing > li { - list-style-type: none; - text-transform: none; - padding: 4px; - margin-bottom: .5em; } - -.listing p { - padding: 0; - margin: 0; } - -body { - background-color: #191b22; } - -body, a, header a:visited { - color: #f2f2f2; } - -pre { - border-left: 1mm solid #f2f2f233; } - -a { - color: PaleTurquoise; } - -.abstract, .meta { - color: #909090; } - -article, .listing > li { - background-color: rgba(100, 100, 100, 0.1); - border: 1px solid rgba(100, 100, 100, 0.2); } - -.pipe { - opacity: .3; } diff --git a/share/template/frontpage.mustache b/share/template/frontpage.mustache deleted file mode 100644 index c92e57f..0000000 --- a/share/template/frontpage.mustache +++ /dev/null @@ -1,3 +0,0 @@ -## Articles - -{{recent_texts_listing}} \ No newline at end of file diff --git a/share/template/header.mustache b/share/template/header.mustache deleted file mode 100644 index ab17eed..0000000 --- a/share/template/header.mustache +++ /dev/null @@ -1 +0,0 @@ -{{title}} diff --git a/share/template/item.mustache b/share/template/item.mustache deleted file mode 100644 index 23b82b0..0000000 --- a/share/template/item.mustache +++ /dev/null @@ -1,3 +0,0 @@ -{{date_human}} -{{link}} -{{abstract}} \ No newline at end of file diff --git a/share/template/list.mustache b/share/template/list.mustache deleted file mode 100644 index 196b072..0000000 --- a/share/template/list.mustache +++ /dev/null @@ -1,7 +0,0 @@ -### Topics - -{{topics}} - -### Recent articles - -{{recent_texts_listing}} \ No newline at end of file diff --git a/share/template/note.mustache b/share/template/note.mustache deleted file mode 100644 index d98fe6a..0000000 --- a/share/template/note.mustache +++ /dev/null @@ -1,5 +0,0 @@ -# {{title}} - -{{details}} - -{{body}} \ No newline at end of file diff --git a/src/confix/config.ml b/src/confix/config.ml deleted file mode 100644 index 163661a..0000000 --- a/src/confix/config.ml +++ /dev/null @@ -1,82 +0,0 @@ -module Validation = struct - let empty = [] - - let (&>) report = function None -> report | Some msg -> msg :: report - let (&&>) report = function [] -> report | msgs -> msgs @ report - - let check ok msg = if ok then None else Some msg - - let file_exists ?(msg=(fun s -> (s ^ " is not a file"))) ?(parent_dir=Fpath.v ".") file = - let str = Fpath.(to_string (parent_dir // file)) in - check (Sys.file_exists str) (msg str) - - let is_directory ?(msg=(fun s -> (s ^ " is not a directory"))) dir = - let str = Fpath.to_string dir in - check (Sys.file_exists str && Sys.is_directory str) (msg str) - - let files_exist ?(msg=(fun s -> (s ^ " is not a file"))) ?(parent_dir=Fpath.v ".") files = - let f report file = report &> file_exists ~msg ~parent_dir file in - List.fold_left f empty files - - let terminate_when_invalid ?(print_error=true) = - let error i msg = prerr_endline ("Error " ^ string_of_int i ^ ": " ^ msg) in - function - | [] -> () - | msgs -> if print_error then List.iteri error (List.rev msgs); exit 1 -end - -module Path = struct - let of_string str = - if Sys.file_exists str then - match Fpath.v str with - | path -> Ok path - | exception (Invalid_argument msg) -> Error ("Invalid path " ^ msg) - else Error (str ^ " not found") - - let path_exists x = Fpath.to_string x |> Sys.file_exists - - let conventional_paths = - let paths = - try [ ".logarion"; Sys.getenv "HOME" ^ "/.config/logarion"; "/etc/logarion" ] - with Not_found -> [ ".logarion"; "/etc/logarion" ] - in - List.map Fpath.v paths - - let with_file ?(conventional_paths=conventional_paths) config_file = - let (//) = Fpath.(//) in - let basepath = Fpath.v config_file in - let existing dir = path_exists (dir // basepath) in - try Ok (List.find existing conventional_paths // basepath) - with Not_found -> Error (config_file ^ " not found in: " ^ String.concat ", " (List.map Fpath.to_string conventional_paths)) -end - -let with_default default = function Some x -> x | None -> default - -let with_default_paths default = - function Some ss -> List.map Fpath.v ss | None -> default - -let mandatory = function Some x -> x | None -> failwith "undefined mandatory setting" - -let (&>) a b = match a with Ok x -> b x | Error e -> Error e - -module type Store = sig - type t - val from_path : Fpath.t -> (t, string) result -end - -module Make (S : Store) = struct - include S - - let of_path path = S.from_path path - - let (&>) = (&>) - - let to_record converter = function - | Ok store -> converter store - | Error s -> Error s - - let to_record_or_exit ?(print_error=true) ?(validator=(fun _cfg -> [])) converter store_result = - match to_record converter store_result with - | Ok cfg -> Validation.terminate_when_invalid (validator cfg); cfg - | Error s -> if print_error then prerr_endline s; exit 1 -end diff --git a/src/confix/confixToml.ml b/src/confix/confixToml.ml deleted file mode 100644 index 837ac1e..0000000 --- a/src/confix/confixToml.ml +++ /dev/null @@ -1,23 +0,0 @@ -type t = TomlTypes.table - -let from_path path = - match Toml.Parser.from_filename (Fpath.to_string path) with - | `Error (str, _loc) -> Error str - | `Ok toml -> Ok toml - -open TomlLenses -let (/) a b = (key a |-- table |-- key b) -let (//) a b = (key a |-- table |-- key b |-- table) - -let int toml path = get toml (path |-- int) - -let float toml path = get toml (path |-- float) - -let string toml path = get toml (path |-- string) - -let strings toml path = get toml (path |-- array |-- strings) - -let path toml path = match string toml path with Some s -> Some (Fpath.v s) | None -> None - -let paths toml path = match strings toml path with - Some ss -> Some (List.map Fpath.v ss) | None -> None diff --git a/src/confix/jbuild b/src/confix/jbuild deleted file mode 100644 index 25bd10b..0000000 --- a/src/confix/jbuild +++ /dev/null @@ -1,7 +0,0 @@ -(jbuild_version 1) - -(library - ((name confix) - (public_name logarion.confix) - (libraries (fpath toml)) - )) \ No newline at end of file diff --git a/src/converters/atom.ml b/src/converters/atom.ml deleted file mode 100644 index 02317ee..0000000 --- a/src/converters/atom.ml +++ /dev/null @@ -1,50 +0,0 @@ -let esc = Xml_print.encode_unsafe_char - -let header config url = - let open Logarion.Meta in - let open Logarion.Archive.Configuration in - "" ^ config.title ^ "" - (* TODO: ^ "A subtitle."*) - ^ "" - ^ "" - ^ "urn:uuid:" ^ Id.to_string config.id ^ "" - ^ "" ^ Ptime.to_rfc3339 (Ptime_clock.now ()) ^ "" - -let opt_element tag_name content = - if content <> "" - then "<" ^ tag_name ^ ">" ^ content ^ "" - else "" - -let entry url note = - let open Logarion in - let meta = note.Note.meta in - let u = "note/" ^ Meta.alias meta in - let open Meta in - let authors elt a = - a ^ "" - ^ (opt_element "name" @@ esc elt.Author.name) - ^ (opt_element "uri" @@ esc (Uri.to_string elt.Author.address)) - ^ "" - in - ("" - ^ "" ^ meta.title ^ "" - ^ "urn:uuid:" ^ Meta.Id.to_string meta.uuid ^ "" - ^ "" - ^ "" ^ Date.(meta.date |> listing |> rfc_string) ^ "" - ^ Meta.AuthorSet.fold authors meta.authors "" - ^ opt_element "summary" @@ esc meta.abstract) - ^ Meta.StringSet.fold (fun elt a -> a ^ "") meta.topics "" - ^ "
    " - ^ (Omd.to_html @@ Omd.of_string @@ esc note.Note.body) - ^ "
    " - ^ "    " - -let feed config url note_fn articles = - let fold_valid feed m = match note_fn m.Logarion.Meta.uuid with - | Some note -> feed ^ "\n" ^ entry url note - | None -> feed - in - "\n\n" - ^ header config url - ^ List.fold_left fold_valid "" articles - ^ "" diff --git a/src/converters/html.ml b/src/converters/html.ml deleted file mode 100644 index f9289dd..0000000 --- a/src/converters/html.ml +++ /dev/null @@ -1,133 +0,0 @@ -open Tyxml.Html -open Logarion - -let to_string tyxml = Format.asprintf "%a" (Tyxml.Html.pp ()) tyxml - -let head ~style linker t = - head (title (pcdata t)) [ - link ~rel:[`Stylesheet] ~href:(linker style) (); - link ~rel:[`Alternate] ~href:(linker "/feed.atom") ~a:[a_mime_type "application/atom+xml"] (); - meta ~a:[a_charset "utf-8"] (); - ] - -let default_style = "/static/main.css" - -let page ?(style=default_style) linker head_title header main = - html (head ~style linker head_title) (body [ header; main ]) - -let anchor url content = a ~a:[ a_href (uri_of_string url) ] content - -let div ?(style_class="") content = - let a = if style_class <> "" then [a_class [style_class]] else [] in - div ~a content - -let main = main - -let unescaped_data = Unsafe.data -let data = pcdata -let title = h1 -let header = header - -let pipe = span ~a:[a_class ["pipe"]] [pcdata " | "] - -let meta ~abstract ~authors ~date ~series ~topics ~keywords ~uuid = - let opt_span name value = if String.length value > 0 then (span [pipe; pcdata (name ^ value)]) else pcdata "" in - let authors = List.fold_left (fun acc x -> a ~a:[a_rel [`Author]] [pcdata x] :: acc) [] authors in - [ p ~a:[a_class ["abstract"]] [Unsafe.data abstract]; ] - @ authors - @ [ - pipe; - time ~a:[a_datetime date] [pcdata date]; - pipe; - opt_span "series: " series; - opt_span "topics: " topics; - opt_span "keywords: " keywords; - div [pcdata ("id: " ^ uuid)]; - ] - |> div ~style_class:"meta" - -let note = article - -let text_item path meta = - let module Meta = Logarion.Meta in - tr [ - td [ a ~a:[a_class ["title"]; a_href (path ^ Meta.alias meta ^ ".html")] [data meta.Meta.title] ]; - td [ span [pcdata Meta.(stringset_csv meta.keywords)] ]; - td [ time @@ [unescaped_data Meta.Date.(pretty_date (listing meta.Meta.date))] ]; - ] - -let listing_texts path metas = - let item meta = text_item path meta in - table @@ List.map item metas - -let listing_index path metas = - let items topic = - List.fold_left Meta.(fun a e -> if StringSet.mem topic e.topics then text_item path e :: a else a) - [] metas - in - let item topic = - let module Meta = Logarion.Meta in - [ h3 ~a:[a_id topic] [pcdata topic]; table (items topic)] - in - List.fold_left (fun a e -> a @ item e) [] - @@ Meta.StringSet.elements - @@ List.fold_left Meta.(fun a e -> unique_topics a e) Meta.StringSet.empty metas - -module Renderer = struct - let meta meta e = - let e = List.hd e in - match e with - | "urn_name" -> [unescaped_data @@ "/note/" ^ Logarion.Meta.alias meta] - | "date" | "date_created" | "date_edited" | "date_published" | "date_human" -> - [time @@ [unescaped_data @@ Logarion.Meta.value_with_name meta e]] - | tag -> [unescaped_data @@ Logarion.Meta.value_with_name meta tag] - - let note note e = match List.hd e with - | "body" -> [unescaped_data @@ Omd.to_html @@ Omd.of_string note.Logarion.Note.body] - | _ -> meta note.Logarion.Note.meta e - - let archive archive e = match List.hd e with - | "title" -> [h1 [anchor ("index.html") [data archive.Logarion.Archive.Configuration.title]]] - | tag -> prerr_endline ("unknown tag: " ^ tag); [unescaped_data ""] -end - -let form ymd = - let article_form = - let input_set title input = p [ label [ pcdata title; input ] ] in - let open Note in - let open Meta in - let authors = AuthorSet.to_string ymd.meta.authors in - [ - input ~a:[a_name "uuid"; a_value (Id.to_string ymd.meta.uuid); a_input_type `Hidden] (); - input_set - "Title" - (input ~a:[a_name "title"; a_value ymd.meta.title; a_required ()] ()); - input_set - "Authors" - (input ~a:[a_name "authors"; a_value authors] ()); - input_set - "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 (stringset_csv ymd.meta.keywords)] ()); - input_set - "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] ()); - input_set - "Text" - (textarea ~a:[a_name "body"] (pcdata ymd.body)); - p [ button ~a:[a_button_type `Submit] [pcdata "Submit"] ]; - ] - in - div - [ form - ~a:[a_method `Post; a_action (uri_of_string "/post.note"); a_accept_charset ["utf-8"]] - [ fieldset ~legend:(legend [pcdata "Article"]) article_form ] - ] diff --git a/src/converters/jbuild b/src/converters/jbuild deleted file mode 100644 index 6e3f460..0000000 --- a/src/converters/jbuild +++ /dev/null @@ -1,5 +0,0 @@ -(library - ((name converters) - (public_name logarion.converters) - (libraries (logarion logarion.file mustache tyxml ptime ptime.clock.os)) - )) diff --git a/src/converters/template.ml b/src/converters/template.ml deleted file mode 100644 index 5e18ba5..0000000 --- a/src/converters/template.ml +++ /dev/null @@ -1,81 +0,0 @@ -type t = Mustache.t - -let of_string = Mustache.of_string -let of_file f = File.load f |> of_string - -let string s = [Html.data s] -let section ~inverted:_ _name _contents = prerr_endline "Mustache sections unsupported"; [] -let unescaped _elts = prerr_endline "Mustache unescaped not supported; used escaped instead"; [] -let partial ?indent:_ _name _ _ = prerr_endline "Mustache sections unsupported"; [] -let comment _ = [Html.data ""] -let concat = List.concat - -let escaped_index ~from:_ ~n:_ _metas _e = [Html.data "temp"] - (* match List.hd e with *) - (* | "topics" -> *) - (* let topics = *) - (* ListLabels.fold_left *) - (* ~init:(Logarion.Meta.StringSet.empty) *) - (* ~f:(fun a e -> Logarion.Meta.unique_topics a e ) metas *) - (* in *) - (* Logarion.Meta.StringSet.fold (fun e a -> a ^ "
  • " ^ e ^ "
    • ") topics "" *) - -let header_custom template _linker archive = - Mustache.fold ~string ~section ~escaped:(Html.Renderer.archive archive) ~unescaped ~partial ~comment ~concat template - |> Html.header - -let header_default linker archive = - Html.(header [title [anchor (linker "/") [data archive.Logarion.Archive.Configuration.title]]]) - -let meta meta = - let open Logarion.Meta in - let abstract = meta.abstract in - let authors = List.map (fun elt -> elt.Author.name) @@ AuthorSet.elements meta.authors in - let date = Date.(pretty_date @@ listing meta.date) in - let series = stringset_csv meta.series in - let topics = stringset_csv meta.topics in - let keywords = stringset_csv meta.keywords in - let uuid = Id.to_string meta.uuid in - Html.meta ~abstract ~authors ~date ~series ~topics ~keywords ~uuid - -let body_custom template note = - Mustache.fold ~string ~section ~escaped:(Html.Renderer.note note) ~unescaped ~partial ~comment ~concat template - |> Html.note - -let body_default note = - Html.note - [ Html.title [Html.unescaped_data note.Logarion.Note.meta.Logarion.Meta.title]; (* Don't add title if body contains one *) - meta note.meta; - Html.unescaped_data @@ Omd.to_html @@ Omd.of_string note.Logarion.Note.body ] - -let page ~style linker title header body = - Html.to_string @@ Html.page ~style linker title header body - -let of_config config k = match config with - | Error msg -> prerr_endline ("Couldn't load [templates] section;" ^ msg); None - | Ok c -> - let open Confix.ConfixToml in - path c ("templates" / k) - -let converter default custom = function - | Some p -> - if Confix.Config.Path.path_exists p then custom @@ of_file p - else (prerr_endline @@ "Couldn't find: " ^ Fpath.to_string p; default) - | None -> default - -let header_converter config = converter header_default header_custom @@ of_config config "header" -let body_converter config = converter body_default body_custom @@ of_config config "body" - -let default_style = Html.default_style - -let page_of_index ~style linker header archive metas = - page ~style linker ("Index | " ^ archive.Logarion.Archive.Configuration.title) (header linker archive) (Html.main (Html.listing_index "" metas)) - -let page_of_log ~style linker header archive metas = - page ~style linker ("Log | " ^ archive.Logarion.Archive.Configuration.title) (header linker archive) (Html.main [Html.listing_texts "" metas]) - -let page_of_note ~style linker header body archive note = - page ~style linker note.Logarion.Note.meta.Logarion.Meta.title (header linker archive) (body note) - -let page_of_msg ~style linker header archive title msg = - page ~style linker title (header linker archive) (Html.div [Html.data msg]) diff --git a/src/core/archive.ml b/src/core/archive.ml deleted file mode 100644 index 6dd16cb..0000000 --- a/src/core/archive.ml +++ /dev/null @@ -1,89 +0,0 @@ -module Id = Meta.Id -type alias_t = string - -module Configuration = struct - type t = { - repository : Lpath.repo_t; - title : string; - owner : string; - email : string; - id : Id.t; - } - - let of_config config = - let open Confix in - let open Confix.Config in - let str k = ConfixToml.(string config ("archive" / k)) in - try - Ok { - repository = - (try Lpath.repo_of_string (str "repository" |> with_default ".") - with - | Invalid_argument s -> failwith ("Invalid repository: " ^ s) - | Failure s -> failwith ("Missing repository value: " ^ s)); - title = str "title" |> with_default ""; - owner = str "owner" |> with_default ""; - email = str "email" |> with_default ""; - id = match Id.of_string (str "uuid" |> mandatory) with Some id -> id | None -> failwith "Invalid UUID in config"; - } - with Failure str -> Error str - - let validity config = - let repo = Lpath.fpath_of_repo config.repository in - let open Confix.Config.Validation in - empty - &> is_directory repo -end - -module AliasMap = Meta.AliasMap - -module Make (Store : Store.T) = struct - type t = { - config : Configuration.t; - store : Store.t; - } - - let note_lens note = note - let meta_lens note = note.Note.meta - - let recency_order a b = Meta.(Date.compare a.date b.date) - - let latest archive = - Store.to_list ~order:recency_order meta_lens archive.store - - let listed archive = - let notes = Store.to_list meta_lens archive.store in - List.filter Meta.(fun e -> CategorySet.listed e.categories) notes - - let published archive = - let notes = Store.to_list meta_lens archive.store in - List.filter Meta.(fun e -> CategorySet.published e.categories) notes - - 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 with_topic archive topic = - let notes = Store.to_list ~order:recency_order meta_lens archive.store in - List.filter Meta.(fun e -> StringSet.exists (fun t -> t = topic) e.topics) notes - - let 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 - let containing_fragment e = Re.Str.(string_match (regexp fragment)) (e.Meta.title) 0 in - try Some (List.find containing_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 sublist ~from ~n list = - let aggregate_subrange (i, elms) e = succ i, if i >= from && i <= n then e::elms else elms in - List.fold_left aggregate_subrange (0, []) list |> snd - -end diff --git a/src/core/jbuild b/src/core/jbuild deleted file mode 100644 index 32c1e27..0000000 --- a/src/core/jbuild +++ /dev/null @@ -1,5 +0,0 @@ -(library - ((name logarion) - (public_name logarion) - (libraries (confix omd ptime lwt uuidm uri re.str emile)) - )) diff --git a/src/core/lpath.ml b/src/core/lpath.ml deleted file mode 100644 index 01799a3..0000000 --- a/src/core/lpath.ml +++ /dev/null @@ -1,25 +0,0 @@ -open Fpath -type repo_t = Repo of t -type note_t = Note of { repo: repo_t; basename: t } - -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_note = function Note n -> (fpath_of_repo n.repo // 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 alias_of_note = function Note n -> n.basename |> rem_ext |> to_string -let note_of_alias repo extension alias = note_of_basename repo (alias ^ extension) - -let versioned_basename_of_title ?(version=0) repo extension (title : string) = - let notes_fpath = fpath_of_repo repo in - let basename = v @@ Meta.string_alias 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 diff --git a/src/core/meta.ml b/src/core/meta.ml deleted file mode 100644 index d914999..0000000 --- a/src/core/meta.ml +++ /dev/null @@ -1,222 +0,0 @@ -module Date = struct - type t = { - created: Ptime.t option; - published: Ptime.t option; - edited: Ptime.t option; - } [@@deriving lens { submodule = true }] - - let rfc_string date = match date with Some t -> Ptime.to_rfc3339 t | None -> "" - - let of_string (rfc : string) = match Ptime.of_rfc3339 rfc with - Ok (t,_,_) -> Some t | Error _ -> None - - let listing date = match date.published, date.created with - | Some _, _ -> date.published - | None, Some _ -> date.created - | None, None -> None - - let compare = compare - - let pretty_date = function - | Some t -> Ptime.to_date t |> fun (y, m, d) -> Printf.sprintf "%04d-%02d-%02d" y m d - | None -> "" -end - -module Id = struct - let random_state = Random.State.make_self_init () - type t = Uuidm.t - let compare = Uuidm.compare - let to_string = Uuidm.to_string - let of_string = Uuidm.of_string - let generate ?(random_state=random_state) = Uuidm.v4_gen random_state -end - -module Author = struct - type name_t = string - type address_t = Uri.t - type t = { - name: name_t; - address: address_t; - } [@@deriving lens { submodule = true } ] - - let empty = { name = ""; address = Uri.empty } - - let compare = Pervasives.compare - -end - -module AuthorSet = struct - include Set.Make(Author) - - let to_string authors = - let to_string a = a.Author.name ^ " <" ^ Uri.to_string a.Author.address ^ ">" in - let f elt acc = if String.length acc > 1 then acc ^ ", " ^ to_string elt else to_string elt in - fold f authors "" - - let of_string s = - match Emile.List.of_string s with - | Error _ -> prerr_endline @@ "Error parsing: " ^ s; empty - | Ok emails -> - let to_author = - let module L = List in - let open Emile in - function - | `Group _ -> prerr_endline @@ "Can't deal with groups in author: " ^ s; Author.empty - | `Mailbox { name; local; _ } -> - let s_of_phrase = function `Dot -> "" | `Word w -> (match w with `Atom a -> a | `String s -> s) | `Encoded _ -> "" in - let name = match name with None -> "" | Some phrase -> L.fold_left (fun a e -> a ^ s_of_phrase e) "" phrase in - let address = - L.fold_left (fun a e -> a ^ match e with `Atom a -> a | `String s -> s) "" local ^ "@" (* TODO: Author address unimplemented *) - in - Author.{ name; address = Uri.of_string address } - in - of_list @@ List.map to_author emails -end - -module Category = struct - type t = Draft | Unlisted | Published | Custom of string - - let compare = Pervasives.compare - - let of_string = function - | "draft" -> Draft - | "unlisted" -> Unlisted - | "published" -> Published - | c -> Custom c - - let to_string = function - | Draft -> "draft" - | Unlisted -> "unlisted" - | Published -> "published" - | Custom c -> c -end - -module CategorySet = struct - include Set.Make(Category) - let to_csv set = - let f elt a = - let s = Category.to_string elt in - if a <> "" then a ^ ", " ^ s else s - in - fold f set "" - let categorised categs cs = of_list categs |> (fun s -> subset s cs) - let published = categorised [Category.Published] - 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_alias t = - let is_reserved = function - | '!' | '*' | '\'' | '(' | ')' | ';' | ':' | '@' | '&' | '=' | '+' | '$' - | ',' | '/' | '?' | '#' | '[' | ']' | ' ' | '\t' | '\x00' -> true - | _ -> false - in - let b = Buffer.create (String.length t) in - let filter char = - let open Buffer in - if is_reserved char then (try (if nth b (pred (length b)) <> '-' then add_char b '-') with Invalid_argument _ -> prerr_endline "reserved") - else add_char b char - in - String.(iter filter (lowercase_ascii t)); - Buffer.contents b - -type t = { - title: string; - authors: AuthorSet.t; - date: Date.t; - categories: CategorySet.t; - topics: StringSet.t; - keywords: StringSet.t; - series: StringSet.t; - abstract: string; - uuid: Id.t; - alias: string; - } [@@deriving lens { submodule = true }] - -let blank ?(uuid=(Id.generate ())) () = { - title = ""; - authors = AuthorSet.empty; - date = Date.({ created = None; edited = None; published = None }); - categories = CategorySet.empty; - topics = StringSet.empty; - keywords = StringSet.empty; - series = StringSet.empty; - abstract = ""; - uuid; - alias = ""; - } - -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 AliasMap = Map.Make(String) -module IdMap = Map.Make(Id) - -let alias meta = if meta.alias = "" then string_alias meta.title else meta.alias - -let value_with_name (_meta as m) = function - | "Title" -> m.title - | "Abstract" -> m.abstract - | "Authors" -> AuthorSet.to_string m.authors - | "Date" -> Date.(rfc_string m.date.created) - | "Edited" -> Date.(rfc_string m.date.edited) - | "Published"-> Date.(rfc_string m.date.published) - | "Human" -> Date.(pretty_date @@ listing m.date) - | "Topics" -> stringset_csv m.topics; - | "Categories" -> CategorySet.to_csv m.categories; - | "Keywords" -> stringset_csv m.keywords; - | "Series" -> stringset_csv m.series; - | "ID" -> Id.to_string m.uuid - | "Alias" -> alias m - | e -> invalid_arg e - -let with_kv meta (k,v) = - let list_of_csv = Re.Str.(split (regexp " *, *")) in - let trim = String.trim in - match k with - | "Title" -> { meta with title = trim v } - | "Author" - | "Authors" -> { meta with authors = AuthorSet.of_string (trim v)} - | "Abstract" -> { meta with abstract = trim v } - | "Date" -> { meta with date = Date.{ meta.date with created = Date.of_string v }} - | "Published" -> { meta with date = Date.{ meta.date with published = Date.of_string v }} - | "Edited" -> { meta with date = Date.{ meta.date with edited = Date.of_string 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 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 } - | "ID" -> (match Id.of_string v with Some id -> { meta with uuid = id } | None -> meta) - | "Alias" -> { meta with alias = v } - | k -> prerr_endline ("Unknown key: " ^ k ^ ", with value: " ^ v ); meta - -let to_string (_meta as m) = - let has_len v = String.length v > 0 in - let s field value = if has_len value then field ^ ": " ^ value ^ "\n" else "" in - let a value = if AuthorSet.is_empty value then "" else "Authors: " ^ AuthorSet.to_string value ^ "\n" in - let d field value = match value with - | Some _ -> field ^ ": " ^ Date.rfc_string value ^ "\n" | None -> "" - in - let rows = - [ s "Title" m.title; - a m.authors; - d "Date" m.date.Date.created; - d "Edited" m.date.Date.edited; - d "Published" m.date.Date.published; - s "Topics" (stringset_csv m.topics); - s "Categories" (CategorySet.to_csv m.categories); - s "Keywords" (stringset_csv m.keywords); - s "Series" (stringset_csv m.series); - s "Abstract" m.abstract; - s "ID" (Uuidm.to_string m.uuid); - s "Alias" m.alias - ] - in - String.concat "" rows diff --git a/src/core/note.ml b/src/core/note.ml deleted file mode 100644 index 9ec92f0..0000000 --- a/src/core/note.ml +++ /dev/null @@ -1,47 +0,0 @@ -type t = { - meta: Meta.t; - body: string; - } [@@deriving lens { submodule = true }] - -let blank ?(uuid=(Meta.Id.generate ())) () = { meta = Meta.blank ~uuid (); body = "" } - -let title ymd = - let mtitle = ymd.meta.Meta.title in - if String.length mtitle > 0 then mtitle else - let open Omd in - try List.find (function H1 _ -> true | _ -> false) (Omd.of_string ymd.body) - |> function H1 h -> to_text h | _ -> "" - with Not_found -> "" - -let categorised categs ymd = Meta.CategorySet.categorised categs ymd.meta.Meta.categories - -let with_kv ymd (k,v) = match k with - | "body" -> { ymd with body = String.trim v } - | _ -> { ymd with meta = Meta.with_kv ymd.meta (k,v) } - -let meta_pair_of_string line = match Re.Str.(bounded_split (regexp ": *")) line 2 with - | [ key; value ] -> Re.Str.(replace_first (regexp "^#\\+") "" key), value - | [ key ] -> Re.Str.(replace_first (regexp "^#\\+") "" key), "" - | _ -> prerr_endline line; ("","") - -let meta_of_string front_matter = - let fields = List.map meta_pair_of_string (String.split_on_char '\n' front_matter) in - List.fold_left Meta.with_kv (Meta.blank ()) fields - -exception Syntax_error of string - -let front_matter_body_split s = - if Re.Str.(string_match (regexp ".*:.*")) s 0 - then match Re.Str.(bounded_split (regexp "\n\n")) s 2 with - | front::body::[] -> (front, body) - | _ -> ("", s) - else ("", s) - -let of_string s = - let (front_matter, body) = front_matter_body_split s in - 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 diff --git a/src/core/store.ml b/src/core/store.ml deleted file mode 100644 index 28d8acc..0000000 --- a/src/core/store.ml +++ /dev/null @@ -1,7 +0,0 @@ -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 diff --git a/src/jbuild b/src/jbuild deleted file mode 100644 index 9e74a4a..0000000 --- a/src/jbuild +++ /dev/null @@ -1,16 +0,0 @@ -(executable - ((name logarion_cli) - (public_name logarion_cli) - (modules logarion_cli) - (libraries (logarion logarion.confix logarion.converters logarion.file re.str cmdliner bos)))) - -(install - ((section share) - (files ( - (../share/config.toml as config.toml) - (../share/template/frontpage.mustache as template/frontpage.mustache) - (../share/template/header.mustache as template/header.mustache) - (../share/template/item.mustache as template/item.mustache) - (../share/template/list.mustache as template/list.mustache) - (../share/template/note.mustache as template/note.mustache) -)))) diff --git a/src/logarion_cli.ml b/src/logarion_cli.ml deleted file mode 100644 index 414625e..0000000 --- a/src/logarion_cli.ml +++ /dev/null @@ -1,176 +0,0 @@ -let version = "0.5" -open Cmdliner -open Logarion -module C = Archive.Configuration -module Lpath = Logarion.Lpath - -let conf () = - let module Config = Confix.Config.Make (Confix.ConfixToml) in - let archive_res = - let open Confix.Config in - Confix.Config.Path.with_file "config.toml" - &> Config.from_path - |> Config.to_record C.of_config - in - match archive_res with - | Ok config -> config - | Error str -> prerr_endline str; exit 1 - -let create_dir dir = Bos.OS.Dir.create (Fpath.v dir) - -let create_dir_msg ?(descr="") dir res = - let () = match res with - | Ok true -> print_endline ("Created " ^ descr ^ " directory " ^ dir) - | Ok false -> print_endline ("Reinitialise existing " ^ descr ^ " directory " ^ dir) - | Error (`Msg msg) -> prerr_endline @@ "Failed making " ^ descr ^ ". " ^ msg - in - res - -let copy ?(recursive = false) src dst = - Bos.OS.Cmd.run (Bos.Cmd.(v "cp" %% (on recursive @@ v "-r") % src % dst)) - -let init _force = - let rec create_dirs = function - | [] -> () - | (dir,descr)::tl -> - match create_dir dir |> create_dir_msg ~descr dir with - | Ok _ -> create_dirs tl - | Error _ -> () - in - let dirs = [ - ".logarion", "Logarion"; - ".logarion/static", "static files"; - ".logarion/html-templates", "templates"; - ] - in - let toml_data = - let open Toml in - let open TomlTypes in - of_key_values [ - key "archive", - TTable ( - of_key_values [ - key "title", TString ""; - key "owner", TString (Bos.OS.Env.opt_var "USER" ~absent:""); - key "email", TString (Bos.OS.Env.opt_var "EMAIL" ~absent:""); - key "uuid", TString (Meta.Id.(generate () |> to_string)); - ]); - key "web", - TTable ( - of_key_values [ - key "url", TString "http://localhost:3666"; - key "stylesheets", TArray ( NodeString ["main.css"] ); - key "static_dir", TString ".logarion/static"; - ]); - key "templates", TTable (of_key_values []); - ] - in - create_dirs dirs; - let config_file = open_out "config.toml" in - output_bytes config_file (Toml.Printer.string_of_table toml_data |> Bytes.of_string); - close_out config_file - -let init_term = - let force = - let doc = "Initialise repository even if directory is non empty" in - Arg.(value & flag & info ["f"; "force"] ~doc) - in - Term.(const init $ force), - Term.info - "init" ~doc:"initialise a logarion repository in present directory" - ~man:[ `S "DESCRIPTION"; `P "Create a repository in current directory" ] - -let create_term = - let title = - Arg.(value & pos 0 string "" & info [] ~docv:"TITLE" ~doc:"Title for new article") - in - let f title = - let conf = conf () in - let t = match title with "" -> "Draft" | _ -> title in - let note = - let meta = - let open Meta in - let authors = AuthorSet.singleton Author.({ name = conf.C.owner; address = Uri.of_string conf.C.email }) in - let date = Date.({ created = Some (Ptime_clock.now ()); published = None; edited = None }) in - { (blank ()) with title = t; authors; date } - in - Note.({ (blank ()) with meta }) - in - File.Lwt.with_note (File.store conf.C.repository) note - |> Lwt_main.run - |> ignore - in - Term.(const f $ title), - Term.info "create" - ~doc:"create a new article" - ~man:[ `S "DESCRIPTION"; `P "Create a new article, with title 'Draft' when none provided"] - -let convert directory = - let module Config = Confix.Config.Make (Confix.ConfixToml) in - - let toml_config = - let open Confix.Config in - Path.with_file "config.toml" - |> function Ok cfg -> Config.from_path cfg | Error str -> prerr_endline str; exit 1 - in - let config = Config.to_record_or_exit Logarion.Archive.Configuration.of_config toml_config in - - let module L = Logarion.Archive.Make(File) in - let store = File.store config.repository in - let archive = L.{ config; store } in - let notes = - List.filter Meta.(fun n -> CategorySet.published n.Note.meta.categories) - @@ File.to_list L.note_lens archive.store - in - let metas = - List.filter Meta.(fun m -> CategorySet.published m.categories && CategorySet.listed m.categories) - @@ File.to_list ~order:(L.recency_order) L.meta_lens archive.store - in - - let template_config = toml_config in - let module T = Converters.Template in - let header = T.header_converter template_config in - let body = T.body_converter template_config in - let style = T.default_style in - let linker x = match Fpath.(relativize ~root:(v "/") (v x)) with Some l -> Fpath.to_string l | None -> "" in - let page_of_log metas = T.page_of_log linker header config metas in - let page_of_index metas = T.page_of_index linker header config metas in - let page_of_note note = T.page_of_note linker header body config note in - let path_of_note note = directory ^ "/" ^ Meta.alias note.Note.meta ^ ".html" in - let file_creation path content = - let out = open_out path in - output_string out content; - close_out out - in - match create_dir directory |> create_dir_msg ~descr:"export" directory with - | Error _ -> () - | Ok _ -> - match copy ~recursive:true ".logarion/static" (directory) with - | Ok _ -> - let note_write note = file_creation (path_of_note note) (page_of_note ~style note) in - List.iter note_write notes; - file_creation (directory ^ "/log.html") (page_of_log ~style metas); - file_creation (directory ^ "/index.html") (page_of_index ~style metas); - file_creation (directory ^ "/feed.atom") (Converters.Atom.feed config "/" (L.note_with_id archive) metas) - | Error (`Msg m) -> prerr_endline m - -let convert_term = - let directory = - Arg.(value & pos 0 string "html-conversion" & info [] ~docv:"Directory" ~doc:"Directory to convert to") - in - Term.(const convert $ directory), - Term.info - "convert" ~doc:"convert archive to HTML" - ~man:[ `S "DESCRIPTION"; `P "Create a repository in current directory" ] - -let default_cmd = - Term.(ret (const (`Help (`Pager, None)))), - Term.info "logarion" ~version ~doc:"an article collection & publishing system" - ~man:[ `S "BUGS"; - `P "Submit bugs "; ] - -let cmds = [ init_term; create_term; convert_term ] - -let () = - Random.self_init(); - match Term.eval_choice default_cmd cmds with `Error _ -> exit 1 | _ -> exit 0 diff --git a/src/store/file.ml b/src/store/file.ml deleted file mode 100644 index 05e8857..0000000 --- a/src/store/file.ml +++ /dev/null @@ -1,112 +0,0 @@ -let extensions = [ ".md"; ".org" ] - -open Logarion -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; - Bytes.to_string s - -let note path = Lpath.fpath_of_note path |> load |> Note.of_string - -type t = { repo_path : Lpath.repo_t } - -let note_filetype name = - try Fpath.(mem_ext extensions @@ v name) with - | Invalid_argument _ -> false - -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.string_of_repo repo_path - |> Sys.readdir - |> Array.to_list - |> List.filter note_filetype - |> 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.string_of_repo repo_path - |> Sys.readdir - |> Array.to_list - |> List.filter note_filetype - 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.string_of_repo repo_path - |> Sys.readdir - |> Array.to_list - |> List.filter note_filetype - |> List.fold_left cons_valid_meta [] - |> List.filter (fun note -> Meta.alias 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 = - let open Lwt in - Lwt_io.(open_file ~mode:(Input) f >|= read_lines) - >|= (fun stream -> Lwt_stream.fold (^) stream "") - - let with_note store new_note = - let extension = List.hd extensions in - let open Lwt in - let open Lwt.Infix in - let store = - let write_note out = Lwt_io.write out (Note.to_string new_note) in - 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 extension new_note.meta.title - else previous_path - in - Lwt_io.with_file ~mode:Lwt_io.output (Lpath.string_of_note filepath) write_note - >>= (fun () -> - if previous_path <> filepath - then Lwt_unix.unlink @@ Lpath.string_of_note previous_path - else Lwt.return_unit - ) - | None -> - let filepath = Lpath.versioned_basename_of_title store.repo_path extension new_note.meta.title in - Lwt_io.with_file ~mode:Lwt_io.output (Lpath.string_of_note filepath) write_note - in - store >>= (fun () -> return new_note); -end - -let with_note = Lwt.with_note diff --git a/src/store/jbuild b/src/store/jbuild deleted file mode 100644 index dc2c9f5..0000000 --- a/src/store/jbuild +++ /dev/null @@ -1,7 +0,0 @@ -(jbuild_version 1) - -(library - ((name file) - (public_name logarion.file) - (libraries (logarion lwt lwt.unix)) - ))