Source file `pgx_lwt_mirage.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
(* 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

(* Defining this inline so we can use older lwt versions. *)
let ( let* ) = Lwt.bind
let ( let+ ) t f = Lwt.map f t

module Make
    (RANDOM : Mirage_random.S)
    (TIME : Mirage_time.S)
    (MCLOCK : Mirage_clock.MCLOCK)
    (PCLOCK : Mirage_clock.PCLOCK)
    (STACK : Tcpip.Stack.V4V6) =
struct
  module Channel = Mirage_channel.Make (STACK.TCP)

  module Thread = struct
    type sockaddr =
      | Unix of string
      | Inet of string * int

    type in_channel = Channel.t
    type out_channel = Channel.t

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

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

    let flush oc =
      Channel.flush oc
      >>= function
      | Ok () -> Lwt.return_unit
      | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_write_error err)
    ;;

    let input_char ic =
      Channel.read_char ic
      >>= function
      | Ok (`Data c) -> Lwt.return c
      | Ok `Eof -> Lwt.fail End_of_file
      | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_error err)
    ;;

    let really_input ic buf off len =
      Channel.read_exactly ~len ic
      >>= function
      | Ok (`Data bufs) ->
        let content = Cstruct.copyv bufs in
        Bytes.blit_string content 0 buf off len;
        Lwt.return_unit
      | Ok `Eof -> Lwt.fail End_of_file
      | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_error err)
    ;;

    let close_in oc =
      Channel.close oc
      >>= function
      | Ok () -> Lwt.return_unit
      | Error err -> Lwt.fail_with (Format.asprintf "%a" Channel.pp_write_error err)
    ;;

    let getlogin () = Lwt.fail_with "Running under MirageOS. getlogin not available."
  end

  module Dns = Dns_client_mirage.Make (RANDOM) (TIME) (MCLOCK) (PCLOCK) (STACK)

  type sockaddr = Thread.sockaddr =
    | Unix of string
    | Inet of string * int

  module TCP = Conduit_mirage.TCP (STACK)

  let connect_stack stack sockaddr =
    let dns = Dns.create stack in
    let* client =
      match sockaddr with
      | Unix _ -> Lwt.fail_with "Running under MirageOS. Unix sockets are not available."
      | Inet (host, port) ->
        (match Ipaddr.of_string host with
        | Ok ipaddr -> Lwt.return (`TCP (ipaddr, port))
        | Error _ ->
          let host' = host |> Domain_name.of_string_exn |> Domain_name.host_exn in
          Dns.gethostbyname dns host'
          >>= (function
          | Ok ipaddr -> Lwt.return (`TCP (Ipaddr.V4 ipaddr, port))
          | Error (`Msg msg) -> Lwt.fail_with msg))
    in
    let+ flow = TCP.connect stack client in
    let ch = Channel.create flow in
    ch, ch
  ;;

  let connect stack =
    let open_connection = connect_stack stack in
    (module struct
      module T : Pgx_lwt.Io_intf.S = struct
        include Thread

        let open_connection = open_connection
      end

      include Pgx_lwt.Make (T)
    end : Pgx_lwt.S)
  ;;
end