logarion/lib/header_pack.ml

97 lines
3.9 KiB
OCaml

let version = 0
type info_t = { version: int; id: string; title: string; people: string list; locations: string list }
type t = { info: info_t; fields: Msgpck.t; texts: Msgpck.t; peers: Msgpck.t }
let of_id id = Msgpck.of_string id
let to_id = Msgpck.to_string
let person p = Msgpck.String (Person.to_string p)
let persons ps = Msgpck.of_list @@ List.rev @@ Person.Set.fold (fun p a -> person p :: a) ps []
let str = Msgpck.of_string
let str_list ls = Msgpck.of_list @@ List.map str ls
let to_str_list x = List.map Msgpck.to_string (Msgpck.to_list x)
let of_set field t =
List.rev @@ String_set.fold (fun s a -> Msgpck.String s :: a) (Text.set field t) []
let date = function "" -> Int32.zero | date -> Int32.of_int (Date.to_secs date)
let to_sec = function Msgpck.Int i -> Int32.of_int i | Msgpck.Uint32 i -> i | x -> Msgpck.to_uint32 x
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_info = function
| Msgpck.List (v::id::n::a::ls::[]) ->
let people = to_str_list a in
let locations = to_str_list ls in
Msgpck.({version = to_int v; id = to_string id; title = to_string n; people; locations})
| _ -> invalid_arg "Pack header"
let of_info i = let open Msgpck in
List [Int i.version; String i.id; String i.title; str_list i.people; str_list i.locations]
let of_text a t =
let open Text in
Msgpck.(List [
of_id t.id; of_uint32 (date (Date.listing t.date));
String t.title; persons t.authors; List (of_set "topics" t)
]) :: a
let of_text_list l = Msgpck.List l
let pack p = Msgpck.List [of_info p.info; p.fields; p.texts; p.peers]
let string p = Bytes.to_string @@ Msgpck.Bytes.to_string @@ pack p
let unpack = function
| Msgpck.List (i::fields::texts::[]) ->
Ok { info = to_info i; fields; texts; peers = Msgpck.List [] }
| Msgpck.List (i::fields::texts::peers::[]) ->
Ok { info = to_info i; fields; texts; peers }
| _ -> Error "format mismatch"
let of_string s = unpack @@ snd @@ Msgpck.StringBuf.read s
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 to_id id with
| "" -> prerr_endline ("Invalid id for " ^ Msgpck.to_string title); false
| id -> text.Text.id = id)
| _ -> prerr_endline ("Invalid record pattern"); false
let numof_texts pack = List.length (Msgpck.to_list pack.texts)
let iteri fn pack =
let of_pck i = function Msgpck.List (id::time::title::authors::topics::[]) ->
let t = match time with Msgpck.Int i -> Int32.of_int i | Msgpck.Uint32 i -> i
| x -> Msgpck.to_uint32 x in
let id = to_id id in
let title = Msgpck.to_string title in
let topics = to_str_list topics in
let authors = to_str_list authors in
fn i id t title authors topics
| _ -> prerr_endline ("\n\nInvalid record structure\n\n")
in List.iteri of_pck (Msgpck.to_list pack.texts);
(*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 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; persons archive.people]) in*)
(* File_store.file fname @@ Bytes.to_string*)
(* @@ Msgpck.Bytes.to_string (List [archive; fields; Msgpck.List header_pack])*)