kosuzu/http/http.ml

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