Changeset 3 in code


Ignore:
Timestamp:
Apr 15, 2022, 1:17:01 PM (3 years ago)
Author:
fox
Message:
  • Removed 'txt init'

Format

  • New B32 ID

Index

  • New option: txt index --print
  • Move scheme to peers
  • Replace peer.*.conf files with index packed locations Instead of adding a URL to peers.*.conf, run txt pull <url>

Conversion

  • Rewritten converters
  • txt-convert looks for a .convert.conf containing key: value lines.
  • Specifiable topic-roots from .convert.conf.
  • Added Topics: key, with comma seperated topics.

If set only those topics will appear in the main index and used as topic roots.
Other topics will have sub-indices generated, but won't be listed in the main index.

  • HTML converter header & footer options
  • HTML-index renamed to HTM-index

Internal

  • Change types: uuid:Uuid -> id:string
  • File_store merges identical texts
  • Use peer ID for store path, store peers' texts in .local/share/texts
  • Simple URN resolution for converter

Continue to next feed if parsing one fails

  • Phasing-out Archive, replaced by improved packs
  • Eliminate Bos, Cohttp, lwt, uri, tls, Re, Ptime, dependencies
  • Lock version for Cmdliner, fix dune-project
  • Optional resursive store
  • Improve header_pack
  • Fix recursive mkdir
Location:
trunk
Files:
10 added
3 deleted
21 edited

Legend:

