Samhain 21

Converter
- type selection
- subdir conversion
- htm extension

Gemini
- index.gmi
- topics and latest
- gmi.atom feed

Add pull (http(s)) operation
- peers.pub.conf and peers.priv.conf

HTML5 format & fixes by Novaburst
Phony target (thanks Gergely)

May

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.
Logarion created texts have part of the UUID in filename.
Logarion's index re-written in Messagepack format. Removed `indices` command. They are generated during `convert`.
This commit is contained in:
orbifx 2021-03-13 18:40:07 +00:00
parent 3d92789cdb
commit 22fe21326f
56 changed files with 1256 additions and 1583 deletions

View File

@ -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/

View File

@ -1,18 +1,18 @@
all: cli
all:
dune build
cli:
dune build src/logarion_cli.exe
dune build cli/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
strip logarion
tar czvf "logarion-$(shell ./logarion --version)-$(shell uname -s)-$(shell uname -m)-$(shell git rev-parse --short HEAD).tar.gz" share logarion
dune subst
dune build
cp _build/default/cli/cli.exe txt
strip txt
tar czvf "logarion-$(shell date -r _build/default/cli/cli.exe "+%y-%m-%d")-$(shell uname -s)-$(shell uname -m)-$(shell git rev-parse --short HEAD).tar.gz" txt ReadMe
rm txt
.PHONY: cli

View File

@ -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: <https://logarion.orbitalfox.eu>
- Mailing list: <https://lists.orbitalfox.eu/listinfo/logarion>
- Matrix (chat): `#logarion:matrix.org`. Via Riot web-app: <https://riot.im/app/#/room/#logarion:matrix.org>
- For issues peferably email to [mailto:logarion@lists.orbitalfox.eu](mailto:logarion@lists.orbitalfox.eu?subject=[Issue] summary-here).
Alternatively <https://gitlab.com/orbifx/logarion/issues>
## 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)

57
cli/atom.ml Normal file
View File

