diff --git a/http/http.ml b/http/http.ml index 8f1331c..83ca424 100644 --- a/http/http.ml +++ b/http/http.ml @@ -1,28 +1,27 @@ let version = "%%VERSION%%" 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 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 "text/plain" | Some "application/octet-stream" -> Ok body - | Some x -> Error ("Invalid content-type: " ^ x) - | None -> Error ("No content-type") + let open Cohttp in + match Header.get (headers |> Response.headers) "content-type" with + | Some "application/msgpack" | Some "text/plain" | Some "application/octet-stream" -> Ok body + | Some x -> Error ("Invalid content-type: " ^ x) + | None -> Error ("No content-type") 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 sl.keywords*) -(* | `Topic s -> check s sl.topics sl.authors sl.keywords*) -(* | `Keyword s -> check s sl.keywords sl.topics sl.authors*) +(* 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 *) @@ -36,75 +35,99 @@ let newer time id dir = | 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 + 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 = function - | Msgpck.List (info :: _fields :: [texts]) -> - 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" - in - print_endline @@ archive_name ^ " (pack format version " ^ string_of_int version ^ ")"; - (match Msgpck.to_list texts with - | [] -> prerr_endline "Empty index" - | texts -> - (try Unix.mkdir "peers" 0o740 with Unix.Unix_error (EEXIST, _, _) -> () | _ -> prerr_endline "Error making peers"); - let dir = "peers/" ^ match Uri.host url with - | None -> "local/" ^ Uri.path url | Some s -> s ^ Uri.path url ^ "/" in - (match Bos.OS.Dir.create ~mode:0o740 (Fpath.v dir) with - | Ok _ -> () - | _ -> prerr_endline "Error making domain dir"); - print_endline @@ "Copying into: " ^ dir; - let text_num = List.length texts in - let of_pck i x = - print_string @@ "\rDownloading " ^ string_of_int (i+1) ^ "/" ^ string_of_int text_num; flush stdout; - match x with - | Msgpck.List (id::time::title::_authors::_topics::_keywords) -> - (match Logarion.Id.of_bytes Msgpck.(to_bytes id) with - | 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) - | _ -> prerr_endline ("Invalid record structure") - in List.iteri of_pck texts) - | _ -> prerr_endline "malformed feed" + | Msgpck.List (info :: _fields :: [texts]) -> + 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" + in + print_endline @@ archive_name ^ " (pack format version " ^ string_of_int version ^ ")"; + (match Msgpck.to_list texts with + | [] -> prerr_endline "Empty index" + | texts -> + (try Unix.mkdir "peers" 0o740 with Unix.Unix_error (EEXIST, _, _) -> () | _ -> prerr_endline "Error making peers"); + let dir = "peers/" ^ match Uri.host url with + | None -> "local/" ^ Uri.path url | Some s -> s ^ Uri.path url ^ "/" in + (match Bos.OS.Dir.create ~mode:0o740 (Fpath.v dir) with + | Ok _ -> () + | _ -> prerr_endline "Error making domain dir"); + print_endline @@ "Copying into: " ^ dir; + let text_num = List.length texts in + let of_pck i x = + print_string @@ "\rDownloading " ^ string_of_int (i+1) ^ "/" ^ string_of_int text_num; flush stdout; + 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 -> if newer Msgpck.(to_uint32 time) id dir then fn url dir id) + | _ -> prerr_endline ("Invalid record structure") + in List.iteri of_pck texts) + | _ -> prerr_endline "malformed feed" -let pull_index url _authors _keywords _topics = - let index_url = Uri.of_string (url ^ "/index.pck") in - match http_apply response index_url with - | Error msg -> prerr_endline @@ "Failed index request for " ^ url ^ " " ^ msg - | Ok body -> - let _i, pack = Msgpck.StringBuf.read body in -(* let predicates =*) -(* A.predicate A.authored authors_opt*) -(* @ A.predicate A.keyworded keywords_opt*) -(* @ A.predicate A.topics topics_opt*) -(* in*) - let is_selected text = List.fold_left (fun a e -> a && e text) true [](*predicates*) in - parse_index is_selected pull_text (Uri.of_string url) pack +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 + parse_index is_selected pull_text url pack -let pull_list_indices auths words topics = - match open_in "peers.txt" with +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 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 - | file -> - let rec read () = try pull_index (input_line file) auths words topics; read () with End_of_file -> () in + | file -> + let rec read () = + try (pull_fn (input_line file)) auths topics; read () + with End_of_file -> () in read () -let pull = function | "" -> pull_list_indices | x -> pull_index x +let pull = function "" -> pull_list | x -> pull_fn x open Cmdliner let pull_term = - 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 url = Arg.(value & pos 0 string "" & info [] ~docv:"URL" ~doc:"HTTP URL of Logarion") in - Term.(const pull $ url $ authors $ keywords $ topics), - Term.info "pull" ~doc:"pull listed texts" ~man:[ `S "DESCRIPTION"; `P "Pull texts from archive at address"] + 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"] diff --git a/lib/header_pack.ml b/lib/header_pack.ml index 2d0b157..7219a38 100644 --- a/lib/header_pack.ml +++ b/lib/header_pack.ml @@ -14,14 +14,14 @@ let date = function let columns = Msgpck.(List [String "id"; String "time"; String "title"; - String "authors"; String "topics"; String "keywords"]) + String "authors"; String "topics"]) 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); List (of_set "keywords" t)]) :: a + 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*) @@ -40,7 +40,7 @@ let list filename = try with Not_found -> Error "unspecified export dir" 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 | None -> prerr_endline ("Invalid id for " ^ Msgpck.to_string title); false | Some id -> text.Text.uuid = id)