Unmodified
Added
Removed

  • trunk/Makefile

    r2 r3  
    33
    44cli:
    5         dune build cli/cli.exe
     5        dune build cli/txt.exe
    66
    77clean:
    … …  
    1111        dune subst
    1212        dune build
    13         cp _build/default/cli/cli.exe txt
     13        cp _build/default/cli/txt.exe txt
    1414        strip txt
    15         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
     15        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
    1616        rm txt
    1717

  • trunk/cli/atom.ml

    r2 r3  
    1010module P = Parsers.Plain_text.Make (Converter.Html)
    1111
    12 let id txt = "<id>urn:uuid:" ^ Logarion.(Id.to_string txt.Text.uuid) ^ "</id>"
     12let id txt = "<id>urn:uuid:" ^ Logarion.(txt.Text.id) ^ "</id>"
    1313let title text = "<title>" ^ esc text.Logarion.Text.title ^ "</title>"
    1414
    1515let authors text =
    16         let u acc addr = acc ^ element "uri" (Uri.to_string addr) in
     16        let u acc addr = acc ^ element "uri" addr in
    1717  let open Logarion in
    1818  let fn txt a =
    … …  
    5252  ^ title ^ {|</title><link rel="alternate" type="|} ^ alternate_type ^ {|" href="|}
    5353  ^ base_url ^ {|/" /><link rel="self" type="application/atom+xml" href="|}
    54   ^ self ^ {|" /><id>urn:uuid:|} ^ Logarion.Id.to_string archive_id ^ "</id><updated>"
    55   ^ Ptime.to_rfc3339 (Ptime_clock.now ()) ^ "</updated>\n"
     54  ^ self ^ {|" /><id>urn:uuid:|} ^ archive_id ^ "</id><updated>"
     55  ^ Logarion.Date.now () ^ "</updated>\n"
    5656  ^ List.fold_left (fun acc t -> acc ^ entry base_url t) "" texts
    5757  ^ "</feed>"

  • trunk/cli/convert.ml

    r2 r3  
    11open Logarion
    2 module A = Archive.Make (Logarion.File_store)
    32
    4 let convert_modified source dest fn title text =
    5         if (try Unix.((stat dest).st_mtime < (stat source).st_mtime) with _-> true)
    6         then (File_store.file dest (fn title text); true) else false
     3let is_older source dest = try
     4        Unix.((stat dest).st_mtime < (stat source).st_mtime) with _-> true
    75
    8 let word_fname dir text = dir ^ "/" ^ Text.alias text
    9 let id_fname dir text = dir ^ "/" ^ Text.short_id text
     6let convert cs r (text, files) = match Text.str "Content-Type" text with
     7        | "" | "text/plain" ->
     8                let source = List.hd files in
     9                let dest = Filename.concat r.Conversion.dir (Text.short_id text) in
     10                List.fold_left
     11                        (fun a f ->
     12                                let dest = dest ^ f.Conversion.ext in
     13                                if is_older source dest then (File_store.file dest (f.Conversion.page r text); true) else false
     14                                || a)
     15                        false cs
     16        | x -> Printf.eprintf "Can't convert Content-Type: %s file: %s" x text.Text.title; false
    1017
    11 let writer types dir name (text,store_item) = (* todo: single_parser -> [files] *)
    12 (*      convert_modified store_item idfilename (fun _title -> Text.to_string) text.title text;*)
    13         let h = if "htm" = types || "all" = types then
    14                 convert_modified store_item (id_fname dir text ^ ".htm") Html.page name text
    15                 else false in
    16         let g = if "gmi" = types || "all" = types then
    17                 convert_modified store_item (id_fname dir text ^ ".gmi") Gemini.page name text
    18                 else false in
    19         h || g
     18let converters types kv =
     19        let t = [] in
     20        let t = if ("htm" = types || "all" = types) then
     21                (let htm = Html.init kv in
     22                 Conversion.{ ext = Html.ext; page = Html.page htm; indices = Html.indices htm })::t
     23                else t in
     24        let t = if ("gmi" = types || "all" = types) then
     25                Conversion.{ ext = Gemini.ext; page = Gemini.page; indices = Gemini.indices}::t else t in
     26        t
    2027
    21 let index_writer types noindex dir archive topic_roots topic_map texts =
    22         let name = archive.A.name in
    23         let file path = File_store.file (dir ^ path) in
    24         file "/index.pck"       (Header_pack.pack archive texts);
    25         if not noindex && ("htm" = types || "all" = types) then (
    26                 let index_name = try Store.KV.find "HTML-index" archive.File_store.kv
    27                         with Not_found -> "index.html" in
    28                 if index_name <> "" then
    29                         file ("/"^index_name) (Html.topic_main_index name topic_roots texts);
    30                 file "/index.date.htm" (Html.date_index name texts);
    31                 List.iter
    32                         (fun topic -> file ("/index." ^ topic ^ ".htm")
    33                          (Html.topic_sub_index name topic_map topic texts))
    34                         topic_roots;
    35                 let base_url = try Store.KV.find "HTTP-URL" archive.File_store.kv
    36                         with Not_found -> prerr_endline "Missing `HTTP-URL:` in config"; "" in
    37                 file "/feed.atom" (Atom.feed archive.A.name archive.A.id base_url "text/html" texts)
    38         );
    39         if not noindex && ("gmi" = types || "all" = types) then (
    40                 let index_name = try Store.KV.find "Gemini-index" archive.File_store.kv
    41                         with Not_found -> "index.gmi" in
    42                 if index_name <> "" then
    43                         file ("/"^index_name) (Gemini.topic_main_index name topic_roots texts);
    44                 file "/index.date.gmi" (Gemini.date_index name texts);
    45                 List.iter
    46                         (fun topic -> file ("/index." ^ topic ^ ".gmi")
    47                          (Gemini.topic_sub_index name topic_map topic texts))
    48                         topic_roots;
    49                 let base_url = try Store.KV.find "GEMINI-URL" archive.File_store.kv
    50                         with Not_found -> prerr_endline "Missing `GEMINI-URL:` in config"; "" in
    51                 file "/gmi.atom" (Atom.feed archive.A.name archive.A.id base_url "text/gemini" texts)
    52         )
     28let convert_all converters noindex dir id kv =
     29        let empty = Topic_set.Map.empty in
     30        let repo = Conversion.{ id; dir; kv; topic_roots = []; topics = empty; texts = [] } in
     31        let fn (ts,ls,acc) ((elt,_) as r) =
     32                (Topic_set.to_map ts (Text.set "topics" elt)), elt::ls,
     33                if convert converters repo r then acc+1 else acc in
     34        let topics, texts, count = File_store.(fold ~dir ~order:newest fn (empty,[],0)) in
     35        let topic_roots = try List.rev @@ String_set.list_of_csv (Store.KV.find "Topics" kv)
     36                with Not_found -> Topic_set.roots topics in
     37        let repo = Conversion.{ repo with topic_roots; topics; texts } in
     38        if not noindex then List.iter (fun c -> c.Conversion.indices repo) converters;
     39        Printf.printf "Converted: %d Indexed: %d\n" count (List.length texts)
    5340
    54 let txt_writer types dir name ((text, _store_item) as r) =
    55         match Text.str "Content-Type" text with
    56         | "" | "text/plain" -> writer types dir name r
    57         | x -> prerr_endline ("Can't convert Content-Type: "^x^" file: " ^text.Text.title); false
    58 
    59 let convert_all types noindex dir archive =
    60         let name = archive.A.name in
    61         let fn (ts,ls,acc) ((elt,_) as r) =
    62                 (Topic_set.to_map ts (Text.set "topics" elt)),
    63                 elt::ls, if txt_writer types dir name r then acc+1 else acc in
    64         let empty = Topic_set.Map.empty in
    65         let topic_map, texts, count = A.(fold ~order:newest fn (empty,[],0) archive) in
    66         let topic_roots = Topic_set.roots topic_map in
    67         index_writer types noindex dir archive topic_roots topic_map texts;
    68         print_endline @@ "Converted: " ^ string_of_int (count)
    69                 ^ "\nIndexed: " ^ string_of_int (List.length texts);
    70         Ok ()
    71 
    72 let convert_dir types noindex cmd_dir =
    73         let (>>=) = Result.bind in
    74         let with_dir dir =
    75                 Result.map_error (function `Msg m -> m)
    76                 Logarion.File_store.Directory.(directory dir |> print ~descr:"export" dir) in
    77         (A.of_path "."
    78                 >>= fun archive -> (match cmd_dir with "" -> Error "unspecified export dir" | x -> Ok x)
    79                 >>= fun dir -> with_dir dir
    80                 >>= fun _ -> convert_all types noindex dir { archive with store = dir })
    81          |> function Ok () -> () | Error x -> prerr_endline x
     41let convert_dir types noindex dir =
     42        match dir with "" -> prerr_endline "unspecified dir"
     43        | dir ->
     44                let fname = Filename.concat dir "index.pck" in
     45                match Header_pack.of_string @@ File_store.to_string fname with
     46                | Error s -> prerr_endline s
     47                | Ok { info; _ } ->
     48                        let kv = let f = Filename.concat dir ".convert.conf" in (* TODO: better place to store convert conf? *)
     49                                if Sys.file_exists f then File_store.of_kv_file f else Store.KV.empty in
     50                        let kv = if Store.KV.mem "Title" kv then kv
     51                                else Store.KV.add "Title" info.Header_pack.title kv in
     52                        let kv = Store.KV.add "Locations" (String.concat ";\n" info.Header_pack.locations) kv in
     53                        let cs = converters types kv in
     54                        convert_all cs noindex dir info.Header_pack.id kv
    8255
    8356open Cmdliner
    84 
    8557let term =
    86         let directory = Arg.(value & pos 0 string "" & info [] ~docv:"target directory" ~doc:"Directory to convert into") in
    87         let types = Arg.(value & opt string "all" & info ["t"; "type"] ~docv:"TYPES" ~doc:"Convert to type") in
    88         let noindex = Arg.(value & flag & info ["noindex"] ~doc:"don't write an index when converting") in
     58        let directory = Arg.(value & pos 0 string "" & info [] ~docv:"target directory"
     59                ~doc:"Directory to convert") in
     60        let types = Arg.(value & opt string "all" & info ["t"; "type"] ~docv:"TYPES"
     61         ~doc:"Convert to type") in
     62        let noindex = Arg.(value & flag & info ["noindex"]
     63                ~doc:"don't create indices in target format") in
    8964        Term.(const convert_dir $ types $ noindex $ directory),
    90         Term.info "convert" ~doc:"convert archive" ~man:[ `S "DESCRIPTION"; `P "Convert Logarion archive" ]
     65        Term.info "convert" ~doc:"convert txts"
     66                ~man:[ `S "DESCRIPTION"; `P "Convert texts within a directory to another format.
     67                Directory must contain an index.pck. Run `txt index` first." ]

  • trunk/cli/dune

    r2 r3  
    11(executable
    2  (name cli)
     2 (name txt)
    33 (public_name txt)
    4  (modules cli convert html atom gemini)
    5  (libraries logarion logarion.http re.str cmdliner bos ptime ptime.clock.os text_parse.converter text_parse.parsers msgpck))
     4 (modules txt authors convert conversion file index last listing new topics html atom gemini pull)
     5 (libraries text_parse.converter text_parse.parsers logarion msgpck curl str cmdliner))

  • trunk/cli/gemini.ml

    r2 r3  
    1 let page _archive_title text =
     1let ext = ".gmi"
     2
     3module GeminiConverter = struct
     4        include Converter.Gemini
     5        let angled_uri u a = if String.sub u 0 10 <> "urn:txtid:" then
     6                angled_uri u a else angled_uri (String.(sub u 10 (length u - 10)) ^ ext) a
     7end
     8
     9let page _conversion text =
    210  let open Logarion.Text in
    311  "# " ^ text.title
    412  ^ "\nAuthors: " ^ Logarion.Person.Set.to_string text.authors
    513  ^ "\nDate: " ^ Logarion.Date.(pretty_date @@ listing text.date)
    6   ^ let module T = Parsers.Plain_text.Make (Converter.Gemini) in
     14  ^ let module T = Parsers.Plain_text.Make (GeminiConverter) in
    715  "\n" ^ T.of_string text.body ""
    816
    … …  
    3139    "" meta_list
    3240
    33 let topic_link root topic =
    34  "=> index." ^ root ^ ".gmi " ^ String.capitalize_ascii topic ^ "\n"
     41let topic_link root topic =
     42  let replaced_space = String.map (function ' '->'+' | x->x) in
     43         "=> index." ^ replaced_space  root ^ ".gmi " ^ String.capitalize_ascii topic ^ "\n"
    3544
    3645let text_item path meta =
    … …  
    7281  "# " ^ title ^ "\n\n"
    7382  ^ listing_index topic_map [topic_root] "" metas
     83
     84let indices r =
     85        let open Logarion in
     86        let file name = File_store.file (Filename.concat r.Conversion.dir name) in
     87        let index_name = try Store.KV.find "Gemini-index" r.kv with Not_found -> "index.gmi" in
     88        let title = try Store.KV.find "Title" r.Conversion.kv with Not_found -> "" in
     89
     90        if index_name <> "" then
     91                file index_name (topic_main_index title r.topic_roots r.texts);
     92
     93        file "index.date.gmi" (date_index title r.texts);
     94
     95        List.iter
     96                (fun topic -> file ("index." ^ topic ^ ".gmi")
     97                 (topic_sub_index title r.topics topic r.texts))
     98                r.topic_roots;
     99
     100        let base_url = try
     101                let _i = Str.(search_forward (regexp "gemini?://[^;]*") (Store.KV.find "Locations" r.kv) 0) in
     102                Str.(matched_string (Store.KV.find "Locations" r.kv))
     103                with Not_found -> prerr_endline "Missing location for Gemini"; "" in
     104        file "gmi.atom" (Atom.feed title r.id base_url "text/gemini" r.texts)

  • trunk/cli/html.ml

    r2 r3  
    1 let wrap (title:string) (subtitle:string) body =
    2   {|<!DOCTYPE HTML>|}
    3   ^ {|<html><head><title>|}
    4   ^ subtitle ^ " | " ^ title
    5   ^ {|</title><link rel="stylesheet" href="main.css">|}
    6   ^ {|<link rel="alternate" href="feed.atom" type="application/atom+xml">|}
    7   ^ {|<meta charset="utf-8"/>|}
    8   ^ {|<meta name="viewport" content="width=device-width, initial-scale=1.0">|}
    9   ^ {|</head><body><header><a href=".">|} ^ title
    10   ^ {|</a> <nav><a href="feed.atom" id="feed">feed</a></nav></header>|} ^ body
    11   ^ "</body></html>"
     1type templates_t = { header: string option; footer: string option }
     2type t = { templates : templates_t }
     3
     4let ext = ".htm"
     5let empty_templates = { header = None; footer = None }
     6let default_opts = { templates = empty_templates }
     7
     8let init kv =
     9        let open Logarion in
     10        let header = match  Store.KV.find "HTM-header" kv with
     11                | fname -> Some (File_store.to_string fname)
     12                | exception Not_found -> None in
     13        let footer = match  Store.KV.find "HTM-footer" kv with
     14                | fname -> Some (File_store.to_string fname)
     15                | exception Not_found -> None in
     16        { templates = { header; footer} }
     17
     18let wrap c htm text_title body =
     19        let site_title = try Logarion.Store.KV.find "Title" c.Conversion.kv
     20                with Not_found -> "" in
     21        let replace x = let open Str in
     22                global_replace (regexp "{{archive-title}}") site_title x
     23                |> global_replace (regexp "{{text-title}}") text_title
     24        in
     25        let header = match htm.templates.header with
     26        | Some x -> replace x
     27        | None -> "<header><a href='.'>" ^ site_title ^
     28                "</a><nav><a href='feed.atom' id='feed'>feed</a></nav></header>"
     29        in
     30        let footer = match htm.templates.footer with  None -> "" | Some x -> replace x in
     31  "<!DOCTYPE HTML><html><head><title>" ^ text_title ^ " • " ^ site_title ^ "</title>\n\
     32  <link rel='stylesheet' href='main.css'>\
     33  <link rel='alternate' href='feed.atom' type='application/atom+xml'>\
     34  <meta charset='utf-8'/><meta name='viewport' content='width=device-width, initial-scale=1.0'>\
     35  </head><body>\n" ^ header ^ body ^ footer ^ "</body></html>"
    1236
    1337let topic_link root topic =
    1438  let replaced_space = String.map (function ' '->'+' | x->x) in
    15   {|<a href="index.|} ^ root ^ {|.htm#|} ^ replaced_space topic ^ {|">|}
     39  "<a href='index." ^ replaced_space root ^ ".htm#" ^ replaced_space topic ^ "'>"
    1640  ^ String.capitalize_ascii topic ^ "</a>"
    1741
    18 let page archive_title text =
     42module HtmlConverter = struct
     43        include Converter.Html
     44        let angled_uri u a = if String.sub u 0 10 <> "urn:txtid:" then
     45                angled_uri u a else angled_uri (String.(sub u 10 (length u - 10)) ^ ext) a
     46end
     47
     48let page htm conversion text =
    1949  let open Logarion in
    2050  let open Text in
    21   let module T = Parsers.Plain_text.Make (Converter.Html) in
     51  let module T = Parsers.Plain_text.Make (HtmlConverter) in
    2252  let sep_append ?(sep=", ") a x = match a,x with "",_ -> x | _, "" -> a | _ -> a ^ sep ^ x in
    23   let opt_kv key value = if String.length value > 0 then "<dt>" ^ key ^ "<dd>" ^ value else "" in
     53  let opt_kv key value = if String.length value > 0
     54        then "<dt>" ^ key ^ "<dd>" ^ value else "" in
    2455(*  let author acc auth = sep_append acc Person.(auth.name ^ " ") in*)
    2556  let authors = (Person.Set.to_string text.authors ^ " ") in
    … …  
    3970    ^ opt_kv "Topics: " (topic_links (set "topics" text))
    4071    ^ opt_kv "Keywords: " keywords
    41     ^ opt_kv "Id: " (Id.to_string text.uuid)
     72    ^ opt_kv "Id: " text.id
    4273    ^ {|</dl></header><pre style="white-space:pre-wrap">|} in
    43   wrap archive_title text.title ((T.of_string text.body header) ^ "</pre></article>")
     74  wrap conversion htm text.title ((T.of_string text.body header) ^ "</pre></article>")
    4475
    4576let to_dated_links ?(limit) meta_list =
    … …  
    5889    "" meta_list
    5990
    60 let date_index ?(limit) title meta_list =
     91let date_index ?(limit) conv htm meta_list =
    6192  match limit with
    62   | Some limit -> wrap title "Index" (to_dated_links ~limit meta_list)
    63   | None -> wrap title "Index" (to_dated_links meta_list)
     93  | Some limit -> wrap conv htm "Index" (to_dated_links ~limit meta_list)
     94  | None -> wrap conv htm "Index" (to_dated_links meta_list)
    6495
    6596let fold_topic_roots topic_roots =
    … …  
    113144  "<nav><h1>Texts</h1>" ^ item_group topic_roots ^ "</nav>"
    114145
    115 let topic_main_index title topic_roots metas =
    116   wrap title "Topics"
     146let topic_main_index conv htm topic_roots metas =
     147  wrap conv htm "Topics"
    117148    (fold_topic_roots topic_roots
    118149     ^ "<nav><h1>Latest</h1>" ^ to_dated_links ~limit:10 metas
    119150     ^ {|<a href="index.date.htm">More by date</a></nav>|} )
    120151
    121 let topic_sub_index title topic_map topic_root metas =
    122   wrap title topic_root
     152let topic_sub_index conv htm topic_map topic_root metas =
     153  wrap conv htm topic_root
    123154    (fold_topics topic_map [topic_root] metas
    124155(*     ^ {|<a href=".atom" id="feed">|}^ String.capitalize_ascii topic_root ^{| feed </a>|}*)
    125156     ^ listing_index topic_map [topic_root] "" metas)
     157
     158open Logarion
     159let indices htm c =
     160        let file name = Logarion.File_store.file (Filename.concat c.Conversion.dir name) in
     161        let index_name = try Store.KV.find "HTM-index" c.Conversion.kv with Not_found -> "index.html" in
     162        let title = try Store.KV.find "Title" c.Conversion.kv with Not_found -> "" in
     163
     164        if index_name <> "" then
     165                file index_name (topic_main_index c htm c.topic_roots c.texts);
     166
     167        file "index.date.htm" (date_index c htm c.texts);
     168
     169        List.iter
     170                (fun root -> file ("index." ^ root ^ ".htm") (topic_sub_index c htm c.topics root c.texts))
     171                c.topic_roots;
     172
     173        let base_url = try
     174                let _i = Str.(search_forward (regexp "https?://[^;]*") (Store.KV.find "Locations" c.kv) 0) in
     175                Str.(matched_string (Store.KV.find "Locations" c.kv))
     176                with Not_found -> prerr_endline "Missing location for HTTP(S)"; "" in
     177        file "feed.atom" (Atom.feed title c.id base_url "text/html" c.texts)

  • trunk/dune-project

    r2 r3  
    11(lang dune 2.0)
    22(name logarion)
    3 (homepage "https://logarion.orbitalfox.eu")
    4 
    5 (source (uri git://orbitalfox.eu/logarion))
    63(license EUPL-1.2)
    7 (authors "orbifx")
    8 (maintainers "fox@orbitalfox.eu")
    9 (bug_reports "mailto:logarion@lists.orbitalfox.eu?subject=Issue:")
     4(maintainers "orbifx <fox@orbitalfox.eu>")
     5(homepage "http://logarion.orbitalfox.eu")
     6(source (uri git+https://git.disroot.org/orbifx/logarion.git))
    107
    118(generate_opam_files true)
    … …  
    1411 (name logarion)
    1512 (synopsis "Texts archival and exchange")
    16  (depends re cmdliner bos ptime uuidm uri text_parse msgpck cohttp-lwt-unix tls))
     13 (depends text_parse (cmdliner (<= 1.0.4)) msgpck ocurl))

  • trunk/lib/archive.ml

    r2 r3  
    1 (*let module S = Set.Make (Text) in*)
    2 (*let module M = Map.Make (String) in*)
    3 (*let module I = Map.Make (Id) in*)
    4 (*let aggr = I.empty, M.empty, M.empty, M.empty in*)
    5 (*let fn (id, a, t, k) (n,_) =*)
    6 (* let id = I.add n.Text.uuid n id in*)
    7 (* let a =*)
    8 (*   let f e a = M.update (e.Person.name) (function Some v -> Some (S.add n v) | None -> Some (S.singleton n)) a in*)
    9 (*   Person.Set.fold f n.Text.authors a in*)
    10 (* let t =*)
    11 (*   let f e a = M.update e (function Some v -> Some (S.add n v) | None -> Some (S.singleton n)) a in*)
    12 (*   String_set.fold f (Text.set "Topics" n) t in*)
    13 (* let k =*)
    14 (*   let f e a = M.update e (function Some v -> Some (S.add n v) | None -> Some (S.singleton n)) a in*)
    15 (*   String_set.fold f (Text.set "Keywords" n) k in*)
    16 (* (id, a, t, k)*)
     1let predicate fn opt = Option.(to_list @@ map fn opt)
    172
    18 module Make (Store : Store.T) = struct
    19   include Store
    20   let predicate fn opt = Option.(to_list @@ map fn opt)
     3let authored query_string =
     4  let q = Person.Set.of_query @@ String_set.query query_string in
     5  fun n -> Person.Set.predicate q n.Text.authors
    216
    22   let authored query_string =
    23     let q = Person.Set.of_query @@ String_set.query query_string in
    24     fun n -> Person.Set.predicate q n.Text.authors
     7let keyworded query_string =
     8  let q = String_set.query query_string in
     9  fun n -> String_set.(predicate q (Text.set "Keywords" n))
    2510
    26   let keyworded query_string =
    27     let q = String_set.query query_string in
    28     fun n -> String_set.(predicate q (Text.set "Keywords" n))
    29 
    30   let topics query_string =
    31     let q = String_set.query query_string in
    32     fun n -> String_set.(predicate q (Text.set "Topics" n))
    33 end
     11let topics query_string =
     12  let q = String_set.query query_string in
     13  fun n -> String_set.(predicate q (Text.set "Topics" n))

  • trunk/lib/date.ml

    r2 r3  
    1 type t = { created: Ptime.t option; edited: Ptime.t option }
     1type t = { created: string; edited: string }
    22let compare = compare
    3 let rfc_string date = match date with Some t -> Ptime.to_rfc3339 t | None -> ""
    4 let of_string (rfc : string) = match Ptime.of_rfc3339 rfc with Ok (t,_,_) -> Some t | Error _ -> None
    5 let listing date = if Option.is_some date.edited then date.edited else date.created
    6 let pretty_date = function
    7   | Some t -> Ptime.to_date t |> fun (y, m, d) -> Printf.sprintf "%04d-%02d-%02d" y m d
    8   | None -> ""
     3let rfc_string date = date
     4let of_string (rfc : string) = rfc
     5let listing date = if date.edited <> "" then date.edited else date.created
     6let pretty_date date =
     7        try Scanf.sscanf date "%4s-%2s-%2s" (fun y m d -> Printf.sprintf "%s %s %s" y m d)
     8        with Scanf.Scan_failure s as e -> Printf.fprintf stderr "%s for %s\n" s date; raise e
     9let now () = Unix.time () |> Unix.gmtime |>
     10        (fun t -> Printf.sprintf "%4d-%02d-%02dT%02d:%02d:%02dZ"
     11         (t.tm_year+1900) (t.tm_mon+1) t.tm_mday t.tm_hour t.tm_min t.tm_sec)
     12let to_secs date =
     13        Scanf.sscanf date "%4d-%02d-%02dT%02d:%02d:%02d"
     14                (fun y mo d h mi s -> (y-1970)*31557600 + mo*2629800 + d*86400 + h*3600 + mi*60 + s)

  • trunk/lib/dune

    r2 r3  
    22 (name        logarion)
    33 (public_name logarion)
    4  (libraries ptime uuidm uri re.str bos text_parse text_parse.parsers msgpck))
     4 (libraries text_parse text_parse.parsers unix str msgpck))

  • trunk/lib/file_store.ml

    r2 r3  
    11type t = string
    2 type item_t = string
    3 type archive_t = {
    4         name: string; archivists: Person.Set.t; id: Id.t;
    5         kv: string Store.KV.t; store: t }
     2type item_t = t list
    63type record_t = Text.t * item_t
    74
    85let extension = ".txt"
     6let def_dir = try Sys.getenv "LOGARION_DIR" with Not_found -> "."
    97
    108let to_string f =
    119        let ic = open_in f in
    12         let n = in_channel_length ic in
    13         let s = Bytes.create n in
    14         really_input ic s 0 n;
     10        let s = really_input_string ic (in_channel_length ic) in
    1511        close_in ic;
    16         Bytes.to_string s
     12        s
    1713
    18 let file path content = let out = open_out path in
    19         output_string out content; close_out out
     14let fold_file_line fn init file = match open_in file with
     15        | exception (Sys_error msg) -> prerr_endline msg; init
     16        | file ->
     17                let rec read acc = match input_line file with
     18                        | "" as s | s when String.get s 0 = '#' -> read acc
     19                        | s -> read (fn s acc)
     20                        | exception End_of_file -> close_in file; acc
     21                in read init
    2022
    21 let (//) a b = a ^ "/" ^ b
     23let file path str = let o = open_out path in output_string o str; close_out o
    2224
    2325let to_text path =
    2426        if Filename.extension path = extension then
    2527                (to_string path |> Text.of_string |> Result.map_error (fun m -> path ^": "^ m))
    26         else Error "Not txt"
     28        else Error (Printf.sprintf "Not txt: %s" path)
    2729
    2830let newest (a,_pa) (b,_pb) = Text.newest a b
    2931let oldest (a,_pa) (b,_pb) = Text.oldest a b
    3032
    31 let list_iter fn {store;_} paths =
    32         let link f = match to_text (Filename.concat store f)
    33                 with Ok t -> fn store t f | Error s -> prerr_endline s in
     33let list_iter fn dir paths =
     34        let link f = match to_text (Filename.concat dir f) with
     35                | Ok t -> fn dir t f | Error s -> prerr_endline s in
    3436        List.iter link paths
    3537
    36 let iter_valid_text pred fn p =
    37         match to_text p with Error _ -> () | Ok t -> if pred t then fn (t, p)
     38module TextMap = Map.Make(Text)
    3839
    39 let fold_valid_text pred fn acc p =
    40         match to_text p with Error _ -> acc | Ok t -> if pred t then fn acc (t, p) else acc
     40type iteration_t = item_t TextMap.t
     41let new_iteration = TextMap.empty
    4142
    42 let list_fs dir =
     43(*let iter_valid_text pred fn path =*)
     44(*      match to_text path with Error _ -> () | Ok t -> if pred t then fn (t, p)*)
     45
     46let fold_valid_text pred it path =
     47        match to_text path with Error _ -> it
     48        | Ok t -> if pred t then (TextMap.update t
     49                        (function None -> Some [path] | Some ps -> Some (path::ps)) it
     50                ) else it
     51
     52(* Compare file system nodes to skip reparsing? *)
     53let list_fs ?(r=false) dir =
     54        let valid_dir f = r && String.get f 0 <> '.' && Sys.is_directory f in
     55        let expand_dir d = Array.(to_list @@ map (Filename.concat d) (Sys.readdir d)) in
    4356        let rec loop result = function
    44                 | [] -> result
    45                 | f::fs when Sys.is_directory f ->
    46                         Array.map (Filename.concat f) (Sys.readdir f)
    47                         |> Array.to_list |> List.append fs |> loop result
     57                | f::fs when valid_dir f -> expand_dir f |> List.append fs |> loop result
    4858                | f::fs -> loop (f::result) fs
    49         in loop [] [dir]
     59                | [] -> result in
     60        let dirs = if dir = "." then Array.to_list (Sys.readdir dir) else
     61                if not r then expand_dir dir else [dir] in
     62        loop [] dirs
    5063
    5164let list_take n =
    … …  
    5568        in take [] n
    5669
    57 let iter ?(predicate=fun _ -> true) ?order ?number fn {store;_} =
    58         match order with
    59         | None -> List.iter (iter_valid_text predicate fn) @@ list_fs store
    60         | Some comp ->
    61                 List.iter fn
    62                 @@ (match number with None -> (fun x -> x) | Some n -> list_take n)
    63                 @@ List.fast_sort comp
    64                 @@ List.fold_left (fold_valid_text predicate (fun a e -> List.cons e a)) []
    65                 @@ list_fs store
     70let fold_sort_take ?(predicate=fun _ -> true) ?(number=None) comp flist =
     71        (match number with None -> (fun x -> x) | Some n -> list_take n)
     72        @@ List.fast_sort comp @@ TextMap.bindings
     73        @@ List.fold_left (fold_valid_text predicate) new_iteration flist
    6674
    67 let fold ?(predicate=fun _ -> true) ?order ?number fn acc {store;_} =
    68         match order with
    69         | None -> List.fold_left (fold_valid_text predicate fn) acc @@ list_fs store
    70         | Some comp ->
    71                 List.fold_left fn acc
    72                 @@ (match number with None -> (fun x -> x) | Some n -> list_take n)
    73                 @@ List.fast_sort comp
    74                 @@ List.fold_left (fold_valid_text predicate (fun a e -> List.cons e a)) []
    75                 @@ list_fs store
     75let iter ?(r=false) ?(dir=def_dir) ?(predicate=fun _ -> true) ?order ?number fn =
     76        let flist = list_fs ~r dir in match order with
     77        | Some comp -> List.iter fn @@ fold_sort_take ~predicate ~number comp flist
     78        | None -> List.iter fn @@ TextMap.bindings @@
     79                List.fold_left (fold_valid_text predicate) new_iteration flist
    7680
    77 let with_id { store; _ } id =
     81let fold ?(r=false) ?(dir=def_dir) ?(predicate=fun _ -> true) ?order ?number fn acc =
     82        let flist = list_fs ~r dir in match order with
     83        | Some comp -> List.fold_left fn acc @@ fold_sort_take ~predicate ~number comp flist
     84        | None -> List.fold_left fn acc @@ TextMap.bindings @@
     85                List.fold_left (fold_valid_text predicate) new_iteration flist
     86
     87let with_id ?(r=false) ?(dir=def_dir) id =
    7888        let matched acc path =
    7989                match to_text path with
    8090                | Error x -> prerr_endline x; acc
    81                 | Ok text when text.Text.uuid <> id -> acc
     91                | Ok text when text.Text.id <> id -> acc
    8292                | Ok text ->
    8393                        match acc with
    … …  
    8595                        | Ok (Some prev) -> if prev = text then acc else Error [text; prev]
    8696                        | Error x -> Error (text :: x)
    87         in List.fold_left matched (Ok None) (list_fs store)
     97        in List.fold_left matched (Ok None) (list_fs ~r dir)
    8898
    89 module Directory = struct
    90         let print ?(descr="") dir result =
    91                 let () = match result with
    92                         | Ok true -> print_endline ("Created " ^ descr ^ " directory " ^ dir)
    93                         | Ok false -> print_endline ("Using existing " ^ descr ^ " directory " ^ dir)
    94                         | Error (`Msg msg) -> prerr_endline @@ "Failed making " ^ descr ^ ". " ^ msg
    95                 in
    96                 result
     99let with_dir ?(descr="") ?(perm=0o740) dir =
     100        let mkdir dir = match Unix.mkdir dir perm with
     101        | exception Unix.Unix_error (EEXIST, _, _) -> ()
     102        | exception Unix.Unix_error (code, _fn, arg) ->
     103                failwith @@ Printf.sprintf "Error %s making %s dir: %s"
     104                        (Unix.error_message code) descr arg
     105        | _ -> () in
     106        let rec mkeach path = function [] | [""] -> () | ""::t -> mkeach path t
     107                | hd::t -> let d = Filename.concat path hd in mkdir d; mkeach d t in
     108        mkeach
     109                (if Filename.is_relative dir then "" else "/")
     110                (String.split_on_char '/' dir)
    97111
    98         let directory dir = Result.bind (Fpath.of_string dir) Bos.OS.Dir.create
    99 
    100         let rec directories = function
    101                 | [] -> Ok ()
    102                 | (d, descr)::tl ->
    103                         match directory d |> print ~descr d with
    104                         | Ok _ -> directories tl
    105                         | Error _ -> Error (d, descr)
    106 end
    107 
    108 let copy ?(recursive = false) src dst =
    109         Bos.OS.Cmd.run (Bos.Cmd.(v "cp" %% (on recursive @@ v "-r") % src % dst))
     112let rec with_dirs = function [] -> () | (d, descr)::tl -> with_dir ~descr d; with_dirs tl
    110113
    111114let versioned_basename_of_title ?(version=0) repo extension (title : string) =
    112115        let basename = Text.string_alias title in
    113116        let rec next version =
    114                 let candidate = repo // basename ^ "." ^ string_of_int version ^ extension in
     117                let candidate = Filename.concat repo
     118                        (basename ^ "." ^ string_of_int version ^ extension) in
    115119                if Sys.file_exists candidate then next (succ version) else candidate
    116120        in
    117121        next version
    118122
    119 let uuid_filename repo extension text =
     123let id_filename repo extension text =
    120124        let basename = Text.alias text in
    121         let candidate = repo // String.sub (Id.to_string text.uuid) 0 6 ^ "." ^ basename ^ extension in
     125        let candidate = Filename.concat repo (text.id ^ "." ^ basename ^ extension) in
    122126        if Sys.file_exists candidate then Error "Name clash, try again" else Ok candidate
    123127
    124 let with_text {store;_} new_text =
    125         Result.bind (uuid_filename store extension new_text) @@
    126         fun path ->
    127                 try file path (Text.to_string new_text); Ok (path, new_text) with Sys_error s -> Error s
    128 
    129 let basic_config () =
    130         "Archive-Name: "
    131         ^ "\nArchive-ID: " ^ Id.(generate () |> to_string)
    132         ^ "\nArchivists: " ^ Bos.OS.Env.opt_var "USER" ~absent:""
    133         |> Bytes.of_string
    134 
    135 let init ?(dotdir=".logarion/") () =
    136         match Directory.directories [dotdir, "dotdir"] with
    137         | Error (_dir, _desc) -> ()
    138         | Ok () ->
    139                 let config_file =
    140                         open_out_gen [Open_creat; Open_excl; Open_wronly]
    141                                 0o700 (dotdir // "config") in
    142                 output_bytes config_file (basic_config ());
    143                 close_out config_file
     128let with_text ?(dir=def_dir) new_text =
     129        match id_filename dir extension new_text with
     130        | Error _ as e -> e
     131        | Ok path ->
     132                try file path (Text.to_string new_text); Ok (path, new_text)
     133                with Sys_error s -> Error s
    144134
    145135module Config = struct
    146         type t = archive_t
    147         let key_value k v a = match k with
    148                 | "Archive-Name" -> { a with name = String.trim v }
    149                 | "Archive-ID" -> { a with id = Option.get (Id.of_string (String.trim v)) }
    150                 | "Archivists" -> { a with archivists = Person.Set.of_string v }
    151                 | _ -> { a with kv = Store.KV.add k (String.trim v) a.kv }
     136        type t = string Store.KV.t
     137        let key_value k v a = Store.KV.add k (String.trim v) a
    152138end
    153139
    154 let of_path store =
     140let of_kv_file path =
    155141        let open Text_parse in
    156         let subsyntaxes = [| (module Parsers.Key_value.Make (Config) : Parser.S with type t = Config.t); (module Parsers.Key_value.Make (Config)); |] in
    157         let of_string text acc = Parser.parse subsyntaxes { text; pos = 0; right_boundary = String.length text - 1 } acc in
    158         Ok (
    159                 of_string (to_string @@ store ^ "/.logarion/config") {
    160                         name = "";
    161                         archivists = Person.Set.empty;
    162                         id = Id.nil;
    163                         kv = Store.KV.empty;
    164                         store = try Sys.getenv "LOGARION_DIR" with Not_found -> "."
    165                 }
    166         )
     142        let subsyntaxes = Parsers.Key_value.[|
     143                (module Make (Config) : Parser.S with type t = Config.t); (module Make (Config)); |] in
     144        let of_string text acc =
     145                Parser.parse subsyntaxes { text; pos = 0; right_boundary = String.length text - 1 } acc in
     146        of_string (to_string @@ path) Store.KV.empty

  • trunk/lib/header_pack.ml

    r2 r3  
    1 type info_t = { version: int; name: string; archivists: string list }
    2 type text_t = { id: Msgpck.t; time: Msgpck.t; title: Msgpck.t; authors: Msgpck.t }
    3 type t = { info: info_t; fields: string list; texts: Msgpck.t; peers: Msgpck.t }
     1let version = 0
     2type info_t = { version: int; id: string; title: string; people: string list; locations: string list }
     3type t = { info: info_t; fields: Msgpck.t; texts: Msgpck.t; peers: Msgpck.t }
    44
    5 let of_id id = Msgpck.Bytes (Id.to_bytes id)
    6 let to_id pck_id = Id.of_bytes Msgpck.(to_bytes pck_id)
     5let of_id id = Msgpck.of_string id
     6let to_id = Msgpck.to_string
    77
    88let person p = Msgpck.String (Person.to_string p)
    9 let persons ps = List.rev @@ Person.Set.fold (fun p a -> person p :: a) ps []
     9let persons ps = Msgpck.of_list @@ List.rev @@ Person.Set.fold (fun p a -> person p :: a) ps []
     10
     11let str = Msgpck.of_string
     12let str_list ls = Msgpck.of_list @@ List.map str ls
     13let to_str_list x = List.map Msgpck.to_string (Msgpck.to_list x)
    1014
    1115let of_set field t =
    1216        List.rev @@ String_set.fold (fun s a -> Msgpck.String s :: a) (Text.set field t) []
    1317
    14 let date = function
    15         | None -> Int32.zero
    16         | Some date ->
    17                 let days, ps = Ptime.Span.to_d_ps (Ptime.to_span date) in
    18                 Int32.add Int32.(mul (of_int days) 86400l) Int64.(to_int32 (div ps 1000000000000L))
     18let date = function "" -> Int32.zero | date -> Int32.of_int (Date.to_secs date)
    1919
    20 let to_sec = function
    21         Msgpck.Int i -> Int32.of_int i | Msgpck.Uint32 i -> i | x -> Msgpck.to_uint32 x
    22 
    23 let public_peers () =
    24         Peers.fold_file (fun x a -> Msgpck.String x :: a) [] Peers.public_fname
     20let to_sec = function Msgpck.Int i -> Int32.of_int i | Msgpck.Uint32 i -> i | x -> Msgpck.to_uint32 x
    2521
    2622let fields = Msgpck.(List [String "id"; String "time";  String "title"; String "authors"; String "topics"])
    2723let to_fields fieldpack = List.map Msgpck.to_string (Msgpck.to_list fieldpack)
    2824
    29 let to_pack a t =
     25let to_info = function
     26        | Msgpck.List (v::id::n::a::ls::[]) ->
     27                let people = to_str_list a in
     28                let locations = to_str_list ls in
     29                Msgpck.({version = to_int v; id = to_string id; title = to_string n; people; locations})
     30        | _ -> invalid_arg "Pack header"
     31
     32let of_info i = let open Msgpck in
     33        List [Int i.version; String i.id; String i.title; str_list i.people; str_list i.locations]
     34
     35let of_text a t =
    3036        let open Text in
    3137        Msgpck.(List [
    32                 Bytes (Id.to_bytes t.uuid); of_uint32 (date (Date.listing t.date));
    33                 String t.title; List (persons t.authors); List (of_set "topics" t)
     38                of_id t.id; of_uint32 (date (Date.listing t.date));
     39                String t.title; persons t.authors; List (of_set "topics" t)
    3440        ]) :: a
    3541
    36 let pack_filename ?(filename="index.pck") archive =
    37         let dir = Store.KV.find "Export-Dir" archive.File_store.kv in (*raises Not_found*)
    38         dir ^ "/" ^ filename
     42let of_text_list l = Msgpck.List l
    3943
    40 let to_info = function
    41         | Msgpck.List (v::n::a::[]) ->
    42                 let archivists = List.map Msgpck.to_string (Msgpck.to_list a) in
    43                 Msgpck.({version = to_int v; name = to_string n; archivists})
    44         | _ -> invalid_arg "Pack header"
     44let pack p = Msgpck.List [of_info p.info; p.fields; p.texts; p.peers]
     45let string p = Bytes.to_string @@ Msgpck.Bytes.to_string @@ pack p
    4546
    4647let unpack = function
    47         | Msgpck.List (i::f::texts::[]) ->
    48                 Some { info = to_info i; fields = to_fields f; texts; peers = Msgpck.List [] }
    49         | Msgpck.List (i::f::texts::peers::[]) ->
    50                 Some { info = to_info i; fields = to_fields f; texts; peers }
    51         | _ -> None
     48        | Msgpck.List (i::fields::texts::[]) ->
     49                Ok { info = to_info i; fields; texts; peers = Msgpck.List [] }
     50        | Msgpck.List (i::fields::texts::peers::[]) ->
     51                Ok { info = to_info i; fields; texts; peers }
     52        | _ -> Error "format mismatch"
     53
     54let of_string s = unpack @@ snd @@ Msgpck.StringBuf.read s
    5255
    5356let list filename = try
    … …  
    6164let contains text = function
    6265        | Msgpck.List (id::_time::title::_authors::_topics::[]) ->
    63                 (match Id.of_bytes (Msgpck.to_bytes id) with
    64                  | None -> prerr_endline ("Invalid id for " ^ Msgpck.to_string title); false
    65                  | Some id -> text.Text.uuid = id)
     66                (match to_id id with
     67                 | "" -> prerr_endline ("Invalid id for " ^ Msgpck.to_string title); false
     68                 | id -> text.Text.id = id)
    6669        | _ -> prerr_endline ("Invalid record pattern"); false
    6770
    68 let pack archive records =
    69         let header_pack = List.fold_left to_pack [] records in
    70         let info = Msgpck.(List [Int 0; String archive.File_store.name; List (persons archive.archivists)]) in
    71         Bytes.to_string @@ Msgpck.Bytes.to_string
    72                 (List [info; fields; Msgpck.List header_pack; Msgpck.List (public_peers ())])
    7371
    74 let add archive records =
    75         let fname = pack_filename archive in
    76         let append published (t, _f) = if List.exists (contains t) published then published else to_pack published t in
    77         match list fname with Error e -> prerr_endline e | Ok published_list ->
    78                 let header_pack = List.fold_left append published_list records in
    79                 let archive = Msgpck.(List [Int 0; String archive.File_store.name;
    80                         List (persons archive.archivists)]) in
    81                 File_store.file fname @@ Bytes.to_string
    82                         @@ Msgpck.Bytes.to_string (List [archive; fields; Msgpck.List header_pack])
     72(*let pack_filename ?(filename="index.pck") archive =*)
     73(*      let dir = Store.KV.find "Export-Dir" archive.File_store.kv in (*raises Not_found*)*)
     74(*      dir ^ "/" ^ filename*)
    8375
    84 let unpublish _archive _records = ()
     76(*let add archive records =*)
     77(*      let fname = pack_filename archive in*)
     78(*      let append published (t, _f) = if List.exists (contains t) published then published else to_pack published t in*)
     79(*      match list fname with Error e -> prerr_endline e | Ok published_list ->*)
     80(*              let header_pack = List.fold_left append published_list records in*)
     81(*              let archive = Msgpck.(List [*)
     82(*                      Int 0; String archive.File_store.name; persons archive.people]) in*)
     83(*              File_store.file fname @@ Bytes.to_string*)
     84(*                      @@ Msgpck.Bytes.to_string (List [archive; fields; Msgpck.List header_pack])*)

  • trunk/lib/id.ml

    r2 r3  
    1 let random_state = Random.State.make_self_init ()
    2 type t = Uuidm.t
    3 let compare = Uuidm.compare
    4 let to_string = Uuidm.to_string
    5 let of_string = Uuidm.of_string
    6 let to_bytes = Uuidm.to_bytes
    7 let of_bytes = Uuidm.of_bytes
    8 let generate ?(random_state=random_state) = Uuidm.v4_gen random_state
    9 let nil = Uuidm.nil
     1let random_state = Random.State.make_self_init
     2
     3(*module UUID = struct*)
     4(*type t = Uuidm.t*)
     5(*let compare = Uuidm.compare*)
     6(*let to_string = Uuidm.to_string*)
     7(*let of_string = Uuidm.of_string*)
     8(*let to_bytes = Uuidm.to_bytes*)
     9(*let of_bytes = Uuidm.of_bytes*)
     10(*let generate ?(random_state=random_state ()) = Uuidm.v4_gen random_state*)
     11(*let nil = Uuidm.nil*)
     12(*end*)
     13
     14type t = string
     15let compare = String.compare   
     16let nil = ""
     17
     18let short ?(len) id =
     19        let id_len = String.length id in
     20        let l = match len with Some l -> l | None -> if id_len = 36 then 8 else 6 in
     21        String.sub id 0 (min l id_len)
     22
     23let generate ?(len=6) ?(seed=random_state ()) () =
     24        let b32 i = char_of_int @@
     25                if i < 10 then i+48 else
     26                if i < 18 then i+87 else
     27                if i < 20 then i+88 else
     28                if i < 22 then i+89 else
     29                if i < 27 then i+90 else
     30                if i < 32 then i+91 else
     31                (invalid_arg ("id.char" ^ string_of_int i)) in
     32        let c _ = b32 (Random.State.int seed 31) in
     33        String.init len c

  • trunk/lib/peers.ml

    r2 r3  
    1 let public_fname = "peers.pub.conf"
    2 let private_fname = "peers.priv.conf"
     1let text_dir = Filename.concat (Sys.getenv "HOME") ".local/share/texts"
    32
    4 let fold_file fn init file = match open_in file with
    5         | exception (Sys_error msg) -> prerr_endline msg; init
    6         | file ->
    7                 let rec read acc = try read (fn (input_line file) acc)
    8                         with End_of_file -> close_in file; acc in
    9                 read init
     3let fold fn init = match Sys.readdir text_dir with
     4        | exception (Sys_error msg) -> prerr_endline msg
     5        | dirs ->
     6                let read_pack path =
     7                        let pack_path = Filename.(concat text_dir @@ concat path "index.pck") in
     8                        match Sys.file_exists pack_path with false -> () | true ->
     9                                match Header_pack.of_string (File_store.to_string pack_path) with
     10                                | Error s -> Printf.eprintf "%s %s\n" s pack_path
     11                                | Ok p -> ignore @@ List.fold_left fn init Header_pack.(p.info.locations)
     12                in
     13                Array.iter read_pack dirs
     14
     15let scheme url =
     16        let colon_idx = String.index_from url 0 ':' in
     17        let scheme = String.sub url 0 colon_idx in
     18(*      let remain = String.(sub url (colon_idx+1) (length url - length scheme - 1)) in*)
     19        scheme

  • trunk/lib/person.ml

    r2 r3  
    11module Person = struct
    22  type name_t = string
    3   type address_t = Uri.t
     3  type address_t = string
    44  type t = { name: name_t; addresses: address_t list }
    55  let empty = { name = ""; addresses = [] }
    66  let compare = Stdlib.compare
    7   let to_string p = List.fold_left (fun a e -> a^" <"^Uri.to_string e^">") p.name p.addresses
     7  let name_to_string p = p.name
     8  let to_string p = List.fold_left (fun a e -> Printf.sprintf "%s <%s>" a e) p.name p.addresses
    89  let of_string s = match String.trim s with "" -> empty | s ->
    9     match Re.Str.(split (regexp " *< *") s) with
     10    match Str.(split (regexp " *< *") s) with
    1011    | [] -> empty
    1112    | [n] -> let name = String.trim n in { empty with name }
    1213    | n::adds ->
    1314      let name = String.trim n in
    14       let addresses = List.map (fun f -> Uri.of_string @@ String.(sub f 0 (length f -1))) adds in
     15      let addresses = List.map (fun f -> String.(sub f 0 (length f -1))) adds in
    1516      { name; addresses }
    1617end
    … …  
    2021module Set = struct
    2122  include Set.Make(Person)
    22   let to_string ?(pre="") ?(sep=", ") s =
    23     let str = Person.to_string in
     23  let to_string ?(names_only=false) ?(pre="") ?(sep=", ") s =
     24    let str = if names_only then Person.name_to_string else Person.to_string in
    2425    let j x a = match a, x with "",_ -> str x | _,x when x = Person.empty -> a | _ -> a^sep^str x in
    2526    fold j s pre

  • trunk/lib/store.ml

    r2 r3  
    44        type t
    55        type item_t
    6         type archive_t = { name: string; archivists: Person.Set.t; id: Id.t; kv: string KV.t; store: t }
     6        type archive_t = { id: Id.t; name: string; archivists: Person.Set.t; kv: string KV.t; store: t }
    77        type record_t = Text.t * item_t
    88        val of_path: string -> (archive_t, string) result

  • trunk/lib/string_set.ml

    r2 r3  
    11include Set.Make(String)
    22
    3 let list_of_csv x = Re.Str.(split (regexp " *, *")) (String.trim x)
     3let list_of_csv x = Str.(split (regexp " *, *")) (String.trim x)
    44let of_string x = of_list (list_of_csv x)
    55let to_string ?(pre="") ?(sep=", ") s =

  • trunk/lib/text.ml

    r2 r3  
    11module String_map = Map.Make (String)
    22type t = {
    3     title: string;
    4     uuid: Id.t;
    5     authors: Person.Set.t;
    6     date: Date.t;
    7     string_map: string String_map.t;
    8     stringset_map: String_set.t String_map.t;
    9     body: string;
    10   }
     3                id: Id.t;
     4                title: string;
     5                authors: Person.Set.t;
     6                date: Date.t;
     7                string_map: string String_map.t;
     8                stringset_map: String_set.t String_map.t;
     9                body: string;
     10        }
    1111
    12 let blank ?(uuid=(Id.generate ())) () = {
    13     title = "";
    14     uuid;
    15     authors = Person.Set.empty;
    16     date = Date.({ created = None; edited = None});
    17     string_map = String_map.empty;
    18     stringset_map = String_map.empty;
    19     body = "";
    20   }
     12let blank ?(id=(Id.generate ())) () = {
     13                id;
     14                title = "";
     15                authors = Person.Set.empty;
     16                date = Date.({ created = now (); edited = ""});
     17                string_map = String_map.empty;
     18                stringset_map = String_map.empty;
     19                body = "";
     20        }
    2121
    2222let compare = Stdlib.compare
    … …  
    2929
    3030let with_kv x (k,v) =
    31   let trim = String.trim in
    32   match String.lowercase_ascii k with
    33   | "body" -> { x with body = String.trim v }
    34   | "title"-> { x with title = trim v }
    35   | "id"   -> (match Id.of_string v with Some id -> { x with uuid = id } | None -> x)
    36   | "author"
    37   | "authors" -> { x with authors = Person.Set.of_string (trim v)}
    38   | "date"       -> { x with date = Date.{ x.date with created  = Date.of_string v }}
    39   | "date-edited"-> { x with date = Date.{ x.date with edited    = Date.of_string v }}
    40   | "licences" | "topics" | "keywords" | "series" as k -> with_str_set x k v
    41   | k -> { x with string_map = String_map.add k (trim v) x.string_map }
     31        let trim = String.trim in
     32        match String.lowercase_ascii k with
     33        | "body" -> { x with body = String.trim v }
     34        | "title"-> { x with title = trim v }
     35        | "id"   -> (match v with "" -> x | s -> { x with id = s })
     36        | "author"
     37        | "authors" -> { x with authors = Person.Set.of_string (trim v)}
     38        | "date"                         -> { x with date = Date.{ x.date with created  = Date.of_string v }}
     39        | "date-edited"-> { x with date = Date.{ x.date with edited             = Date.of_string v }}
     40        | "licences" | "topics" | "keywords" | "series" as k -> with_str_set x k v
     41        | k -> { x with string_map = String_map.add k (trim v) x.string_map }
    4242
    43 let kv_of_string line = match Re.Str.(bounded_split (regexp ": *")) line 2 with
    44   | [ key; value ] -> Re.Str.(replace_first (regexp "^#\\+") "" key), value
    45   | [ key ] -> Re.Str.(replace_first (regexp "^#\\+") "" key), ""
    46   | _ -> "",""
     43let kv_of_string line = match Str.(bounded_split (regexp ": *")) line 2 with
     44        | [ key; value ] -> Str.(replace_first (regexp "^#\\+") "" key), value
     45        | [ key ] -> Str.(replace_first (regexp "^#\\+") "" key), ""
     46        | _ -> "",""
    4747
    4848let of_header front_matter =
    49   let fields = List.map kv_of_string (Re.Str.(split (regexp "\n")) front_matter) in
    50   List.fold_left with_kv (blank ~uuid:Id.nil ()) fields
     49        let fields = List.map kv_of_string (Str.(split (regexp "\n")) front_matter) in
     50        List.fold_left with_kv (blank ~id:Id.nil ()) fields
    5151
    5252let front_matter_body_split s =
    53   if Re.Str.(string_match (regexp ".*:.*")) s 0
    54   then match Re.Str.(bounded_split (regexp "^$")) s 2 with
    55       | front::body::[] -> (front, body)
    56       | _ -> ("", s)
    57   else ("", s)
     53        if Str.(string_match (regexp ".*:.*")) s 0
     54        then match Str.(bounded_split (regexp "^$")) s 2 with
     55                        | front::body::[] -> (front, body)
     56                        | _ -> ("", s)
     57        else ("", s)
    5858
    5959let of_string s =
    60   let front_matter, body = front_matter_body_split s in
    61   try
    62     let note = { (of_header front_matter) with body } in
    63     if note.uuid <> Id.nil then Ok note else Error "Missing ID header"
    64   with _ -> Error ("Failed parsing" ^ s)
     60        let front_matter, body = front_matter_body_split s in
     61        try
     62                let note = { (of_header front_matter) with body } in
     63                if note.id <> Id.nil then Ok note else Error "Missing ID header"
     64        with _ -> Error ("Failed parsing" ^ s)
    6565
    6666let to_string x =
    67   let has_len v = String.length v > 0 in
    68   let s field value = if has_len value then field ^ ": " ^ value ^ "\n" else "" in
    69   let a value = if Person.Set.is_empty value then "" else "Authors: " ^ Person.Set.to_string value ^ "\n" in
    70   let d field value = match value with Some _ -> field ^ ": " ^ Date.rfc_string value ^ "\n" | None -> "" in
    71   let rows =
    72     [ s "Title" x.title;
    73       a x.authors;
    74       d "Date" x.date.Date.created;
    75       d "Edited" x.date.Date.edited;
    76       s "Licences" (str_set "licences" x);
    77       s "Topics"   (str_set "topics" x);
    78       s "Keywords" (str_set "keywords" x);
    79       s "Series"   (str_set "series" x);
    80       s "Abstract" (str "abstract" x);
    81       s "ID" (Uuidm.to_string x.uuid);
    82       s "Alias" (str "Alias" x) ]
    83   in
    84   String.concat "" rows ^ "\n" ^ x.body
     67        let has_len v = String.length v > 0 in
     68        let s field value = if has_len value then field ^ ": " ^ value ^ "\n" else "" in
     69        let a value = if Person.Set.is_empty value then "" else "Authors: " ^ Person.Set.to_string value ^ "\n" in
     70        let d field value = match value with "" -> "" | s -> field ^ ": " ^ Date.rfc_string s ^ "\n" in
     71        let rows = [
     72                s "ID" x.id;
     73                d "Date"     x.date.Date.created;
     74                d "Edited"   x.date.Date.edited;
     75                s "Title" x.title;
     76                a x.authors;
     77                s "Licences" (str_set "licences" x);
     78                s "Topics"   (str_set "topics" x);
     79                s "Keywords" (str_set "keywords" x);
     80                s "Series"   (str_set "series" x);
     81                s "Abstract" (str "abstract" x);
     82                s "Alias"    (str "Alias" x)
     83        ] in
     84        String.concat "" rows ^ "\n" ^ x.body
    8585
    8686let string_alias t =
    87   let is_reserved = function
    88     | '!' | '*' | '\'' | '(' | ')' | ';' | ':' | '@' | '&' | '=' | '+' | '$'
    89       | ',' | '/' | '?' | '#' | '[' | ']' | ' ' | '\t' | '\x00' -> true
    90     | _ -> false
    91   in
    92   let b = Buffer.create (String.length t) in
    93   let filter char =
    94     let open Buffer in
    95     if is_reserved char then (try (if nth b (pred (length b)) <> '-' then add_char b '-') with Invalid_argument _ -> prerr_endline "reserved")
    96     else add_char b char
    97   in
    98   String.(iter filter (lowercase_ascii t));
    99   Buffer.contents b
     87        let is_reserved = function
     88                | '!' | '*' | '\'' | '(' | ')' | ';' | ':' | '@' | '&' | '=' | '+' | '$'
     89                        | ',' | '/' | '?' | '#' | '[' | ']' | ' ' | '\t' | '\x00' -> true
     90                | _ -> false
     91        in
     92        let b = Buffer.create (String.length t) in
     93        let filter char =
     94                let open Buffer in
     95                if is_reserved char then (try (if nth b (pred (length b)) <> '-' then add_char b '-') with Invalid_argument _ -> prerr_endline "reserved")
     96                else add_char b char
     97        in
     98        String.(iter filter (lowercase_ascii t));
     99        Buffer.contents b
    100100
    101101let alias t = match str "alias" t with "" -> string_alias t.title | x -> x
    102 let short_id ?(len=8) t = String.sub (Id.to_string t.uuid) 0 len
     102let short_id t = Id.short t.id

  • trunk/lib/topic_set.ml

    r2 r3  
    1 let of_string x = Re.Str.(split (regexp " *> *")) (String.trim x)
     1let of_string x = Str.(split (regexp " *> *")) (String.trim x)
    22
    33let topic x =

  • trunk/logarion.opam

    r2 r3  
    22opam-version: "2.0"
    33synopsis: "Texts archival and exchange"
    4 maintainer: ["fox@orbitalfox.eu"]
    5 authors: ["orbifx"]
     4maintainer: ["orbifx <fox@orbitalfox.eu>"]
    65license: "EUPL-1.2"
    7 homepage: "https://logarion.orbitalfox.eu"
    8 bug-reports: "mailto:logarion@lists.orbitalfox.eu?subject=Issue:"
     6homepage: "http://logarion.orbitalfox.eu"
    97depends: [
    108  "dune" {>= "2.0"}
    11   "re"
    12   "cmdliner"
    13   "bos"
    14   "ptime"
    15   "uuidm"
    16   "uri"
    179  "text_parse"
     10  "cmdliner" {<= "1.0.4"}
    1811  "msgpck"
    19   "cohttp-lwt-unix"
    20   "tls"
     12  "ocurl"
    2113]
    2214build: [
    … …  
    3426  ]
    3527]
    36 dev-repo: "git://orbitalfox.eu/logarion"
     28dev-repo: "git+https://git.disroot.org/orbifx/logarion.git"

  • trunk/readme

    r2 r3  
    1 Logarion is a free and open-source text archive system. A blog-wiki hybrid.
     1Logarion is a text header-format and suite of tools, for discovering, collecting & exchanging texts.
    22
    3 Download: <https://logarion.orbitalfox.eu/downloads/>
    4 EUPL licence: <https://joinup.ec.europa.eu/software/page/eupl>
     3Guide: <http://texts.orbitalfox.eu/11bcd8e9.htm>
     4Source: <http://git.disroot.org/orbifx/logarion>
     5IRC: <irc://tilde.chat/#logarion>
     6EUPL licence: <http://joinup.ec.europa.eu/software/page/eupl>
    57
    68
    7 Start
     9Header fields
    810
    9 Create a folder and run `logarion init` from within it to produce `.logarion/config` configuration file.
    10 Run `logarion --help` for more options.
     11ID:     unique identifier
     12Date:   of creation, ISO8601 formatted
     13Topics: comma seperated list of topic names & phrases
     14Title:
     15Authors:list of name with optional set of <address>
     16
     17A blank line must seperarate the header from the body.
    1118
    1219
    13 Community & support
     20Build development version
    1421
    15 * Website: <https://logarion.orbitalfox.eu>
    16 * Report an issue: <mailto:logarion@lists.orbitalfox.eu?subject=Issue:>
    17 * Discussion: <https://lists.orbitalfox.eu/listinfo/logarion>
    18   or join via <mailto:logarion-join@lists.orbitalfox.eu>
     22Install `ocaml` and `opam`. Then build and install Logarion using opam's pin function:
    1923
    20 
    21 Install development version
    22 
    23         opam pin add text_parse git://orbitalfox.eu/text-parse-ml
    24         opam pin add logarion git://orbitalfox.eu/logarion
    25         opam install logarion
     24```
     25opam pin add text_parse https://git.disroot.org/orbifx/text-parse-ml.git
     26opam pin add logarion https://git.disroot.org/orbifx/logarion.git
     27opam install logarion
     28```
Note: See TracChangeset for help on using the changeset viewer.