@ -0,0 +1,57 @@
let esc = Converter.Html.esc
let element tag content = "<" ^ tag ^ ">" ^ content ^ "</" ^ tag ^ ">"
let opt_element tag_name content =
if content <> ""
then element tag_name content
else ""
module P = Parsers.Plain_text.Make (Converter.Html)
let id txt = "<id>urn:uuid:" ^ Logarion.(Id.to_string txt.Text.uuid) ^ "</id>"
let title text = "<title>" ^ esc text.Logarion.Text.title ^ "</title>"
let authors text =
let u acc addr = acc ^ element "uri" (Uri.to_string addr) in
let open Logarion in
let fn txt a =
a ^ "<author>" ^ (opt_element "name" @@ esc txt.Person.name)
^ (List.fold_left u "" txt.Person.addresses)
^ "</author>" in
Person.Set.fold fn text.Text.authors ""
let updated txt = let open Logarion in
"<updated>"^ Date.(txt.Text.date |> listing |> rfc_string) ^"</updated>"
let htm_entry base_url text =
let open Logarion in
let u = Text.short_id text in
"<entry><link rel=\"alternate\" href=\"" ^ base_url ^ "/" ^ u ^ ".htm\" />"
^ title text ^ id text ^ updated text ^ authors text
^ (opt_element "summary" @@ esc @@ Text.str "abstract" text)
^ String_set.fold (fun elt a -> a ^ "<category term=\"" ^ esc elt ^ "\"/>") (Text.set "topics" text) ""
^ "<content type=\"xhtml\"><div xmlns=\"http://www.w3.org/1999/xhtml\">"
^ P.of_string text.body ""
^ "</div></content></entry>\n"
let gmi_entry base_url text =
let open Logarion in
let u = Text.short_id text in
"<entry><link rel=\"alternate\" href=\"" ^ base_url ^ "/" ^ u ^ ".gmi\" />"
^ title text ^ id text ^ updated text ^ authors text
^ (opt_element "summary" @@ esc @@ Text.str "abstract" text)
^ String_set.fold (fun elt a -> a ^ "<category term=\"" ^ elt ^ "\"/>") (Text.set "topics" text) ""
^ "</entry>\n"
let feed title archive_id base_url alternate_type texts =
let entry, self = match alternate_type with
| "text/gemini" -> gmi_entry, base_url^"/gmi.atom"
| "text/html" | _ -> htm_entry, base_url^"/feed.atom" in
{|<?xml version="1.0" encoding="utf-8"?><feed xmlns="http://www.w3.org/2005/Atom" xml:base="|} ^ base_url ^ {|"><title>|}
^ title ^ {|</title><link rel="alternate" type="|} ^ alternate_type ^ {|" href="|}
^ base_url ^ {|/" /><link rel="self" type="application/atom+xml" href="|}
^ self ^ {|" /><id>urn:uuid:|} ^ Logarion.Id.to_string archive_id ^ "</id><updated>"
^ Ptime.to_rfc3339 (Ptime_clock.now ()) ^ "</updated>\n"
^ List.fold_left (fun acc t -> acc ^ entry base_url t) "" texts
^ "</feed>"

142
cli/cli.ml Normal file
View File

@ -0,0 +1,142 @@
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 order_opt reverse_opt number_opt values_opt authors_opt topics_opt =
match A.of_path (Sys.getcwd ()) with
| Error msg -> prerr_endline msg
| Ok archive ->
let predicates = A.predicate A.authored authors_opt @ A.predicate A.topics topics_opt in
let predicate text = List.fold_left (fun a e -> a && e text) true predicates in
let print_fold ~predicate fn =
let ts = A.fold ~predicate fn String_set.empty archive in
String_set.iter (print_endline) ts
in
let list_text (t, fname) = print_endline (Text.short_id t ^ " " ^ t.Text.title ^ "\t" ^ fname) in
match values_opt with
| Some "topics" -> print_fold ~predicate (fun a (e,_) -> (String_set.union a (Text.set "topics" e)))
| Some "authors" ->
let s = A.fold ~predicate (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
| None -> match order_opt with
| false -> A.iter ~predicate list_text archive
| true ->
let order = match reverse_opt with true -> A.newest | false -> A.oldest in
match number_opt with
| Some number -> A.iter ~predicate ~order ~number list_text archive
| None -> A.iter ~predicate ~order list_text archive
let list_term =
let reverse = Arg.(value & flag & info ["r"] ~doc:"reverse order") in
let time = Arg.(value & flag & info ["t"] ~doc:"Sort by time, newest first") in
let number = Arg.(value & opt (some int) None & info ["n"] ~docv:"NUMBER" ~doc:"number of entries to list") in
let values = Arg.(value & opt (some string) None & info ["values"] ~docv:"HEADER-FIELD" ~doc:"unique values for header field") in
let authed = Arg.(value & opt (some string) None & info ["authored"] ~docv:"AUTHORS" ~doc:"texts by authors") in
let topics = Arg.(value & opt (some string) None & info ["topics"] ~docv:"TOPICS" ~doc:"texts with topics") in
Term.(const text_list $ time $ reverse $ number $ values $ authed $ topics),
Term.info "list" ~doc:"list texts" ~man:[ `S "DESCRIPTION"; `P "List texts" ]
let print_last search_mine =
let last a ((t,_) as pair) = match a with None -> Some pair
| Some (t', _) as pair' -> if Text.newest t t' > 0 then Some pair else pair' in
match A.of_path (Sys.getcwd ()) with
| Error msg -> prerr_endline msg
| Ok archive ->
let last_mine a ((t,_) as pair) =
let open Text in
match a with None ->
if Person.Set.subset archive.A.archivists t.authors then Some pair else None
| Some (t', _) as pair' ->
if Text.newest t t' > 0 && Person.Set.subset archive.A.archivists t'.authors
then Some pair else pair'
in
match A.fold (if search_mine then last_mine else last) None archive with
| Some (_,f) -> print_endline f | None -> ()
let last_term =
let mine = Arg.(value & flag & info ["mine"] ~doc:"last text authored by me") in
Term.(const print_last $ mine),
Term.info "last" ~doc:"most recent test" ~man:[ `S "DESCRIPTION"; `P "Print the filename of most recent text" ]
let split_filetypes files =
let acc (dirs, files) x = if Sys.is_directory x then (x::dirs, files) else (dirs, x::files) in
List.fold_left acc ([],[]) files
let file files = match A.of_path "." with
| Error msg -> prerr_endline msg
| Ok _archive ->
let dirs, files = split_filetypes files in
let _link_as_named dir file = Unix.link file (dir ^"/"^ file) in
let link_with_id dir file =
match File_store.to_text file with Error s -> prerr_endline s
| Ok t -> Unix.link file (dir ^"/"^ String.sub (Id.to_string (t.Text.uuid)) 0 8 ^".txt")
in
let link = link_with_id in
List.iter (fun d -> List.iter (link d) files) dirs
let file_term =
let files = Arg.(value & pos_all string [] & info [] ~doc:"filenames") in
let doc = "file texts in directories" in
let man = [ `S "DESCRIPTION"; `P doc ] in
Term.(const file $ files), Term.info "file" ~doc ~man
let unfile files = match A.of_path "." with
| Error msg -> prerr_endline msg
| Ok _archive ->
let dirs, files = split_filetypes files in
let unlink dir file = try Unix.unlink (dir ^"/"^ file) with Unix.(Unix_error(ENOENT,_,_))-> () in
List.iter (fun d -> List.iter (unlink d) files) dirs
let unfile_term =
let files = Arg.(value & pos_all string [] & info [] ~doc:"filenames") in
let doc = "unfile texts from directories" in
let man = [ `S "DESCRIPTION"; `P doc ] in
Term.(const unfile $ files), Term.info "unfile" ~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 text repository in present directory" in
let man = [ `S "DESCRIPTION"; `P "Start an archive in current directory" ] in
Term.(const init $ force), Term.info "init" ~doc ~man
let new_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 _code = Sys.command ("$EDITOR " ^ filepath) in
()
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 "new" ~doc:"create a new article" ~man
let default_cmd =
let doc = "text archival & publishing" in
let man = [ `S "BUGS"; `P "Submit bugs <mailto:logarion@lists.orbitalfox.eu?subject=Issue: " ] in
Term.(ret (const (`Help (`Pager, None)))), Term.info "txt" ~version ~doc ~man
let cmds = [ init_term; new_term; file_term; unfile_term; list_term; last_term; Convert.term; Http.pull_term ]
let () =
Random.self_init();
match Term.eval_choice default_cmd cmds with `Error _ -> exit 1 | _ -> exit 0

90
cli/convert.ml Normal file
View File

@ -0,0 +1,90 @@
open Logarion
module A = Archive.Make (Logarion.File_store)
let convert_modified 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); true) else false
let word_fname dir text = dir ^ "/" ^ Text.alias text
let id_fname dir text = dir ^ "/" ^ Text.short_id text
let writer types dir name (text,store_item) = (* todo: single_parser -> [files] *)
(* convert_modified store_item idfilename (fun _title -> Text.to_string) text.title text;*)
let h = if "htm" = types || "all" = types then
convert_modified store_item (id_fname dir text ^ ".htm") Html.page name text
else false in
let g = if "gmi" = types || "all" = types then
convert_modified store_item (id_fname dir text ^ ".gmi") Gemini.page name text
else false in
h || g
let index_writer types noindex dir archive topic_roots topic_map texts =
let name = archive.A.name in
let file path = File_store.file (dir ^ path) in
file "/index.pck" (Header_pack.pack archive texts);
if not noindex && ("htm" = types || "all" = types) then (
let index_name = try Store.KV.find "HTML-index" archive.File_store.kv
with Not_found -> "index.html" in
if index_name <> "" then
file ("/"^index_name) (Html.topic_main_index name topic_roots texts);
file "/index.date.htm" (Html.date_index name texts);
List.iter
(fun topic -> file ("/index." ^ topic ^ ".htm")
(Html.topic_sub_index name topic_map topic texts))
topic_roots;
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 "text/html" texts)
);
if not noindex && ("gmi" = types || "all" = types) then (
let index_name = try Store.KV.find "Gemini-index" archive.File_store.kv
with Not_found -> "index.gmi" in
if index_name <> "" then
file ("/"^index_name) (Gemini.topic_main_index name topic_roots texts);
file "/index.date.gmi" (Gemini.date_index name texts);
List.iter
(fun topic -> file ("/index." ^ topic ^ ".gmi")
(Gemini.topic_sub_index name topic_map topic texts))
topic_roots;
let base_url = try Store.KV.find "GEMINI-URL" archive.File_store.kv
with Not_found -> prerr_endline "Missing `GEMINI-URL:` in config"; "" in
file "/gmi.atom" (Atom.feed archive.A.name archive.A.id base_url "text/gemini" texts)
)
let txt_writer types dir name ((text, _store_item) as r) =
match Text.str "Content-Type" text with
| "" | "text/plain" -> writer types dir name r
| x -> prerr_endline ("Can't convert Content-Type: "^x^" file: " ^text.Text.title); false
let convert_all types noindex dir archive =
let name = archive.A.name in
let fn (ts,ls,acc) ((elt,_) as r) =
(Topic_set.to_map ts (Text.set "topics" elt)),
elt::ls, if txt_writer types dir name r then acc+1 else acc in
let empty = Topic_set.Map.empty in
let topic_map, texts, count = A.(fold ~order:newest fn (empty,[],0) archive) in
let topic_roots = Topic_set.roots topic_map in
index_writer types noindex dir archive topic_roots topic_map texts;
print_endline @@ "Converted: " ^ string_of_int (count)
^ "\nIndexed: " ^ string_of_int (List.length texts);
Ok ()
let convert_dir types noindex cmd_dir =
let (>>=) = Result.bind in
let with_dir 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 "" -> Error "unspecified export dir" | x -> Ok x)
>>= fun dir -> with_dir dir
>>= fun _ -> convert_all types noindex dir { archive with store = dir })
|> 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
let types = Arg.(value & opt string "all" & info ["t"; "type"] ~docv:"TYPES" ~doc:"Convert to type") in
let noindex = Arg.(value & flag & info ["noindex"] ~doc:"don't write an index when converting") in
Term.(const convert_dir $ types $ noindex $ directory),
Term.info "convert" ~doc:"convert archive" ~man:[ `S "DESCRIPTION"; `P "Convert Logarion archive" ]

5
cli/dune Normal file
View File

@ -0,0 +1,5 @@
(executable
(name cli)
(public_name txt)
(modules cli convert html atom gemini)
(libraries logarion logarion.http re.str cmdliner bos ptime ptime.clock.os text_parse.converter text_parse.parsers msgpck))

73
cli/gemini.ml Normal file
View File

@ -0,0 +1,73 @@
let page _archive_title text =
let open Logarion.Text in
"# " ^ text.title
^ "\nAuthors: " ^ Logarion.Person.Set.to_string text.authors
^ "\nDate: " ^ 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.short_id m ^ ".gmi " ^
Logarion.(Date.(pretty_date (listing m.date)) ^ " " ^ m.title) ^ "\n")
("# " ^ title ^ "\n\n## Posts by date\n\n") meta_list
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.Text.short_id m ^ ".gmi "
^ Logarion.(Date.(pretty_date (listing m.Text.date))) ^ " "
^ m.Logarion.Text.title ^ "\n")
"" meta_list
let topic_link root topic =
"=> index." ^ root ^ ".gmi " ^ String.capitalize_ascii topic ^ "\n"
let text_item path meta =
let open Logarion in
"=> " ^ path ^ Text.short_id meta ^ ".gmi "
^ Date.(pretty_date (listing meta.Text.date)) ^ " "
^ meta.Text.title ^ "\n"
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 -> "## " ^ String.capitalize_ascii topic ^ "\n\n" ^ x
in
item_group topic_roots
let fold_topic_roots topic_roots =
let list_item root t = topic_link root t in
List.fold_left (fun a x -> a ^ list_item x x) "" (List.rev topic_roots)
let topic_main_index title topic_roots metas =
"# " ^ title ^ "\n\n"
^ (if topic_roots <> [] then ("## Main topics\n\n" ^ fold_topic_roots topic_roots) else "")
^ "\n## Latest\n\n" ^ to_dated_links ~limit:10 metas
^ "\n=> index.date.gmi More by date\n"
let topic_sub_index title topic_map topic_root metas =
"# " ^ title ^ "\n\n"
^ listing_index topic_map [topic_root] "" metas

125
cli/html.ml Normal file
View File

@ -0,0 +1,125 @@
let wrap (title:string) (subtitle:string) body =
{|<!DOCTYPE HTML>|}
^ {|<html><head><title>|}
^ subtitle ^ " | " ^ title
^ {|</title><link rel="stylesheet" href="main.css">|}
^ {|<link rel="alternate" href="feed.atom" type="application/atom+xml">|}
^ {|<meta charset="utf-8"/>|}
^ {|<meta name="viewport" content="width=device-width, initial-scale=1.0">|}
^ {|</head><body><header><a href=".">|} ^ title
^ {|</a> <nav><a href="feed.atom" id="feed">feed</a></nav></header>|} ^ body
^ "</body></html>"
let topic_link root topic =
let replaced_space = String.map (function ' '->'+' | x->x) in
{|<a href="index.|} ^ root ^ {|.htm#|} ^ replaced_space topic ^ {|">|}
^ String.capitalize_ascii topic ^ "</a>"
let page 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 "<dt>" ^ key ^ "<dd>" ^ value else "" in
(* let author acc auth = sep_append acc Person.(auth.name ^ " ") in*)
let authors = (Person.Set.to_string text.authors ^ " ") in
let keywords = str_set "keywords" text in
let header =
let time x = {|<time datetime="|} ^ x ^ {|">|} ^ x ^ "</time>" 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
"<article><header><dl>"
^ 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)
^ {|</dl></header><pre style="white-space:pre-wrap">|} in
wrap archive_title text.title ((T.of_string text.body header) ^ "</pre></article>")
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)) ^ " ")
^ {|<a href="|} ^ Logarion.Text.short_id m ^ {|.htm">|} ^ m.Logarion.Text.title ^ "</a><br>")
"" 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 = "<li>" ^ topic_link root t in
"<nav><h2>Main topics</h2>"
^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
^ "</ul></nav>"
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) "<ul>" topic
^ "</ul>"
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 String.capitalize_ascii t
in
"<li>" ^ item ^ sub_items root t
in
"<nav><h2>Topics</h2>"
^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
^ "</ul></nav>"
let text_item path meta =
let open Logarion in
"<time>" ^ Date.(pretty_date (listing meta.Text.date))
^ {|</time> <a href="|} ^ path ^ Text.short_id meta ^ {|.htm">|} ^ meta.Text.title
^ "</a><br>"
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 -> {|<h2 id="|} ^ topic ^ {|">|} ^ String.capitalize_ascii topic ^ "</h2>" ^ x
in
"<nav><h1>Texts</h1>" ^ item_group topic_roots ^ "</nav>"
let topic_main_index title topic_roots metas =
wrap title "Topics"
(fold_topic_roots topic_roots
^ "<nav><h1>Latest</h1>" ^ to_dated_links ~limit:10 metas
^ {|<a href="index.date.htm">More by date</a></nav>|} )
let topic_sub_index title topic_map topic_root metas =
wrap title topic_root
(fold_topics topic_map [topic_root] metas
(* ^ {|<a href=".atom" id="feed">|}^ String.capitalize_ascii topic_root ^{| feed </a>|}*)
^ listing_index topic_map [topic_root] "" metas)

View File

@ -1,3 +0,0 @@
Logarion
Ymd
Web

16
dune-project Normal file
View File

@ -0,0 +1,16 @@
(lang dune 2.0)
(name logarion)
(homepage "https://logarion.orbitalfox.eu")
(source (uri git://orbitalfox.eu/logarion))
(license EUPL-1.2)
(authors "orbifx")
(maintainers "fox@orbitalfox.eu")
(bug_reports "mailto:logarion@lists.orbitalfox.eu?subject=Issue:")
(generate_opam_files true)
(package
(name logarion)
(synopsis "Texts archival and exchange")
(depends re cmdliner bos ptime uuidm uri text_parse msgpck cohttp-lwt-unix tls))

4
http/dune Normal file
View File

@ -0,0 +1,4 @@
(library
(name http)
(public_name logarion.http)
(libraries logarion uri cmdliner lwt cohttp cohttp-lwt cohttp-lwt-unix tls msgpck))

143
http/http.ml Normal file
View File

@ -0,0 +1,143 @@
let http_body fn uri =
let open Lwt in
let open Cohttp_lwt_unix in
Client.get uri >>= fun (headers, body) ->
body |> Cohttp_lwt.Body.to_string >|= fun body -> fn (headers, body)
let response (headers, body) =
let open Cohttp in
match Header.get (headers |> Response.headers) "content-type" with
| Some "application/msgpack" | Some "application/octet-stream"
| Some "text/plain" | Some "text/plain; charset=utf-8" -> Ok body
| Some x -> Error ("Invalid content-type: " ^ x)
| None -> Ok body
let http_apply fn uri = Lwt_main.run (http_body fn uri)
module S = Set.Make(String)
(*let is_selected sl =*)
(* let check str a b c = Option.(fold ~none:(is_none b && is_none c) ~some:(fun x -> x = str) a) in*)
(* function*)
(* | `Author s -> check s sl.authors sl.topics*)
(* | `Topic s -> check s sl.topics sl.authors*)
(* TODO: parse using Header_pack *)
let sub_id text = Logarion.(String.sub (text.Text.uuid |> Id.to_string) 0 8)
let fname dir text = dir ^ sub_id text ^ ".txt"
let newer time id dir =
match Logarion.File_store.to_text @@ Filename.concat dir (String.sub (Logarion.Id.to_string id) 0 8 ^ ".txt") with
| Error x -> prerr_endline x; true
| Ok txt -> time > (Logarion.(Header_pack.date (Date.listing txt.date)))
| exception (Sys_error _) -> true
let pull_text url dir id =
let path = Uri.path url in
let u = Uri.with_path url (path ^ "/" ^ String.sub (Logarion.Id.to_string id) 0 8 ^ ".txt") in
match http_apply response u with
| Error msg -> prerr_endline @@ " Failed " ^ Uri.to_string u ^ " " ^ msg
| Ok txt ->
match Logarion.Text.of_string txt with
| Error s -> prerr_endline s
| Ok text ->
let file = open_out_gen [Open_creat; Open_trunc; Open_wronly] 0o640 (fname dir text) in
output_string file txt; close_out file
(*TODO: adapt Archive predication function to work with free sets*)
let parse_index _is_selected fn url p =
let open Logarion.Header_pack in
let dir = "peers/" ^ match Uri.host url with
None -> "local/" ^ Uri.path url | Some s -> s ^ Uri.path url ^ "/" in
Printf.printf "%s => %s\n" p.info.name dir;
(match Msgpck.to_list p.peers with [] -> () | ps ->
print_string " peers: ";
List.iter (fun x -> print_string (" " ^ Msgpck.to_string x)) ps;
print_newline ());
match Msgpck.to_list p.texts with
| [] -> print_endline ", has empty index"
| texts ->
match Bos.OS.Dir.create ~mode:0o740 (Fpath.v dir) with
| Error (`msg s) -> prerr_endline ("Error making domain dir:" ^ s);
| _ ->
let numof_texts = string_of_int @@ List.length texts in
let text_num_len = String.length numof_texts in
let of_pck i x =
Printf.printf "\r%*d/%s %!" text_num_len (i+1) numof_texts;
match x with
| Msgpck.List (id::time::title::_authors::_topics) ->
(match Logarion.Id.of_bytes Msgpck.(to_bytes id) with
| None -> prerr_endline ("Invalid id for " ^ Msgpck.to_string title)
| Some id ->
let t = match time with Msgpck.Int i -> Int32.of_int i | Msgpck.Uint32 i -> i | x -> Msgpck.to_uint32 x in
if newer t id dir then fn url dir id)
| _ -> prerr_endline ("Invalid record structure") in
List.iteri of_pck texts;
print_newline ()
let pull_index url _authors _topics =
let index_url = Uri.(with_path url (path url ^ "/index.pck")) in
match http_apply response index_url with
| Error msg -> prerr_endline @@ "Failed index request for " ^ Uri.to_string index_url ^ " " ^ msg
| Ok body ->
let _i, pack = Msgpck.StringBuf.read body in
(* let predicates =*)
(* A.predicate A.authored authors_opt*)
(* @ A.predicate A.topics topics_opt*)
(* in*)
let is_selected text = List.fold_left (fun a e -> a && e text) true [](*predicates*) in
match Logarion.Header_pack.unpack pack with None -> ()
| Some headers -> parse_index is_selected pull_text url headers
module Msg = struct
type t = Ptime.t * string
let compare (x0,y0) (x1,y1) = match Ptime.compare x1 x0 with 0 -> String.compare y0 y1 | c -> c
end
module MsgSet = Set.Make(Msg)
let pull_msgs url _authors _topics = match http_apply response url with
| Error msg -> prerr_endline @@ "Failed index request for " ^ Uri.(to_string url) ^ " " ^ msg
| Ok body ->
let rec fold_msgs s a fn =
let t, msg = Scanf.bscanf s "%s %s@\n" (fun t m -> t, m) in
if t <> "" then fold_msgs s (fn a t msg) fn else a
in
let s = Scanf.Scanning.from_string body in
let msgs = MsgSet.empty in
let date_string t = Ptime.to_date t |>
fun (y, m, d) -> Printf.sprintf "%04d-%02d-%02d" y m d in
let msgs = fold_msgs s msgs
(fun msgs t m -> match Ptime.of_rfc3339 t with
| Ok (v,_,_) -> let open MsgSet in
let msgs = if cardinal msgs > 1 then remove (max_elt msgs) msgs else msgs in
add (v,m) msgs
| _ -> msgs) in
print_endline ("\n┌────=[ " ^ Uri.to_string url);
MsgSet.iter
(fun (t,m) -> print_endline
("" ^ date_string t ^ "\n" ^ m ^ "\n└─────────")) msgs
let pull_url url = match Uri.of_string url with
| x when x = Uri.empty -> (fun _ _ -> ())
| x when Uri.scheme x = Some "msg+http" -> pull_msgs Uri.(with_scheme x (Some "http"))
| x when Uri.scheme x = Some "msg+https"-> pull_msgs Uri.(with_scheme x (Some "https"))
| x -> pull_index x
let pull_list auths topics =
let pull peer_url () = pull_url peer_url auths topics in
let open Logarion.Peers in
fold_file pull () public_fname;
fold_file pull () private_fname
let pull = function "" -> pull_list | x -> pull_url x
open Cmdliner
let pull_term =
let authors = Arg.(value & opt (some string) None & info ["a"; "authors"] ~docv:"AUTHORS" ~doc:"select authors") in
let topics = Arg.(value & opt (some string) None & info ["t"; "topics"] ~docv:"TOPICS" ~doc:"select topics") in
let url = Arg.(value & pos 0 string "" & info [] ~docv:"URL" ~doc:"HTTP URL of Logarion") in
Term.(const pull $ url $ authors $ topics),
Term.info "pull" ~doc:"pull listed texts" ~man:[ `S "DESCRIPTION"; `P "Pull texts from archive at address"]

33
lib/archive.ml Normal file
View File

@ -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

22
lib/category.ml Normal file
View File

@ -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

8
lib/date.ml Normal file
View File

@ -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 -> ""

4
lib/dune Normal file
View File

@ -0,0 +1,4 @@
(library
(name logarion)
(public_name logarion)
(libraries ptime uuidm uri re.str bos text_parse text_parse.parsers msgpck))

166
lib/file_store.ml Normal file
View File

@ -0,0 +1,166 @@
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 extension = ".txt"
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 file path content = let out = open_out path in
output_string out content; close_out out
let (//) a b = a ^ "/" ^ b
let to_text path =
if Filename.extension path = extension then
(to_string path |> Text.of_string |> Result.map_error (fun m -> path ^": "^ m))
else Error "Not txt"
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 (Filename.concat store f)
with Ok t -> fn store t f | Error s -> prerr_endline s in
List.iter link paths
let iter_valid_text pred fn p =
match to_text p with Error _ -> () | Ok t -> if pred t then fn (t, p)
let fold_valid_text pred fn acc p =
match to_text p with Error _ -> acc | Ok t -> if pred t then fn acc (t, p) else acc
let list_fs dir =
let rec loop result = function
| [] -> result
| f::fs when Sys.is_directory f ->
Array.map (Filename.concat f) (Sys.readdir f)
|> Array.to_list |> List.append fs |> loop result
| f::fs -> loop (f::result) fs
in loop [] [dir]
let list_take n =
let rec take acc n = function [] -> []
| x::_ when n = 1 -> x::acc
| x::xs -> take (x::acc) (n-1) xs
in take [] n
let iter ?(predicate=fun _ -> true) ?order ?number fn {store;_} =
match order with
| None -> List.iter (iter_valid_text predicate fn) @@ list_fs store
| Some comp ->
List.iter fn
@@ (match number with None -> (fun x -> x) | Some n -> list_take n)
@@ List.fast_sort comp
@@ List.fold_left (fold_valid_text predicate (fun a e -> List.cons e a)) []
@@ list_fs store
let fold ?(predicate=fun _ -> true) ?order ?number fn acc {store;_} =
match order with
| None -> List.fold_left (fold_valid_text predicate fn) acc @@ list_fs store
| Some comp ->
List.fold_left fn acc
@@ (match number with None -> (fun x -> x) | Some n -> list_take n)
@@ List.fast_sort comp
@@ List.fold_left (fold_valid_text predicate (fun a e -> List.cons e a)) []
@@ list_fs store
let with_id { store; _ } id =
let matched acc path =
match to_text path with
| Error x -> prerr_endline x; acc
| Ok text when text.Text.uuid <> id -> acc
| Ok text ->
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 List.fold_left matched (Ok None) (list_fs 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 with_text {store;_} new_text =
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_config () =
"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"] 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_config ());
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 = try Sys.getenv "LOGARION_DIR" with Not_found -> "."
}
)

84
lib/header_pack.ml Normal file
View File

@ -0,0 +1,84 @@
type info_t = { version: int; name: string; archivists: string list }
type text_t = { id: Msgpck.t; time: Msgpck.t; title: Msgpck.t; authors: Msgpck.t }
type t = { info: info_t; fields: string list; texts: Msgpck.t; peers: Msgpck.t }
let of_id id = Msgpck.Bytes (Id.to_bytes id)
let to_id pck_id = Id.of_bytes Msgpck.(to_bytes pck_id)
let person p = Msgpck.String (Person.to_string p)
let persons ps = List.rev @@ Person.Set.fold (fun p a -> person p :: a) ps []
let of_set field t =
List.rev @@ String_set.fold (fun s a -> Msgpck.String s :: a) (Text.set field t) []
let date = function
| None -> Int32.zero
| Some date ->
let days, ps = Ptime.Span.to_d_ps (Ptime.to_span date) in
Int32.add Int32.(mul (of_int days) 86400l) Int64.(to_int32 (div ps 1000000000000L))
let to_sec = function
Msgpck.Int i -> Int32.of_int i | Msgpck.Uint32 i -> i | x -> Msgpck.to_uint32 x
let public_peers () =
Peers.fold_file (fun x a -> Msgpck.String x :: a) [] Peers.public_fname
let fields = Msgpck.(List [String "id"; String "time"; String "title"; String "authors"; String "topics"])
let to_fields fieldpack = List.map Msgpck.to_string (Msgpck.to_list fieldpack)
let to_pack a t =
let open Text in
Msgpck.(List [
Bytes (Id.to_bytes t.uuid); of_uint32 (date (Date.listing t.date));
String t.title; List (persons t.authors); List (of_set "topics" t)
]) :: a
let pack_filename ?(filename="index.pck") archive =
let dir = Store.KV.find "Export-Dir" archive.File_store.kv in (*raises Not_found*)
dir ^ "/" ^ filename
let to_info = function
| Msgpck.List (v::n::a::[]) ->
let archivists = List.map Msgpck.to_string (Msgpck.to_list a) in
Msgpck.({version = to_int v; name = to_string n; archivists})
| _ -> invalid_arg "Pack header"
let unpack = function
| Msgpck.List (i::f::texts::[]) ->
Some { info = to_info i; fields = to_fields f; texts; peers = Msgpck.List [] }
| Msgpck.List (i::f::texts::peers::[]) ->
Some { info = to_info i; fields = to_fields f; texts; peers }
| _ -> None
let list filename = try
let texts_list = function
| Msgpck.List (_info :: _fields :: [texts]) -> Msgpck.to_list texts
| _ -> prerr_endline "malformed feed"; [] in
let _pos, data = Msgpck.StringBuf.read @@ File_store.to_string filename in
Ok (texts_list data)
with Not_found -> Error "unspecified export dir"
let contains text = function
| Msgpck.List (id::_time::title::_authors::_topics::[]) ->
(match Id.of_bytes (Msgpck.to_bytes id) with
| None -> prerr_endline ("Invalid id for " ^ Msgpck.to_string title); false
| Some id -> text.Text.uuid = id)
| _ -> prerr_endline ("Invalid record pattern"); false
let pack archive records =
let header_pack = List.fold_left to_pack [] records in
let info = Msgpck.(List [Int 0; String archive.File_store.name; List (persons archive.archivists)]) in
Bytes.to_string @@ Msgpck.Bytes.to_string
(List [info; fields; Msgpck.List header_pack; Msgpck.List (public_peers ())])
let add archive records =
let fname = pack_filename archive in
let append published (t, _f) = if List.exists (contains t) published then published else to_pack published t in
match list fname with Error e -> prerr_endline e | Ok published_list ->
let header_pack = List.fold_left append published_list records in
let archive = Msgpck.(List [Int 0; String archive.File_store.name;
List (persons archive.archivists)]) in
File_store.file fname @@ Bytes.to_string
@@ Msgpck.Bytes.to_string (List [archive; fields; Msgpck.List header_pack])
let unpublish _archive _records = ()

9
lib/id.ml Normal file
View File

@ -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

9
lib/peers.ml Normal file
View File

@ -0,0 +1,9 @@
let public_fname = "peers.pub.conf"
let private_fname = "peers.priv.conf"
let fold_file fn init file = match open_in file with
| exception (Sys_error msg) -> prerr_endline msg; init
| file ->
let rec read acc = try read (fn (input_line file) acc)
with End_of_file -> close_in file; acc in
read init

31
lib/person.ml Normal file
View File

@ -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

17
lib/store.ml Normal file
View File

@ -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 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) -> ?number:int
-> (record_t -> unit) -> archive_t -> unit
val fold: ?predicate:(Text.t -> bool) -> ?order:(record_t -> record_t -> int) -> ?number:int
-> ('a -> record_t -> 'a) -> 'a -> archive_t -> 'a
end

