Source file http.ml

(*********************************************************************************)
(*                OCaml-LDP                                                      *)
(*                                                                               *)
(*    Copyright (C) 2016-2024 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public License          *)
(*    along with this program; if not, write to the Free Software                *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

module Ldp = Rdf.Ldp
open Types

open Cohttp
open Lwt.Infix;;

let user_agent = ref "ocaml-ldp"

type query_error = Cohttp.Code.meth * int * Types.meta

type Types.error +=
  | Query_error of query_error
  | Unexpected_resource of Ct.t * Ct.t
  | Invalid_response_data of Ct.t * string * exn

let fail e = Types.fail e

let string_of_query_error (meth, code, meta) =
  Printf.sprintf "%s error (%d, %s)"
    (Cohttp.Code.string_of_method meth)
    code (Iri.to_string meta.iri)

let string_of_error fallback = function
| Query_error qe -> string_of_query_error qe
| Unexpected_resource (ct_ex, ct) ->
    Printf.sprintf "Unexpected resource: expected %s but got %s"
      (Ct.to_string ct_ex) (Ct.to_string ct)
| Invalid_response_data (ct, body, e) ->
    Printf.sprintf "Could not parse response as %s: %s\n%s"
      (Ct.to_string ct) (Printexc.to_string e) body
| e -> fallback e

let () = Types.register_string_of_error string_of_error

let get_link links rel = List.assoc_opt rel links

let container_types =
  Iri.Set.of_list
    [ Rdf.Ldp.c_BasicContainer ;
      Rdf.Ldp.c_Container ;
    ]

let type_is_container =
  fun iri -> Iri.Set.mem iri container_types

let is_container ?iri g =
  let iri =
    match iri with
      None -> g.Rdf.Graph.name ()
    | Some iri -> iri
  in
  let sub = Rdf.Term.Iri iri in
  let e t =
    g.Rdf.Graph.exists ~sub ~pred: Rdf.Rdf_.type_ ~obj:(Rdf.Term.Iri t) ()
  in
  let b = Iri.Set.exists e container_types in
  Log.debug
    (fun f -> f "is_container:%b\n%s" b
      (Rdf.Ttl.to_string ~compact:true g));
  b

let response_metadata iri ((resp, body): Response.t * Cohttp_lwt.Body.t) =
  let header = resp.Response.headers in
  let links =
    match Header.get header "Link" with
      None -> []
    | Some str ->
        try Iri.parse_http_link str
        with e -> Log.warn (fun m -> m "Invalid Link header: %s\n%s"
               (Printexc.to_string e) str);
            []
  in
  let iri =
    match Header.get header "Location" with
      None -> iri
    | Some str -> Iri.of_string str
  in
  let acl = get_link links "acl" in
  let meta =
    match get_link links "describedby" with
      None -> get_link links "meta"
    | x -> x
  in
  let user = Header.get header "User" in
  let websocket =
    match Header.get header "Updates-via" with
    | None -> None
    | Some s ->
      try Some (Iri.of_string s)
      with _ -> None
  in
  let exists = Code.code_of_status resp.Response.status = 200 in
  let editable =
    match Header.get header "Allow" with
      None -> []
    | Some str -> Types.methods_of_string str
  in
  { iri ; acl ; meta ; user ;
    websocket ; editable ; exists ; info = (resp, body) ;
  }

module type Requests =
  sig
    val dbg : string -> unit Lwt.t
    val call : ?body: Cohttp_lwt.Body.t ->
      ?headers: Header.t -> Code.meth -> Iri.t -> (Response.t * Cohttp_lwt.Body.t) Lwt.t
  end

exception Not_initialized of string
let () = Printexc.register_printer
  (function Not_initialized s ->
       Some (Printf.sprintf "HTTP module %s not initialized" s) | _ -> None)
let dummy_requests name =
  let module M : Requests =
  struct
    let dbg _ = Lwt.return_unit
    let call ?body ?headers _ _ = raise (Not_initialized name)
  end
  in
  (module M: Requests)

module type Cache =
  sig
    val clear : unit -> unit Lwt.t
    val get :
      (?headers: Header.t -> Iri.t ->
       (Response.t * Cohttp_lwt.Body.t) Lwt.t) ->
        ?headers:Header.t -> Iri.t -> (Response.t * string) Lwt.t
  end

module type Http =
  sig
    module Cache : Cache
    module Requests : Requests
    val dbg : string -> unit Lwt.t
    val head : ?follow:int -> ?headers:Header.t -> Iri.t -> (Types.meta, query_error) result Lwt.t
    val head_exn : ?follow:int -> ?headers:Header.t -> Iri.t -> Types.meta Lwt.t
    val get_non_rdf : ?follow:int -> ?headers:Header.t ->
      ?accept:Ct.t list -> Iri.t -> ((Ct.t * string), query_error) result Lwt.t
    val get_non_rdf_exn : ?follow:int -> ?headers:Header.t ->
      ?accept:Ct.t list -> Iri.t -> (Ct.t * string) Lwt.t
    val get_rdf : ?g:Rdf.Graph.graph -> ?follow:int ->
      ?headers:Header.t -> ?accept:Ct.t list -> ?parse: bool -> Iri.t ->
        (string * Rdf.Graph.graph option, Types.error) result Lwt.t
    val get_rdf_exn : ?g:Rdf.Graph.graph -> ?follow:int ->
      ?headers:Header.t -> ?accept:Ct.t list -> ?parse: bool -> Iri.t ->
        (string * Rdf.Graph.graph option) Lwt.t
    val get_rdf_graph : ?g:Rdf.Graph.graph -> ?follow:int ->
      ?headers:Header.t -> ?accept:Ct.t list -> Iri.t ->
        (Rdf.Graph.graph, Types.error) result Lwt.t
    val get_rdf_graph_exn : ?g:Rdf.Graph.graph -> ?follow:int ->
      ?headers:Header.t -> ?accept:Ct.t list -> Iri.t ->
        Rdf.Graph.graph Lwt.t
    val get_container : ?g:Rdf.Graph.graph -> ?follow:int ->
      ?headers:Header.t -> ?accept:Ct.t list -> Iri.t ->
        (Rdf.Graph.graph, Types.error) result Lwt.t
    val get_container_exn : ?g:Rdf.Graph.graph -> ?follow:int ->
      ?headers:Header.t -> ?accept:Ct.t list -> Iri.t ->
        Rdf.Graph.graph Lwt.t
    val get : ?follow:int -> ?headers:Header.t -> ?accept:Ct.t list ->
      ?parse:bool -> Iri.t -> (Types.resource, Types.error) result Lwt.t
    val get_exn : ?follow:int -> ?headers:Header.t -> ?accept:Ct.t list ->
      ?parse:bool -> Iri.t -> Types.resource Lwt.t
    val post :
      ?headers:Header.t -> ?data:string ->
        ?ct:Ct.t -> ?slug:string -> ?typ:Iri.t -> Iri.t ->
        (Types.meta, query_error) result Lwt.t
    val post_exn :
      ?headers:Header.t -> ?data:string ->
        ?ct:Ct.t -> ?slug:string -> ?typ:Iri.t -> Iri.t ->
        Types.meta Lwt.t
    val post_container : ?headers:Header.t -> ?data: Rdf.Graph.graph ->
      ?slug:string -> Iri.t -> (Types.meta, query_error) result Lwt.t
    val post_container_exn : ?headers:Header.t -> ?data: Rdf.Graph.graph ->
      ?slug:string -> Iri.t -> Types.meta Lwt.t
    val post_direct_container : ?headers:Header.t -> ?data: Rdf.Graph.graph ->
      ?slug:string -> ?membershipResource: Iri.t ->
        relation: [< `HasMember of Iri.t | `IsMemberOf of Iri.t ] ->
          Iri.t -> (Types.meta, query_error) result Lwt.t
    val post_direct_container_exn : ?headers:Header.t -> ?data: Rdf.Graph.graph ->
      ?slug:string -> ?membershipResource: Iri.t ->
        relation: [< `HasMember of Iri.t | `IsMemberOf of Iri.t ] ->
          Iri.t -> Types.meta Lwt.t
    val post_indirect_container : ?headers:Header.t -> ?data: Rdf.Graph.graph ->
      ?slug:string -> ?membershipResource: Iri.t ->
        relation: [< `HasMember of Iri.t | `IsMemberOf of Iri.t ] ->
          insertedContent: Iri.t -> Iri.t -> (Types.meta, query_error) result Lwt.t
    val post_indirect_container_exn : ?headers:Header.t -> ?data: Rdf.Graph.graph ->
      ?slug:string -> ?membershipResource: Iri.t ->
        relation: [< `HasMember of Iri.t | `IsMemberOf of Iri.t ] ->
          insertedContent: Iri.t -> Iri.t -> Types.meta Lwt.t
    val post_rdf :
      ?headers:Header.t -> ?data:Rdf.Graph.graph ->
      ?slug:string -> ?typ: Iri.t -> Iri.t -> (Types.meta, query_error) result Lwt.t
    val post_rdf_exn :
      ?headers:Header.t -> ?data:Rdf.Graph.graph ->
      ?slug:string -> ?typ: Iri.t -> Iri.t -> Types.meta Lwt.t
    val post_non_rdf : ?headers:Header.t ->
      ?data:string -> ?ct:Ct.t -> Iri.t -> (Types.meta, query_error) result Lwt.t
    val post_non_rdf_exn : ?headers:Header.t ->
      ?data:string -> ?ct:Ct.t -> Iri.t -> Types.meta Lwt.t
    val put : ?headers:Header.t -> ?data:string ->
      ?ct:Ct.t -> ?typ: Iri.t -> Iri.t -> (Types.meta, query_error) result Lwt.t
    val put_exn : ?headers:Header.t -> ?data:string ->
      ?ct:Ct.t -> ?typ: Iri.t -> Iri.t -> Types.meta Lwt.t
    val put_rdf : ?headers:Header.t -> data: Rdf.Graph.graph ->
      ?typ:Iri.t -> Iri.t -> (Types.meta, query_error) result Lwt.t
    val put_rdf_exn : ?headers:Header.t -> data: Rdf.Graph.graph ->
      ?typ:Iri.t -> Iri.t -> Types.meta Lwt.t
    val patch_with_query : ?headers:Header.t -> Iri.t -> string ->
      (Types.meta, query_error) result Lwt.t
    val patch_with_query_exn : ?headers:Header.t -> Iri.t -> string -> Types.meta Lwt.t
    val patch : ?headers:Header.t ->
      ?del:Rdf.Graph.graph -> ?ins:Rdf.Graph.graph -> Iri.t ->
        (Types.meta, query_error) result Lwt.t
    val patch_exn : ?headers:Header.t ->
      ?del:Rdf.Graph.graph -> ?ins:Rdf.Graph.graph -> Iri.t -> Types.meta Lwt.t
    val delete : ?headers:Header.t -> Iri.t -> (Types.meta, query_error) result Lwt.t
    val delete_exn : ?headers:Header.t -> Iri.t -> Types.meta Lwt.t
    val login : ?headers:Header.t -> Iri.t ->
      (string option, query_error) result Lwt.t
    val login_exn : ?headers:Header.t -> Iri.t -> string option Lwt.t
    val fold_get :
      ?onerror:[ `Fail | `Ignore | `Report of exn -> unit Lwt.t ] ->
        ?follow:int -> ?headers:Header.t -> ?accept:Ct.t list ->
        ?parse:bool ->
        ('a -> Types.resource -> 'a Lwt.t) ->
        'a -> Iri.t list -> 'a Lwt.t
    val fold_get_graph :
      ?onerror:[ `Fail | `Ignore | `Report of exn -> unit Lwt.t ] ->
      ?follow:int -> ?headers:Header.t ->
      Rdf.Graph.graph -> Iri.t list -> unit Lwt.t

  end


type cache_find_response =
  | Not_found
  | Found of (Response.t * string)
  | If_error of (Response.t -> string -> (Response.t * string) Lwt.t)

module type Cache_impl =
  sig
    type key
    val clear : unit -> unit Lwt.t
    val key : Header.t -> Iri.t -> key option
    val store : key -> Response.t -> string -> (Response.t * string) Lwt.t
    val find : key -> cache_find_response Lwt.t
  end

module Make_cache (I:Cache_impl) : Cache =
  struct
    let empty_headers = Header.init ()

    let clear = I.clear
    let get (call_get : ?headers: Header.t -> Iri.t -> (Response.t * Cohttp_lwt.Body.t) Lwt.t)
      ?(headers=empty_headers) iri =
      let headers_nocookie = Header.remove headers "cookie" in
      match I.key headers_nocookie iri with
      | None ->
           let%lwt (resp, body) = call_get ~headers iri in
           let%lwt body = Cohttp_lwt.Body.to_string body in
           Lwt.return (resp, body)
      | Some key ->
          match%lwt I.find key with
          | Found x -> Lwt.return x
          | r ->
              let%lwt (resp, body) = call_get ~headers iri in
              let%lwt body = Cohttp_lwt.Body.to_string body in
              match (Code.code_of_status resp.Response.status) / 100 with
              | 2 -> I.store key resp body
              | _ ->
                  match r with
                  | If_error f -> f resp body
                  | _ -> Lwt.return (resp, body)
  end

module No_cache = Make_cache
  (struct
    type key = unit
    let clear () = Lwt.return_unit
    let key _ _ = None
    let store _ _ = assert false
    let find _ = assert false
   end)

let parse_graph ?g iri ct str =
  let g =
    match g with
      None -> Rdf.Graph.open_graph (Iri.with_fragment iri None)
    | Some g -> g
  in
  if Ct.has_mime ct Ct.mime_turtle then
    begin
      try Rdf.Ttl.from_string g str; Result.ok g
      with e ->
          Result.error (Types.Parse_error (iri, e))
      end
  else
    if Ct.has_mime ct Ct.mime_xmlrdf then
      begin
        try Rdf.Xml.from_string g str; Result.ok g
        with e ->
            Result.error (Types.Parse_error (iri, e))
      end
    else
      Result.error (Types.Unsupported_format (iri, Ct.to_mime ct))


let to_exn v =
  match%lwt v with
  | Stdlib.Error e -> Types.fail e
  | Ok v -> Lwt.return v
  | exception e -> Types.fail (Other e)

let to_query_error_exn v =
  match%lwt v with
  | Stdlib.Error e -> Types.fail (Query_error e)
  | Ok v -> Lwt.return v
  | exception e -> Types.fail (Other e)

module Cached_http (C:Cache) (P:Requests) =
  struct
    module Cache = C
    module Requests = P
    let dbg = P.dbg

    let get_location meta =
      let h = let (resp, _) = meta.Types.info in resp.Cohttp.Response.headers in
      match Cohttp.Header.get h "location" with
      | None -> None
      | Some s ->
          try Some (Iri.of_string s)
          with _ ->
              Log.debug (fun m -> m "Invalid redirection iri %S" s);
              None

    let rec head ?(follow=1) ?headers iri = P.call ?headers `HEAD iri >>= fun (resp, body) ->
      let code = Code.code_of_status resp.Response.status in
      let meta = response_metadata iri (resp, body) in
      match code / 100 with
      | 3 when follow > 0 ->
          (match get_location meta with
           | Some iri2 ->
               let iri = Iri.resolve ~base:iri iri2 in
               Log.debug (fun m -> m "Following redirection (%d) to %a" code Iri.pp iri);
               head ~follow:(follow-1) ?headers iri
           | None -> Lwt.return_error (`HEAD, code, meta)
            )
      | 2 -> Lwt.return_ok meta
      | _ -> Lwt.return_error (`HEAD, code, meta)

    let head_exn ?follow ?headers iri = to_query_error_exn (head ?follow ?headers iri)

    let cached_get =
      let call_get ?headers iri = P.call ?headers `GET iri in
      C.get call_get

    let rec get_non_rdf ?(follow=1) ?(headers=Header.init ()) ?accept iri =
      let headers =
        match accept with
          None -> headers
        | Some m -> Header.add headers "Accept"
             (String.concat "," (List.map Ct.to_string m))
      in
      cached_get ~headers iri >>= fun (resp, body) ->
      let code = Code.code_of_status resp.Response.status in
      match code / 100 with
      | 3 when follow > 0 ->
          (
           let meta = response_metadata iri (resp, `String body) in
           match get_location meta with
           | Some iri2 ->
               let iri = Iri.resolve ~base:iri iri2 in
               Log.debug (fun m -> m "Following redirection (%d) to %a" code Iri.pp iri);
               get_non_rdf ~follow:(follow-1) ~headers ?accept:None iri
           | None -> Lwt.return_error (`GET, code, meta)
          )
      | 2 ->
          let content_type =
            match Header.get resp.Response.headers "Content-type" with
              None -> Ct.default
            | Some str ->
                match Ct.of_string str with
                | Ok ct -> ct
                | Error _ -> Ct.default
          in
          Lwt.return_ok (content_type, body)
      | _ ->
          Lwt.return_error (`GET, code, response_metadata iri (resp, `String body))

    let get_non_rdf_exn ?follow ?headers ?accept iri =
      to_query_error_exn (get_non_rdf ?follow ?headers ?accept iri)

    let get_rdf ?g ?follow ?headers ?(accept=[Ct.ct_turtle]) ?(parse=(g<>None)) iri =
      get_non_rdf ?follow ?headers ~accept iri >>=
      function
        | Result.Error qe -> Lwt.return_error (Query_error qe)
        | Ok (content_type, str) ->
          let%lwt () = Log.debug_lwt (fun f -> f "%s" str) in
          if parse then
            match parse_graph ?g iri content_type str with
            | Result.Error e -> Lwt.return_error e
            | Ok res -> Lwt.return_ok (str, Some res)
          else
            Lwt.return_ok (str, None)

    let get_rdf_exn ?g ?follow ?headers ?accept ?parse iri =
      to_exn (get_rdf ?g ?follow ?headers ?accept ?parse iri)

    let get_rdf_graph ?g ?follow ?headers ?accept iri =
      match%lwt get_rdf ?g ?follow ?headers ?accept ~parse:true iri with
      | Result.Error e -> Lwt.return_error e
      | Ok (_, Some g) -> Lwt.return_ok g
      | Ok (_, None) -> assert false (* we must have a graph, because we parse *)

    let get_rdf_graph_exn ?g ?follow ?headers ?accept iri =
      to_exn (get_rdf_graph ?g ?follow ?headers ?accept iri)

    let get_container = get_rdf_graph
    let get_container_exn = get_rdf_graph_exn

    let rec get ?(follow=1) ?(headers=Header.init())
      ?(accept=[Ct.ct_turtle ; Ct.create (Ct.Ietf "*") "*"])
      ?(parse=true) iri =
      let headers = Header.add_multi headers
        "Accept" (List.map Ct.to_string accept)
      in
      cached_get ~headers iri >>= fun (resp, body) ->
      let code = Code.code_of_status resp.Response.status in
      let meta = response_metadata iri (resp, `String body) in
      match code / 100 with
      | 3 when follow > 0 ->
          (
           match get_location meta with
           | Some iri2 ->
               let iri = Iri.resolve ~base:iri iri2 in
               Log.debug (fun m -> m "Following redirection (%d) to %a" code Iri.pp iri);
               get ~follow:(follow-1) ~headers ?accept:None ~parse iri
           | None ->  Lwt.return_error (Query_error (`GET, code, meta))
          )
      | n when n <> 2 ->
          Lwt.return_error (Query_error (`GET, code, meta))
      | _ ->
          let header = resp.Response.headers in
          let ct =
            match Header.get header "Content-type" with
            | None -> Ct.default
            | Some s ->
                match Ct.of_string s with
                | Ok ct -> ct
                | Error _ -> Ct.default
          in
          if parse && (Ct.has_mime ct Ct.mime_turtle || Ct.has_mime ct Ct.mime_xmlrdf) then
            let g = Rdf.Graph.open_graph iri in
            begin
              match parse_graph ~g iri ct body with
              | Result.Error e -> Lwt.return_error e
              | Ok g ->
                  let resource = { meta ; graph = g ; ct ; contents = body } in
                  if is_container g then
                    Lwt.return_ok (Container resource)
                  else
                    Lwt.return_ok (Rdf resource)
            end
          else
            let resource = { meta ; ct ; contents = body} in
            Lwt.return_ok (Non_rdf resource)

    let get_exn ?follow ?headers ?accept ?parse iri =
      to_exn (get ?follow ?headers ?accept ?parse iri)

    let post ?(headers=Header.init()) ?data ?(ct=Ct.ct_turtle) ?slug ?typ iri =
      let headers =
        let h = Header.add headers "Content-type" (Ct.to_string ct) in
        let h =
          match typ with
          | None -> h
          | Some typ ->
              Header.add h
                "Link" (Printf.sprintf "<%s>; rel=\"type\"" (Iri.to_string typ))
        in
        let h =
          match slug with
            None | Some "" -> h
          | Some str -> Header.add h "Slug" str
        in
        h
      in
      (*prerr_endline
        (let s =
          Cohttp.Header.pp_hum Format.str_formatter headers ;
          Format.flush_str_formatter ()
         in
         Printf.sprintf "request header=%s" s);*)
      let body = Option.map (fun s -> `String s) data in
      P.call ~headers ?body `POST iri
        >>= fun (resp, body) ->
      let code = Code.code_of_status resp.Response.status in
        match code / 100 with
        | 2 -> Lwt.return_ok (response_metadata iri (resp, body))
        | _ -> Lwt.return_error (`POST, code, response_metadata iri (resp, body))

    let post_exn ?headers ?data ?ct ?slug ?typ iri =
      to_query_error_exn (post ?headers ?data ?ct ?slug ?typ iri)

    let post_rdf ?headers ?data ?slug ?(typ=Rdf.Ldp.c_RDFSource) iri =
      let data = Option.map Rdf.Ttl.to_string data in
      post ?headers ?data ?slug ~typ iri

    let post_rdf_exn ?headers ?data ?slug ?typ iri =
      to_query_error_exn (post_rdf ?headers ?data ?slug ?typ iri)

    let empty_iri = Iri.of_string ""

    let mk_container ?(data=Rdf.Graph.open_graph empty_iri)
     ?membershipResource ?relation ?insertedContent typ =
      let open Rdf.Graph in
      let open Rdf.Term in
      let add = data.add_triple ~sub: (Iri empty_iri) in
      add ~pred: Rdf.Rdf_.type_ ~obj: (Iri Rdf.Ldp.c_Container);
      add ~pred: Rdf.Rdf_.type_ ~obj: (Iri typ);
      (
       match membershipResource with
         None -> ()
       | Some iri ->
           add ~pred: Rdf.Ldp.membershipResource
             ~obj: (Iri iri)
      );
      (
       match relation with
       | None -> ()
       | Some (`HasMember iri) ->
           add ~pred: Rdf.Ldp.hasMemberRelation
             ~obj: (Iri iri)
       | Some (`IsMemberOf iri) ->
           add ~pred: Rdf.Ldp.isMemberOfRelation
             ~obj: (Iri iri)
      );
      (match insertedContent with
         None -> ()
       | Some iri -> add ~pred: Rdf.Ldp.insertedContentRelation ~obj: (Iri iri)
      );
      data

    let post_container ?headers ?data ?slug iri =
      let data = mk_container ?data Rdf.Ldp.c_BasicContainer in
      post_rdf ?headers ~data ?slug ~typ: Rdf.Ldp.c_BasicContainer iri

    let post_container_exn ?headers ?data ?slug iri =
      to_query_error_exn (post_container ?headers ?data ?slug iri)

    let post_direct_container ?headers ?data ?slug ?membershipResource ~relation iri =
      let membershipResource =
        match membershipResource with
          None -> empty_iri
        | Some iri -> iri
      in
      let data = mk_container ?data
        ~membershipResource ~relation
          Rdf.Ldp.c_DirectContainer
      in
      post_rdf ?headers ~data ?slug ~typ: Rdf.Ldp.c_DirectContainer iri

    let post_direct_container_exn ?headers ?data ?slug
      ?membershipResource ~relation iri =
      to_query_error_exn
        (post_direct_container ?headers ?data ?slug ?membershipResource ~relation iri)

    let post_indirect_container ?headers ?data
      ?slug ?membershipResource ~relation ~insertedContent iri =
      let membershipResource =
        match membershipResource with
          None -> empty_iri
        | Some iri -> iri
      in
      let data = mk_container ?data
        ~membershipResource ~relation ~insertedContent
          Rdf.Ldp.c_IndirectContainer
      in
      post_rdf ?headers ~data ?slug ~typ: Rdf.Ldp.c_IndirectContainer iri

    let post_indirect_container_exn ?headers ?data ?slug
      ?membershipResource ~relation ~insertedContent iri =
      to_query_error_exn
        (post_indirect_container ?headers ?data ?slug
         ?membershipResource ~relation ~insertedContent iri)

    let put ?(headers=Header.init()) ?data ?(ct=Ct.ct_turtle) ?(typ=Rdf.Ldp.c_NonRDFSource) iri =
      let body = Option.map (fun s -> `String s) data in
      let headers = Header.add headers "Content-type" (Ct.to_string ct) in
      let headers =
        Header.add headers
          "Link" (Printf.sprintf "<%s>; rel=\"type\"" (Iri.to_string typ))
      in
      P.call ~headers ?body `PUT iri
      >>= fun (resp, body) ->
        let code = Code.code_of_status resp.Response.status in
        match code / 100 with
        | 2 -> Lwt.return_ok (response_metadata iri (resp, body))
        | _ -> Lwt.return_error (`PUT, code, response_metadata iri (resp, body))

    let put_exn ?headers ?data ?ct ?typ iri =
      to_query_error_exn (put ?headers ?data ?ct ?typ iri)

    let put_rdf ?headers ~data:g ?(typ=Rdf.Ldp.c_RDFSource) iri =
      put ?headers ~data:(Rdf.Ttl.to_string g) ~ct:Ct.ct_turtle ~typ iri

    let put_rdf_exn ?headers ~data ?typ iri =
      to_query_error_exn (put_rdf ?headers ~data ?typ iri)

    let post_non_rdf ?headers ?data ?ct iri =
      post ?headers ?data ?ct ~typ: Rdf.Ldp.c_NonRDFSource iri

    let post_non_rdf_exn ?headers ?data ?ct iri =
      to_query_error_exn (post_non_rdf ?headers ?data ?ct iri)

    let patch_with_query ?(headers=Header.init()) iri query =
      let body = `String query in
      let headers = Header.add headers
        "Content-type" (Ct.mime_to_string Ct.mime_sparql_update)
      in
      P.call ~headers ~body `PATCH iri
        >>= fun (resp, body) ->
        let code = Code.code_of_status resp.Response.status in
        match code / 100 with
        | 2 -> Lwt.return_ok (response_metadata iri (resp, body))
        | _ -> Lwt.return_error (`PATCH, code, response_metadata iri (resp, body))

    let patch_with_query_exn ?headers iri query =
       to_query_error_exn (patch_with_query ?headers iri query)

    let patch ?headers ?del ?ins iri =
      let b = Buffer.create 256 in
      (match del with
         None -> ()
       | Some g ->
           Printf.bprintf b "DELETE DATA { %s }\n"
             (Rdf.Ttl.to_string g)
      );
      (match ins with
         None -> ()
       | Some g ->
           Printf.bprintf b "%sINSERT DATA { %s }\n"
             (match del with None -> "" | Some _ -> ";\n")
             (Rdf.Ttl.to_string g)
      );
      let query = Buffer.contents b in
      patch_with_query ?headers iri query

    let patch_exn ?headers ?del ?ins iri =
      to_query_error_exn (patch ?headers ?del ?ins iri)

    let delete ?headers iri =
      P.call ?headers `DELETE iri
      >>= fun (resp, body) ->
        let code = Code.code_of_status resp.Response.status in
        match code / 100 with
        | 2 -> Lwt.return_ok (response_metadata iri (resp, body))
        | _ -> Lwt.return_error (`DELETE, code, response_metadata iri (resp, body))

    let delete_exn ?headers iri = to_query_error_exn (delete ?headers iri)

    let login ?headers iri =
      P.dbg (Printf.sprintf "login, iri=%s" (Iri.to_string iri)) >>= fun () ->
        head ?headers iri >>= function
    | Result.Ok meta -> Lwt.return_ok meta.user
    | Error qe -> Lwt.return_error qe

    let login_exn ?headers iri = to_query_error_exn (login ?headers iri)

    let fold_get ?(onerror=`Fail) ?follow ?headers ?accept ?parse f acc iris =
      let g acc iri =
        match%lwt get_exn ?follow ?headers ?accept ?parse iri with
        | r -> f acc r
        | exception e ->
           begin
             match onerror with
               `Fail -> Lwt.fail e
             | `Ignore -> Lwt.return acc
             | `Report rep -> let%lwt () = rep e in Lwt.return acc
           end
      in
      Lwt_list.fold_left_s g acc iris

    let fold_get_graph ?onerror ?follow ?headers g iris =
      let f () = function
      | Container r | Rdf r -> Rdf.Graph.merge g r.graph; Lwt.return_unit
      | Non_rdf _ ->  Lwt.return_unit
      in
      fold_get ?onerror ?follow ?headers ~parse: true f () iris
  end

module Http (P:Requests) = Cached_http (No_cache) (P)

module type Ct_wrapper = sig
    type t
    val ct : Ct.t
    val to_string : t -> string
    val of_string : string -> t
  end

module type Http_ct = sig
    type t
    val dbg : string -> unit Lwt.t
    val get : ?follow:int -> ?headers:Header.t  -> Iri.t ->
      (t option * Types.non_rdf_resource, Types.error) result Lwt.t
    val get_exn : ?follow:int -> ?headers:Header.t  -> Iri.t -> (t option * Types.non_rdf_resource) Lwt.t
    val post : ?headers:Header.t -> ?data:t -> ?slug:string ->
      Iri.t -> (t option * Types.meta, query_error) result Lwt.t
    val post_exn : ?headers:Header.t -> ?data:t -> ?slug:string ->
      Iri.t -> (t option * Types.meta) Lwt.t
    val put : ?headers:Header.t -> ?data:t -> Iri.t ->
      (t option * Types.meta, query_error) result Lwt.t
    val put_exn : ?headers:Header.t -> ?data:t -> Iri.t -> (t option * Types.meta) Lwt.t
    val fold_get :
      ?onerror:[ `Fail | `Ignore | `Report of exn -> unit Lwt.t ] ->
        ?follow:int -> ?headers:Header.t ->
        ('a -> t option * Types.non_rdf_resource -> 'a Lwt.t) ->
        'a -> Iri.t list -> 'a Lwt.t
  end

module Http_ct (H:Http) (W:Ct_wrapper) = struct
    type t = W.t
    let accept_mime = Ct.to_mime W.ct
    let dbg = H.dbg
    let t_of_body body =
      match%lwt Cohttp_lwt.Body.to_string body with
      | "" -> Lwt.return_none
      | body ->
          match W.of_string body with
          | v -> Lwt.return_some v
          | exception e -> Types.fail (Invalid_response_data (W.ct, body, e))

    let of_resource = function
    | Types.Container r | Rdf r -> Lwt.return_error (Unexpected_resource (W.ct, r.ct))
    | Non_rdf r when Ct.to_mime r.ct <> accept_mime ->
        let%lwt body =  Cohttp_lwt.Body.to_string (snd r.meta.info) in
        Log.debug (fun m -> m "body=%s" body) ;
        Lwt.return_error (Unexpected_resource (W.ct, r.ct))
    | Non_rdf r ->
        let%lwt v = t_of_body (snd r.meta.info) in
        Lwt.return_ok (v, r)

    let of_resource_exn v = to_exn (of_resource v)

    let get ?follow ?headers iri =
      Log.debug (fun m -> m "GET %s\n%s" (Iri.to_string iri)
         (Option.value ~default:"" (Option.map Cohttp.Header.to_string headers)));
      match%lwt H.get ?follow ?headers ~accept:[W.ct] ~parse:false iri with
      | Error e -> Lwt.return_error e
      | Ok r -> of_resource r
    let get_exn ?follow ?headers iri = to_exn (get ?headers iri)

    let post ?headers ?data ?slug iri =
      let headers = match headers with
        | None -> Cohttp.Header.init ()
        | Some h -> h
      in
      let headers = Cohttp.Header.add headers "accept" (Ct.to_string W.ct) in
      let data = Option.map W.to_string data in
      match%lwt H.post ~headers ?data ~ct:W.ct ?slug iri with
      | Stdlib.Error e -> Lwt.return_error e
      | Ok meta ->
          let%lwt v = t_of_body (snd meta.info) in
          Lwt.return_ok (v, meta)

    let post_exn ?headers ?data ?slug iri =
      to_query_error_exn (post ?headers ?data ?slug iri)

    let put ?headers ?data iri =
      let headers = match headers with
        | None -> Cohttp.Header.init ()
        | Some h -> h
      in
      let headers = Cohttp.Header.add headers "accept" (Ct.to_string W.ct) in
      let data = Option.map W.to_string data in
      match%lwt H.put ~headers ?data ~ct:W.ct iri with
      | Stdlib.Error e -> Lwt.return_error e
      | Ok meta ->
          let%lwt v = t_of_body (snd meta.info) in
          Lwt.return_ok (v, meta)

    let put_exn ?headers ?data iri = to_query_error_exn (put ?headers ?data iri)

    let fold_get ?onerror ?follow ?headers f acc iris =
      let f acc r =
        let%lwt x = of_resource_exn r in
        f acc x
      in
      H.fold_get ?onerror ?follow ?headers ~accept:[W.ct] ~parse:false f acc iris

  end