Source file http.ml

open! Import
open Ppx_yojson_conv_lib.Yojson_conv.Primitives

module type S = sig
  module Deferred : sig
    type 'a t
  end

  module Pipe : sig
    module Reader : sig
      type 'a t
    end

    module Flushed : sig
      type t
    end

    val fold
      :  ?flushed:Flushed.t
      -> 'a Reader.t
      -> init:'accum
      -> f:('accum -> 'a -> 'accum Deferred.t)
      -> 'accum Deferred.t

    val of_list : 'a list -> 'a Reader.t
  end

  module Response : sig
    type t

    val status : t -> Cohttp.Code.status_code
    val headers : t -> (string * string) list
  end

  module Body : sig
    type t

    val of_pipe : string Pipe.Reader.t -> t
    val of_string : string -> t
    val to_string : t -> string Deferred.t
    val to_pipe : t -> string Pipe.Reader.t
  end

  module Client : sig
    val get : ?headers:Cohttp.Header.t -> Uri.t -> (Response.t * Body.t) Deferred.t

    val post
      :  ?headers:Cohttp.Header.t
      -> ?body:Body.t
      -> ?chunked:bool
      -> Uri.t
      -> (Response.t * Body.t) Deferred.t

    val put
      :  ?headers:Cohttp.Header.t
      -> ?body:Body.t
      -> ?chunked:bool
      -> Uri.t
      -> (Response.t * Body.t) Deferred.t

    val delete
      :  ?headers:Cohttp.Header.t
      -> ?body:Body.t
      -> ?chunked:bool
      -> Uri.t
      -> (Response.t * Body.t) Deferred.t
  end
end

module Meth = struct
  type standard =
    [ `GET
    | `HEAD
    | `POST
    | `PUT
    | `DELETE
    | `CONNECT
    | `OPTIONS
    | `TRACE
    | `PATCH
    ]
  [@@deriving yojson_of]

  type t =
    [ standard
    | `Other of string
    ]
  [@@deriving yojson_of]

  let pp ppf x = Format.pp_print_string ppf (Yojson.Safe.to_string (yojson_of_t x))
end

module Headers = struct
  type t = (string * string) list

  let yojson_of_t l = `List (List.map l ~f:(fun (k, v) -> `List [ `String k; `String v ]))
  let empty = []
  let of_list x = x
  let to_list x = x
  let pp ppf l = Format.pp_print_string ppf (Yojson.Safe.to_string (yojson_of_t l))
end