15
lib/string_set.ml Normal file
View File

@ -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

102
lib/text.ml Normal file
View File

@ -0,0 +1,102 @@
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
let short_id ?(len=8) t = String.sub (Id.to_string t.uuid) 0 len

35
lib/topic_set.ml Normal file
View File

@ -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

View File

@ -1,29 +1,36 @@
opam-version: "1.2"
name: "logarion"
version: "0.5.0"
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
synopsis: "Texts archival and exchange"
maintainer: ["fox@orbitalfox.eu"]
authors: ["orbifx"]
license: "EUPL-1.2"
homepage: "https://logarion.orbitalfox.eu"
dev-repo: "git://orbitalfox.eu/logarion"
bug-reports: "mailto:logarion@lists.orbitalfox.eu?subject=[Issue]"
maintainer: "Stavros Polymenis <sp@orbitalfox.eu>"
authors: "Stavros Polymenis <sp@orbitalfox.eu>"
license: "EUPL"
build: [
["dune" "build" "--root" "." "-j" jobs "@install"]
]
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"
"cohttp-lwt-unix"
"tls"
]
build: [
["dune" "subst"] {pinned}
[
"dune"
"build"
"-p"
name
"-j"
jobs
"@install"
"@runtest" {with-test}
"@doc" {with-doc}
]
]
dev-repo: "git://orbitalfox.eu/logarion"

