source: code/trunk/http/http.ml@ 2

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