let reporter ppf =
  let report src level ~over k msgf =
    let k _ =
      over () ;
      k () in
    let with_metadata header _tags k ppf fmt =
      Format.kfprintf k ppf
        ("[%a]%a[%a]: " ^^ fmt ^^ "\n%!")
        Fmt.(styled `Blue int)
        (Unix.getpid ()) Logs_fmt.pp_header (level, header)
        Fmt.(styled `Magenta string)
        (Logs.Src.name src) in
    msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in
  { Logs.report }

(*
let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ()
let () = Logs.set_reporter (reporter Fmt.stderr)
let () = Logs.set_level ~all:true (Some Logs.Debug)
*)

let failf fmt = Format.kasprintf failwith fmt
let failwith fmt = Format.kasprintf (fun err -> Lwt.fail (Failure err)) fmt
let src = Logs.Src.create "simple-client"

module Log = (val Logs.src_log src : Logs.LOG)
module P = Paf_mirage.Make (Tcpip_stack_socket.V4V6.TCP)
open Lwt.Infix

let ( >>? ) x f =
  x >>= function Ok x -> f x | Error err -> Lwt.return_error err

let ( <.> ) f g x = f (g x)
let apply v f = f v

let response_handler : type reqd headers request response ro wo.
    _ ->
    f:(H1.Response.t -> string -> unit Lwt.t) ->
    Mimic.flow ->
    (Ipaddr.t * int) option ->
    response ->
    ro ->
    (reqd, headers, request, response, ro, wo) Alpn.protocol ->
    unit =
 fun th_err ~f _flow _edn response body -> function
  | Alpn.H2 (module Reqd) -> failf "Invalid protocol H2"
  | Alpn.HTTP_1_1 (module Reqd) -> (
      let buf = Buffer.create 0x100 in
      let th, wk = Lwt.wait () in
      let on_eof () =
        H1.Body.Reader.close body ;
        Lwt.wakeup_later wk () in
      let rec on_read payload ~off ~len =
        Buffer.add_string buf (Bigstringaf.substring payload ~off ~len) ;
        H1.Body.Reader.schedule_read body ~on_eof ~on_read in
      H1.Body.Reader.schedule_read body ~on_eof ~on_read ;
      Lwt.async @@ fun () ->
      Lwt.pick [ (th >|= fun () -> `Done); th_err ] >>= function
      | `Done -> f response (Buffer.contents buf)
      | _ ->
          H1.Body.Reader.close body ;
          Lwt.return_unit)

let failf fmt = Format.kasprintf (fun err -> raise (Failure err)) fmt

let error_handler wk _ _protocol err =
  Lwt.wakeup_later wk (err :> [ `Body of string | `Done | Alpn.client_error ]) ;
  match err with
  | `Invalid_response_body_length_v1 _ | `Invalid_response_body_length_v2 _ ->
      failf "Invalid response body-length"
  | `Malformed_response _ -> failf "Malformed response"
  | `Exn exn -> raise exn
  | `Protocol_error (_error_code, _msg) -> failf "Protocol error"

let client_handler th_err ~f wk =
  {
    Alpn.error = (fun edn protocol error -> error_handler wk edn protocol error);
    Alpn.response =
      (fun edn response body protocol ->
        response_handler th_err ~f edn response body protocol);
  }

let anchors = []

let null =
  let authenticator ?ip:_ ~host:_ _ = Ok None in
  Result.get_ok (Tls.Config.client ~authenticator ())

let v =
  Tcpip_stack_socket.V4V6.UDP.connect ~ipv4_only:false ~ipv6_only:false
    Ipaddr.V4.Prefix.global None
  >>= fun udpv4 ->
  Tcpip_stack_socket.V4V6.TCP.connect ~ipv4_only:false ~ipv6_only:false
    Ipaddr.V4.Prefix.global None
  >>= fun tcpv4 -> Tcpip_stack_socket.V4V6.connect udpv4 tcpv4

let stack = Mimic.make ~name:"stack"
let ipaddr = Mimic.make ~name:"ipaddr"
let port = Mimic.make ~name:"port"
let domain_name = Mimic.make ~name:"domain-name"
let scheme = Mimic.make ~name:"scheme"
let tls = Mimic.make ~name:"tls"

let tcp_connect scheme stack ipaddr port =
  match scheme with
  | `HTTP -> Lwt.return_some (stack, ipaddr, port)
  | `HTTPS -> Lwt.return_none

let dns_resolve domain_name =
  match Unix.gethostbyname (Domain_name.to_string domain_name) with
  | { Unix.h_addr_list; _ } ->
      if Array.length h_addr_list > 0
      then Lwt.return_some (Ipaddr_unix.of_inet_addr h_addr_list.(0))
      else Lwt.return_none
  | exception _ -> Lwt.return_none

let tls_connect scheme domain_name cfg stack ipaddr port =
  match scheme with
  | `HTTPS -> Lwt.return_some (domain_name, cfg, stack, ipaddr, port)
  | `HTTP -> Lwt.return_none

let ctx =
  Mimic.empty
  |> Mimic.(
       fold P.tcp_edn
         Fun.[ req scheme; req stack; req ipaddr; dft port 80 ]
         ~k:tcp_connect)
  |> Mimic.(
       fold P.tls_edn
         Fun.
           [
             req scheme;
             opt domain_name;
             dft tls null;
             req stack;
             req ipaddr;
             dft port 443;
           ]
         ~k:tls_connect)
  |> Mimic.(fold ipaddr Fun.[ req domain_name ] ~k:dns_resolve)

let run uri =
  let th, wk = Lwt.wait () in
  let f _ body =
    Lwt.wakeup_later wk body ;
    Lwt.return_unit in
  let th_err, (wk_err : [ `Body of string | `Done | Alpn.client_error ] Lwt.u) =
    Lwt.wait () in
  let ctx =
    match Uri.scheme uri with
    | Some "http" -> Mimic.add scheme `HTTP ctx
    | Some "https" -> Mimic.add scheme `HTTPS ctx
    | _ -> ctx in
  let ctx, hostname =
    match Uri.host uri with
    | None -> (ctx, None)
    | Some host ->
    match
      ( Ipaddr.of_string host,
        Result.bind (Domain_name.of_string host) Domain_name.host )
    with
    | Ok v0, Ok v1 ->
        (ctx |> Mimic.add ipaddr v0 |> Mimic.add domain_name v1, Some host)
    | Ok v, _ -> (ctx |> Mimic.add ipaddr v, Some host)
    | _, Ok v -> (ctx |> Mimic.add domain_name v, Some host)
    | _ -> (ctx, Some host) in
  let ctx =
    match Uri.port uri with Some v -> Mimic.add port v ctx | None -> ctx in
  let headers =
    Option.fold ~none:H1.Headers.empty
      ~some:(fun hostname -> H1.Headers.of_list [ ("Host", hostname) ])
      hostname in
  let request = H1.Request.create ~headers `GET (Uri.path uri) in
  v >>= fun v ->
  let ctx = Mimic.add stack (Tcpip_stack_socket.V4V6.tcp v) ctx in
  (* XXX(dinosaure): we don't fill the [ctx] with [Paf_mirage.paf_transmission]
   * which is fine because we only want to send HTTP/1.1 requests and we don't
   * need to proceed the ALPN challenge - so we don't need to inform [Paf_mirage.run]
   * about the type of the connection and if we got the ALPN protocol _via_ the [ctx]
   * and [paf_transmission] - in the default case, we proceed an HTTP/1.1 request.
   *
   * However, if we want to test an {i alpn} service, we must refactorize the code
   * above to automatically add [paf_transmission] as a proceeded information into
   * the [ctx] after a [Mimic.unfold]. *)
  Paf_mirage.run ~ctx (client_handler th_err ~f wk_err) (`V1 request)
  >>= function
  | Error err ->
      Log.err (fun m -> m "Got an error: %a." Mimic.pp_error err) ;
      Lwt.return_error err
  | Ok (Alpn.Response_H2 _) -> Lwt.return_error (`Msg "Invalid protocol (H2)")
  | Ok (Alpn.Response_HTTP_1_1 (body, _)) -> (
      H1.Body.Writer.close body ;
      Lwt.pick [ (th >|= fun body -> `Body body); th_err ] >>= function
      | `Body body -> Lwt.return_ok body
      | _ ->
          H1.Body.Writer.close body ;
          Lwt.return_error (`Msg "Got an error while sending request"))