25
readme Normal file
View File

@ -0,0 +1,25 @@
Logarion is a free and open-source text archive system. A blog-wiki hybrid.
Download: <https://logarion.orbitalfox.eu/downloads/>
EUPL licence: <https://joinup.ec.europa.eu/software/page/eupl>
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: <https://logarion.orbitalfox.eu>
* Report an issue: <mailto:logarion@lists.orbitalfox.eu?subject=Issue:>
* Discussion: <https://lists.orbitalfox.eu/listinfo/logarion>
or join via <mailto:logarion-join@lists.orbitalfox.eu>
Install development version
opam pin add text_parse git://orbitalfox.eu/text-parse-ml
opam pin add logarion git://orbitalfox.eu/logarion
opam install logarion

View File

@ -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"

View File

@ -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')

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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; }

View File

@ -1,3 +0,0 @@
## Articles
{{recent_texts_listing}}

View File

@ -1 +0,0 @@
{{title}}

View File

@ -1,3 +0,0 @@
{{date_human}}
{{link}}
{{abstract}}

View File

@ -1,7 +0,0 @@
### Topics
{{topics}}
### Recent articles
{{recent_texts_listing}}

View File

@ -1,5 +0,0 @@
# {{title}}
{{details}}
{{body}}

View File

@ -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

