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

wip: status messages

Browse Source
This commit is contained in:
orbifx 2021-09-19 22:52:30 +01:00
parent 6e728e1473
commit 9ccbcb7f3d
2 changed files with 100 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

171
http/http.ml
View File

@ -1,28 +1,27 @@
let version = "%%VERSION%%" let version = "%%VERSION%%"
let http_body fn uri = let http_body fn uri =
let open Lwt in let open Lwt in
let open Cohttp_lwt_unix in let open Cohttp_lwt_unix in
Client.get uri >>= fun (headers, body) -> Client.get uri >>= fun (headers, body) ->
body |> Cohttp_lwt.Body.to_string >|= fun body -> fn (headers, body) body |> Cohttp_lwt.Body.to_string >|= fun body -> fn (headers, body)
let response (headers, body) = let response (headers, body) =
let open Cohttp in let open Cohttp in
match Header.get (headers |> Response.headers) "content-type" with match Header.get (headers |> Response.headers) "content-type" with
| Some "application/msgpack" | Some "text/plain" | Some "application/octet-stream" -> Ok body | Some "application/msgpack" | Some "text/plain" | Some "application/octet-stream" -> Ok body
| Some x -> Error ("Invalid content-type: " ^ x) | Some x -> Error ("Invalid content-type: " ^ x)
| None -> Error ("No content-type") | None -> Error ("No content-type")
let http_apply fn uri = Lwt_main.run (http_body fn uri) let http_apply fn uri = Lwt_main.run (http_body fn uri)
module S = Set.Make(String) module S = Set.Make(String)
(*let is_selected sl =*) (*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*) (* let check str a b c = Option.(fold ~none:(is_none b && is_none c) ~some:(fun x -> x = str) a) in*)
(* function*) (* function*)
(* | `Author s -> check s sl.authors sl.topics sl.keywords*) (* | `Author s -> check s sl.authors sl.topics*)
(* | `Topic s -> check s sl.topics sl.authors sl.keywords*) (* | `Topic s -> check s sl.topics sl.authors*)
(* | `Keyword s -> check s sl.keywords sl.topics sl.authors*)
(* TODO: parse using Header_pack *) (* TODO: parse using Header_pack *)
@ -36,75 +35,99 @@ let newer time id dir =
| exception (Sys_error _) -> true | exception (Sys_error _) -> true
let pull_text url dir id = let pull_text url dir id =
let path = Uri.path url in let path = Uri.path url in
let u = Uri.with_path url (path ^ "/" ^ String.sub (Logarion.Id.to_string id) 0 8 ^ ".txt") 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 match http_apply response u with
| Error msg -> prerr_endline @@ " Failed " ^ Uri.to_string u ^ " " ^ msg | Error msg -> prerr_endline @@ " Failed " ^ Uri.to_string u ^ " " ^ msg
| Ok txt -> | Ok txt ->
match Logarion.Text.of_string txt with match Logarion.Text.of_string txt with
| Error s -> prerr_endline s | Error s -> prerr_endline s
| Ok text -> | Ok text ->
let file = open_out_gen [Open_creat; Open_trunc; Open_wronly] 0o640 (fname dir text) in let file = open_out_gen [Open_creat; Open_trunc; Open_wronly] 0o640 (fname dir text) in
output_string file txt; close_out file output_string file txt; close_out file
(*TODO: adapt Archive predication function to work with free sets*) (*TODO: adapt Archive predication function to work with free sets*)
let parse_index _is_selected fn url = function let parse_index _is_selected fn url = function
| Msgpck.List (info :: _fields :: [texts]) -> | Msgpck.List (info :: _fields :: [texts]) ->
let version, archive_name, _archivists = let version, archive_name, _archivists =
match info with Msgpck.List (v::n::a) -> Msgpck.(to_int v, to_string n, a) | _ -> invalid_arg "Pack header" match info with Msgpck.List (v::n::a) -> Msgpck.(to_int v, to_string n, a) | _ -> invalid_arg "Pack header"
in in
print_endline @@ archive_name ^ " (pack format version " ^ string_of_int version ^ ")"; print_endline @@ archive_name ^ " (pack format version " ^ string_of_int version ^ ")";
(match Msgpck.to_list texts with (match Msgpck.to_list texts with
| [] -> prerr_endline "Empty index" | [] -> prerr_endline "Empty index"
| texts -> | texts ->
(try Unix.mkdir "peers" 0o740 with Unix.Unix_error (EEXIST, _, _) -> () | _ -> prerr_endline "Error making peers"); (try Unix.mkdir "peers" 0o740 with Unix.Unix_error (EEXIST, _, _) -> () | _ -> prerr_endline "Error making peers");
let dir = "peers/" ^ match Uri.host url with let dir = "peers/" ^ match Uri.host url with
| None -> "local/" ^ Uri.path url | Some s -> s ^ Uri.path url ^ "/" in | None -> "local/" ^ Uri.path url | Some s -> s ^ Uri.path url ^ "/" in
(match Bos.OS.Dir.create ~mode:0o740 (Fpath.v dir) with (match Bos.OS.Dir.create ~mode:0o740 (Fpath.v dir) with
| Ok _ -> () | Ok _ -> ()
| _ -> prerr_endline "Error making domain dir"); | _ -> prerr_endline "Error making domain dir");
print_endline @@ "Copying into: " ^ dir; print_endline @@ "Copying into: " ^ dir;
let text_num = List.length texts in let text_num = List.length texts in
let of_pck i x = let of_pck i x =
print_string @@ "\rDownloading " ^ string_of_int (i+1) ^ "/" ^ string_of_int text_num; flush stdout; print_string @@ "\rDownloading " ^ string_of_int (i+1) ^ "/" ^ string_of_int text_num; flush stdout;
match x with match x with
| Msgpck.List (id::time::title::_authors::_topics::_keywords) -> | Msgpck.List (id::time::title::_authors::_topics) ->
(match Logarion.Id.of_bytes Msgpck.(to_bytes id) with (match Logarion.Id.of_bytes Msgpck.(to_bytes id) with
| None -> prerr_endline ("Invalid id for " ^ Msgpck.to_string title) | None -> prerr_endline ("Invalid id for " ^ Msgpck.to_string title)
| Some id -> if newer Msgpck.(to_uint32 time) id dir then fn url dir id) | Some id -> if newer Msgpck.(to_uint32 time) id dir then fn url dir id)
| _ -> prerr_endline ("Invalid record structure") | _ -> prerr_endline ("Invalid record structure")
in List.iteri of_pck texts) in List.iteri of_pck texts)
| _ -> prerr_endline "malformed feed" | _ -> prerr_endline "malformed feed"
let pull_index url _authors _keywords _topics = let pull_index url _authors _topics =
let index_url = Uri.of_string (url ^ "/index.pck") in let index_url = Uri.(with_path url (path url ^ "/index.pck")) in
match http_apply response index_url with match http_apply response index_url with
| Error msg -> prerr_endline @@ "Failed index request for " ^ url ^ " " ^ msg | Error msg -> prerr_endline @@ "Failed index request for " ^ Uri.to_string index_url ^ " " ^ msg
| Ok body -> | Ok body ->
let _i, pack = Msgpck.StringBuf.read body in let _i, pack = Msgpck.StringBuf.read body in
(* let predicates =*) (* let predicates =*)
(* A.predicate A.authored authors_opt*) (* A.predicate A.authored authors_opt*)
(* @ A.predicate A.keyworded keywords_opt*) (* @ A.predicate A.topics topics_opt*)
(* @ A.predicate A.topics topics_opt*) (* in*)
(* in*) let is_selected text = List.fold_left (fun a e -> a && e text) true [](*predicates*) in
let is_selected text = List.fold_left (fun a e -> a && e text) true [](*predicates*) in parse_index is_selected pull_text url pack
parse_index is_selected pull_text (Uri.of_string url) pack
let pull_list_indices auths words topics = module Msg = struct
match open_in "peers.txt" with 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 msgs = fold_msgs s msgs (fun msgs t m -> match Ptime.of_rfc3339 t with Ok (v,_,_) -> MsgSet.add (v,m) msgs | _ -> msgs) in
MsgSet.iter (fun (t,m) -> print_endline (Ptime.to_rfc3339 t ^ " @ " ^ m)) msgs
let pull_fn 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 = match open_in "peers.txt" with
| exception (Sys_error msg) -> prerr_endline msg | exception (Sys_error msg) -> prerr_endline msg
| file -> | file ->
let rec read () = try pull_index (input_line file) auths words topics; read () with End_of_file -> () in let rec read () =
try (pull_fn (input_line file)) auths topics; read ()
with End_of_file -> () in
read () read ()
let pull = function | "" -> pull_list_indices | x -> pull_index x let pull = function "" -> pull_list | x -> pull_fn x
open Cmdliner open Cmdliner
let pull_term = let pull_term =
let authors = Arg.(value & opt (some string) None & info ["a"; "authors"] ~docv:"AUTHORS" ~doc:"select authors") in let authors = Arg.(value & opt (some string) None & info ["a"; "authors"] ~docv:"AUTHORS" ~doc:"select authors") in
let keywords = Arg.(value & opt (some string) None & info ["k"; "keywords"] ~docv:"KEYWORDS" ~doc:"select keywords") in let topics = Arg.(value & opt (some string) None & info ["t"; "topics"] ~docv:"TOPICS" ~doc:"select topics") 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
let url = Arg.(value & pos 0 string "" & info [] ~docv:"URL" ~doc:"HTTP URL of Logarion") in Term.(const pull $ url $ authors $ topics),
Term.(const pull $ url $ authors $ keywords $ topics), Term.info "pull" ~doc:"pull listed texts" ~man:[ `S "DESCRIPTION"; `P "Pull texts from archive at address"]
Term.info "pull" ~doc:"pull listed texts" ~man:[ `S "DESCRIPTION"; `P "Pull texts from archive at address"]

6
lib/header_pack.ml
View File

@ -14,14 +14,14 @@ let date = function
let columns = Msgpck.(List let columns = Msgpck.(List
[String "id"; String "time"; String "title"; [String "id"; String "time"; String "title";
String "authors"; String "topics"; String "keywords"]) String "authors"; String "topics"])
let to_pack a t = let to_pack a t =
let open Text in let open Text in
Msgpck.(List [Bytes (Id.to_bytes t.uuid); Msgpck.(List [Bytes (Id.to_bytes t.uuid);
of_uint32 (date (Date.listing t.date)); of_uint32 (date (Date.listing t.date));
String t.title; List (persons t.authors); String t.title; List (persons t.authors);
List (of_set "topics" t); List (of_set "keywords" t)]) :: a List (of_set "topics" t)]) :: a
let pack_filename ?(filename="index.pck") archive = let pack_filename ?(filename="index.pck") archive =
let dir = Store.KV.find "Export-Dir" archive.File_store.kv in (*raises Not_found*) let dir = Store.KV.find "Export-Dir" archive.File_store.kv in (*raises Not_found*)
@ -40,7 +40,7 @@ let list filename = try
with Not_found -> Error "unspecified export dir" with Not_found -> Error "unspecified export dir"
let contains text = function let contains text = function
| Msgpck.List (id::_time::title::_authors::_topics::_keywords) -> | Msgpck.List (id::_time::title::_authors::_topics) ->
(match Id.of_bytes (Msgpck.to_bytes id) with (match Id.of_bytes (Msgpck.to_bytes id) with
| None -> prerr_endline ("Invalid id for " ^ Msgpck.to_string title); false | None -> prerr_endline ("Invalid id for " ^ Msgpck.to_string title); false
| Some id -> text.Text.uuid = id) | Some id -> text.Text.uuid = id)