Source file ldp_tls.ml

(*********************************************************************************)
(*                OCaml-LDP                                                      *)
(*                                                                               *)
(*    Copyright (C) 2016-2023 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                                          *)
(*                                                                               *)
(*********************************************************************************)

open Lwt.Infix

module IO =
  struct
    type 'a t = 'a Lwt.t
    let (>>=) = Lwt.bind
    let return = Lwt.return

    type ic = Lwt_io.input_channel
    type oc = Lwt_io.output_channel
    type conn = ic * oc

    let read_line ic = Lwt_io.read_line_opt ic
    let read ic count = Lwt_io.read ~count ic
    let write oc buf = Lwt_io.write oc buf
    let flush oc = Lwt_io.flush oc

    type error = exn

    let catch f =
      match%lwt f () with
      | exception e -> return (Result.error e)
      | v -> return (Result.ok v)

    let pp_error f e =
      let msg = Printexc.to_string e in
      Format.pp_print_string f msg
  end

module Tls_net =
  struct
    module IO = IO
    type ctx = Tls.Config.client
    let default_ctx =
      let authenticator ?ip ~host:_ _ = Ok None in
      (*let authenticator = X509.Authenticator.chain_of_trust [] in*)
      Tls.Config.(client ~authenticator ())

    let connect_uri ~ctx uri =
      let host = match Uri.host uri with None -> "" | Some s -> s in
      let port = match Uri.port uri with None -> 443 | Some n -> n in
      Tls_lwt.connect_ext
        (*~trace:eprint_sexp*)
        ctx (host, port)
        >>= fun (ic, oc) -> Lwt.return ((ic, oc), ic, oc)

    let close c = Lwt.catch (fun () -> Lwt_io.close c) (fun _ -> Lwt.return_unit)
    let close_in ic = Lwt.ignore_result (close ic)
    let close_out oc = Lwt.ignore_result (close oc)
    let close ic oc = Lwt.ignore_result (close ic >>= fun () -> close oc)

    let sexp_of_ctx _ = failwith "sexp_of_ctx not implemented"
end

module Client = Cohttp_lwt.Make_client (IO) (Tls_net)

let client_call = Client.call

module type P =
  sig
    val dbg : string -> unit Lwt.t
    val authenticator : X509.Authenticator.t
    val certificates : Tls.Config.own_cert
  end

module Make (P:P) : Ldp.Http.Requests =
  struct
    let dbg = P.dbg

    include Ldp.Cookies.Make ()

    let call ?body ?(headers=Cohttp.Header.init()) meth iri =
      let headers = Cohttp.Header.prepend_user_agent headers !Ldp.Http.user_agent in
      let headers =
        match cookies_by_iri iri with
        | [] -> headers
        | cookies ->
            (*List.iter
               (fun (k, v) -> prerr_endline (Printf.sprintf "setting cookie: %s => %s" k v))
               cookies;*)
            let (k, v) = Cohttp.Cookie.Cookie_hdr.serialize cookies in
            Cohttp.Header.add headers k v
      in
      let ctx =
        Tls.Config.client
          ~authenticator: P.authenticator ~certificates: P.certificates
          (*~version:(`TLS_1_2,`TLS_1_3)*)
          ()
      in
      (*let%lwt dbgbody = match body with
        | None -> Lwt.return "no body"
        | Some b -> Cohttp_lwt.Body.to_string b
      in
      Ldp.Log.debug (fun m -> m "%s %s\n%sbody=%s"
         (Cohttp.Code.string_of_method meth)
           (Iri.to_string iri)
           (match headers with None -> "<no headers>\n"
            | Some h -> Cohttp.Header.to_string h)
           dbgbody
      );*)
      match%lwt Client.call ~ctx ?body ~headers meth
        (Uri.of_string (Iri.to_uri iri))
      with
      | exception e ->
          Ldp.Types.(fail (Request_error (iri, Printexc.to_string e)))
      | (resp, body) ->
          let () =
            let cookies = Cohttp.Cookie.Set_cookie_hdr.extract resp.Cohttp.Response.headers in
            match cookies with
            | [] -> ()
            | _ ->
                remove_expired_cookies () ;
                List.iter (add_cookie iri) (List.map snd cookies) ;
          in
          Lwt.return (resp, body)
  end

let (dummy_authenticator : X509.Authenticator.t) = fun ?ip ~host certs -> Ok None


let make ?cache_impl ?cache_dir
  ?(authenticator=dummy_authenticator) ?cert ~dbg () =
  (*let%lwt authenticator = X509_lwt.authenticator `No_authentication_I'M_STUPID in*)
(*  let%lwt authenticator = X509_lwt.authenticator (`Ca_dir cert_dir) in*)
  let%lwt certificates =
    match cert with
    | None -> Lwt.return `None
    | Some (cert, priv_key) ->
        X509_lwt.private_of_pems ~cert ~priv_key >>=
          fun c -> Lwt.return (`Single c)
  in
  let module P =
  struct
    let dbg = dbg
    let authenticator = authenticator
    let certificates = certificates
  end
  in
  let%lwt cache =
    match cache_impl, cache_dir with
    | None, None -> Lwt.return (module Ldp.Http.No_cache : Ldp.Http.Cache)
    | Some c, _ -> Lwt.return c
    | _, Some dir -> Ldp.Cache.of_dir dir
  in
  let module C = (val cache: Ldp.Http.Cache) in
  let module H = Ldp.Http.Cached_http (C) (Make(P)) in
  Lwt.return (module H : Ldp.Http.Http)