View File

@ -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

View File

@ -1,7 +0,0 @@
(jbuild_version 1)
(library
((name confix)
(public_name logarion.confix)
(libraries (fpath toml))
))

View File

@ -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
"<title>" ^ config.title ^ "</title>"
(* TODO: ^ "<subtitle>A subtitle.</subtitle>"*)
^ "<link rel=\"alternate\" type=\"text/html\" href=\"" ^ url ^ "\"/>"
^ "<link rel=\"self\" type=\"application/atom+xml\" href=\"" ^ url ^ "/feed.atom\" />"
^ "<id>urn:uuid:" ^ Id.to_string config.id ^ "</id>"
^ "<updated>" ^ Ptime.to_rfc3339 (Ptime_clock.now ()) ^ "</updated>"
let opt_element tag_name content =
if content <> ""
then "<" ^ tag_name ^ ">" ^ content ^ "</" ^ tag_name ^ ">"
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 ^ "<author>"
^ (opt_element "name" @@ esc elt.Author.name)
^ (opt_element "uri" @@ esc (Uri.to_string elt.Author.address))
^ "</author>"
in
("<entry>"
^ "<title>" ^ meta.title ^ "</title>"
^ "<id>urn:uuid:" ^ Meta.Id.to_string meta.uuid ^ "</id>"
^ "<link rel=\"alternate\" href=\"" ^ url ^ "/" ^ u ^ "\" />"
^ "<updated>" ^ Date.(meta.date |> listing |> rfc_string) ^ "</updated>"
^ Meta.AuthorSet.fold authors meta.authors ""
^ opt_element "summary" @@ esc meta.abstract)
^ Meta.StringSet.fold (fun elt a -> a ^ "<category term=\"" ^ elt ^ "\"/>") meta.topics ""
^ "<content type=\"xhtml\"><div xmlns=\"http://www.w3.org/1999/xhtml\">"
^ (Omd.to_html @@ Omd.of_string @@ esc note.Note.body)
^ "</div></content>"
^ "</entry>"
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
"<?xml version=\"1.0\" encoding=\"utf-8\"?>\n<feed xmlns=\"http://www.w3.org/2005/Atom\">\n"
^ header config url
^ List.fold_left fold_valid "" articles
^ "</feed>"

View File

@ -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 ]
]

View File

@ -1,5 +0,0 @@
(library
((name converters)
(public_name logarion.converters)
(libraries (logarion logarion.file mustache tyxml ptime ptime.clock.os))
))

View File

@ -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 ^ "<li><a href=\"/topic/" ^ e ^ "\">" ^ e ^ "</a></li>") 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])

View File

@ -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

View File

@ -1,5 +0,0 @@
(library
((name logarion)
(public_name logarion)
(libraries (confix omd ptime lwt uuidm uri re.str emile))
))

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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)
))))

View File

@ -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 <mailto:logarion@lists.orbitalfox.eu?subject=[Issue] summary-here>"; ]
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

View File

@ -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

View File

@ -1,7 +0,0 @@
(jbuild_version 1)
(library
((name file)
(public_name logarion.file)
(libraries (logarion lwt lwt.unix))
))