module Monad = struct
  type (+'x, 'f) app

  module type S = sig
    type 'a s
    type t

    external inj : 'a s -> ('a, t) app = "%identity"
    external prj : ('a, t) app -> 'a s = "%identity"
  end

  module Make (T : sig
      type 'a t
    end) : S with type 'a s = 'a T.t = struct
    type 'a s = 'a T.t
    type t

    external inj : 'a -> 'b = "%identity"
    external prj : 'a -> 'b = "%identity"
  end

  type 'm t =
    { bind : 'a 'b. ('a, 'm) app -> ('a -> ('b, 'm) app) -> ('b, 'm) app
    ; return : 'a. 'a -> ('a, 'm) app
    }
end

module Backend = struct
  module type S = sig
    type +'a t

    val return : 'a -> 'a t
    val bind : 'a t -> ('a -> 'b t) -> 'b t
    val map : 'a t -> ('a -> 'b) -> 'b t
  end
end

module Range = struct
  type byte_range_spec =
    [ `Range of int64 * int64
    | `From_start of int64
    | `From_end of int64
    ]
  [@@deriving yojson]

  let of_range start stop =
    if Int64.compare stop start < 0
    then
      Error
        (sprintf "Not a valid byte range specification: start=%Ld, stop=%Ld" start stop)
    else Ok [ `Range (start, stop) ]
  ;;

  let%expect_test "of_range" =
    let yojson_of_byte_range_spec_list l =
      `List (List.map l ~f:yojson_of_byte_range_spec)
    in
    let test x y =
      of_range x y
      |> (function
       | Ok v -> `List [ `String "Ok"; yojson_of_byte_range_spec_list v ]
       | Error s -> `List [ `String "Error"; `String s ])
      |> Yojson.Safe.to_string
      |> print_endline
    in
    (* Test 1: first argument < second argument *)
    test Int64.min_value Int64.max_value;
    [%expect {| ["Ok",[["Range",-9223372036854775808,9223372036854775807]]] |}];
    (* Test 2: first argument = second argument *)
    test Int64.min_value Int64.min_value;
    [%expect {| ["Ok",[["Range",-9223372036854775808,-9223372036854775808]]] |}];
    (* Test 3: first argument > second argument, invalid range *)
    test Int64.max_value Int64.min_value;
    [%expect
      {| ["Error","Not a valid byte range specification: start=9223372036854775807, stop=-9223372036854775808"] |}]
  ;;

  let from_end start = [ `From_end start ]
  let from_start start = [ `From_start start ]

  let byte_range_spec_to_string (spec : byte_range_spec) =
    match spec with
    | `Range (start, stop) -> sprintf "%Ld-%Ld" start stop
    | `From_start start -> sprintf "%Ld-" start
    | `From_end stop -> sprintf "-%Ld" stop
  ;;

  let%expect_test "byte_range_spec_to_string" =
    let test x = printf "%s" (byte_range_spec_to_string x) in
    (* Test 1: `Range (correct by design, no need to check the bounds) *)
    test (`Range (Int64.zero, Int64.one));
    [%expect {| 0-1 |}];
    (* Test 2: `From_start *)
    test (`From_start Int64.one);
    [%expect {| 1- |}];
    (* Test 3: `From_end *)
    test (`From_end Int64.one);
    [%expect {| -1 |}]
  ;;

  type t = byte_range_spec list

  let to_header (t : t) =
    let byte_range_spec_strs = List.map ~f:byte_range_spec_to_string t in
    let concatenated = String.concat ~sep:"," byte_range_spec_strs in
    "Range", sprintf "bytes=%s" concatenated
  ;;

  let%expect_test "to_header" =
    let test x =
      let k, v = to_header x in
      printf "(%s %s)" k v
    in
    (* Test 1: empty list *)
    test [];
    [%expect {| (Range bytes=) |}];
    (* Test 2: list of a single `Range *)
    test [ `Range (Int64.zero, Int64.one) ];
    [%expect {| (Range bytes=0-1) |}];
    (* Test 3: list of a single `From_start *)
    test [ `From_start Int64.one ];
    [%expect {| (Range bytes=1-) |}];
    (* Test 4: list of a `From_start and a `From_end *)
    test [ `From_start Int64.zero; `From_end Int64.one ];
    [%expect {| (Range bytes=0-,-1) |}]
  ;;

  let to_header_value (t : t) =
    let k, v = to_header t in
    sprintf "%s: %s" k v
  ;;

  let%expect_test "to_header_value" =
    let test x = printf "%s" (to_header_value x) in
    (* Test 1: empty list *)
    test [];
    [%expect {| Range: bytes= |}];
    (* Test 2: list of a single `Range *)
    test [ `Range (Int64.zero, Int64.one) ];
    [%expect {| Range: bytes=0-1 |}];
    (* Test 3: list of a single `From_start *)
    test [ `From_start Int64.one ];
    [%expect {| Range: bytes=1- |}];
    (* Test 4: list of a `From_start and a `From_end *)
    test [ `From_start Int64.zero; `From_end Int64.one ];
    [%expect {| Range: bytes=0-,-1 |}]
  ;;
end

module Status = struct
  type informational =
    [ `Continue
    | `Switching_protocols
    ]
  [@@deriving yojson_of]

  type successful =
    [ `OK
    | `Created
    | `Accepted
    | `Non_authoritative_information
    | `No_content
    | `Reset_content
    | `Partial_content
    ]
  [@@deriving yojson_of]

  type redirection =
    [ `Multiple_choices
    | `Moved_permanently
    | `Found
    | `See_other
    | `Not_modified
    | `Use_proxy
    | `Temporary_redirect
    ]
  [@@deriving yojson_of]

  type client_error =
    [ `Bad_request
    | `Unauthorized
    | `Payment_required
    | `Forbidden
    | `Not_found
    | `Method_not_allowed
    | `Not_acceptable
    | `Proxy_authentication_required
    | `Request_timeout
    | `Conflict
    | `Gone
    | `Length_required
    | `Precondition_failed
    | `Unsupported_media_type
    | `Expectation_failed
    | `I_m_a_teapot
    | `Enhance_your_calm
    | `Upgrade_required
    ]
  [@@deriving yojson_of]

  type server_error =
    [ `Internal_server_error
    | `Not_implemented
    | `Bad_gateway
    | `Service_unavailable
    | `Gateway_timeout
    | `Http_version_not_supported
    ]
  [@@deriving yojson_of]

  type standard =
    [ informational
    | successful
    | redirection
    | client_error
    | server_error
    ]
  [@@deriving yojson_of]

  type t =
    [ standard
    | `Code of int
    ]
  [@@deriving yojson_of]

  let to_code = function
    | `Code n -> n
    | #Cohttp.Code.status_code as s -> Cohttp.Code.code_of_status s
  ;;
end

module Request = struct
  type t =
    { meth : Meth.t
    ; version : int * int
    ; headers : Headers.t
    ; body : string
    }
  [@@deriving yojson_of]

  let meth t = t.meth
  let version t = t.version
  let headers t = t.headers
  let body t = t.body

  let make ?(version = 1, 1) ?(headers = Headers.empty) ?(body = "") meth =
    { meth; version; headers; body }
  ;;

  let pp ppf t = Format.pp_print_string ppf (Yojson.Safe.to_string (yojson_of_t t))
end

module Response = struct
  type t =
    { version : int * int
    ; status : Status.t
    ; reason : string
    ; headers : Headers.t
    ; body : string
    }

  let make ?(version = 1, 1) ?(reason = "") ?(headers = Headers.empty) ~body status =
    { version; reason; headers; status; body }
  ;;

  let status { status; _ } = status
  let headers { headers; _ } = headers
  let body { body; _ } = body
  let version { version; _ } = version
  let reason { reason; _ } = reason
end

module Io = struct
  module Error = struct
    type bad_response =
      { code : int
      ; body : string
      ; x_amzn_error_type : string option
      }
    [@@deriving yojson]

    exception Bad_response of bad_response
    exception Too_many_redirects
  end

  module type S = sig
    include Backend.S

    val call
      :  ?endpoint_url:string
      -> cfg:Cfg.t
      -> service:Service.t
      -> Meth.t
      -> Request.t
      -> Uri.t
      -> Response.t t

    val resolve_cfg : Cfg.t option -> Cfg.t t
  end
end