pgx_mirage.ml

(* Draft for cherry-picking into pgx.
 *
 * Copyright (C) 2020 Petter A. Urkedal
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Library General Public
 * License as published by the Free Software Foundation; either
 * version 2 of the License, or (at your option) any later version,
 * with the OCaml static compilation exception.
 *
 * This library 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
 * Library General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this library; see the file COPYING.  If not, write to
 * the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 * Boston, MA 02111-1307, USA.
 *)

open Lwt.Infix

module Make
    (Random : Mirage_random.S)
    (Clock : Mirage_clock.MCLOCK)
    (Stack : sig include Mirage_stack.V4 val singleton : t end) =
struct
  module Channel = Mirage_channel.Make (Conduit_mirage.Flow)
  module Resolver = Dns_client_mirage.Make (Random) (Clock) (Stack)

  let dns = Resolver.create Stack.singleton

  include Pgx.Make (struct

    type 'a t = 'a Lwt.t
    let return = Lwt.return
    let (>>=) = Lwt.(>>=)
    let catch = Lwt.catch

    type in_channel = Channel.t
    type out_channel = Channel.t
    type sockaddr =
      | Unix of string
      | Inet of string * int

    let open_connection sockaddr =
      let%lwt conduit =
        Conduit_mirage.(with_tcp empty (stackv4 (module Stack)) Stack.singleton)
      in
      let%lwt client =
        (match sockaddr with
         | Unix _ ->
            Lwt.fail_with "UNIX socket not available on MirageOS."
         | Inet (host, port) ->
            (match Ipaddr.of_string host with
             | Ok ipaddr -> Lwt.return (`TCP (ipaddr, port))
             | Error _ ->
                let domain_name =
                  Domain_name.of_string_exn host |> Domain_name.host_exn in
                (match%lwt Resolver.gethostbyname dns domain_name with
                 | Error (`Msg msg) ->
                    Lwt.fail_with ("Failed PostgreSQL server: " ^ msg)
                 | Ok ipaddr ->
                    Lwt.return (`TCP (Ipaddr.V4 ipaddr, port)))))
      in
      let%lwt flow = Conduit_mirage.connect conduit client in
      let ch = Channel.create flow in
      Lwt.return (ch, ch)

    let output_char oc c = Channel.write_char oc c; Lwt.return_unit

    let output_binary_int oc n =
      Channel.write_char oc (Char.chr (n lsr 24));
      Channel.write_char oc (Char.chr (n lsr 16 land 255));
      Channel.write_char oc (Char.chr (n lsr 8 land 255));
      Channel.write_char oc (Char.chr (n land 255));
      Lwt.return_unit

    let output_string oc s =
      Channel.write_string oc s 0 (String.length s);
      Lwt.return_unit

    let flush oc =
      (match%lwt Channel.flush oc with
       | Ok () -> Lwt.return_unit
       | Error err ->
          Lwt.fail_with (Fmt.to_to_string Channel.pp_write_error err))

    let input_char ic =
      (match%lwt Channel.read_char ic with
       | Ok (`Data c) -> Lwt.return c
       | Ok `Eof -> Lwt.fail End_of_file
       | Error err -> Lwt.fail_with (Fmt.to_to_string Channel.pp_error err))

    let really_input ic obuf pos len =
      (match%lwt Channel.read_exactly ~len ic with
       | Ok (`Data ibufs) ->
          let rec loop opos = function
           | [] -> Lwt.return_unit
           | ibuf :: ibufs ->
              let ilen = Cstruct.len ibuf in
              Cstruct.blit_to_bytes ibuf 0 obuf opos ilen;
              loop (opos + ilen) ibufs
          in
          loop pos ibufs
       | Ok `Eof -> Lwt.fail_with "Unexpected EOF"
       | Error err -> Lwt.fail_with (Fmt.to_to_string Channel.pp_error err))

    let input_binary_int ic =
      let buf = Bytes.create 4 in
      really_input ic buf 0 4 >|= fun () ->
      (Char.code (Bytes.get buf 0) lsl 24) lor
      (Char.code (Bytes.get buf 1) lsl 16) lor
      (Char.code (Bytes.get buf 2) lsl 8) lor
      (Char.code (Bytes.get buf 3))

    let close_in ic =
      (match%lwt Channel.close ic with
       | Ok () -> Lwt.return ()
       | Error err ->
          Lwt.fail_with (Fmt.to_to_string Channel.pp_write_error err))

    let getlogin () = Lwt.return "unikernel" (* TODO: Other default or fail? *)
    let debug s = Logs_lwt.debug (fun m -> m "%s" s)
    let protect f ~finally = Lwt.finalize f finally

    module Sequencer = struct
      type 'a monad = 'a Lwt.t
      type 'a t = 'a * Lwt_mutex.t
      let create x = (x, Lwt_mutex.create ())
      let enqueue (x, mutex) f = Lwt_mutex.with_lock mutex (fun () -> f x)
    end
  end)
end

pgx_mirage.mli

(* Draft for cherry-picking into pgx.
 *
 * Copyright (C) 2020 Petter A. Urkedal
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Library General Public
 * License as published by the Free Software Foundation; either
 * version 2 of the License, or (at your option) any later version,
 * with the OCaml static compilation exception.
 *
 * This library 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
 * Library General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this library; see the file COPYING.  If not, write to
 * the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 * Boston, MA 02111-1307, USA.
 *)

module Make :
  functor (Random : Mirage_random.S) ->
  functor (Clock : Mirage_clock.MCLOCK) ->
  functor (Stack : sig include Mirage_stack.V4 val singleton : t end) ->
  Pgx.S with type 'a monad = 'a Lwt.t