Source file `mehari_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
open Mehari.Private

module type IO_RESPONSE = sig
  val respond : 'a Mehari.status -> 'a -> Mehari.response Lwt.t
  val respond_body : Mehari.body -> Mehari.mime -> Mehari.response Lwt.t
  val respond_text : string -> Mehari.response Lwt.t

  val respond_gemtext :
    ?charset:string ->
    ?lang:string list ->
    Mehari.Gemtext.t ->
    Mehari.response Lwt.t

  val respond_raw :
    [ `Body of string | `Full of int * string * string ] ->
    Mehari.response Lwt.t
end

module type S = sig
  module IO = Lwt

  include
    Mehari.NET
      with module IO := IO
       and type addr = Ipaddr.t
       and type clock := unit

  val make_rate_limit :
    ?period:int -> int -> [ `Second | `Minute | `Hour | `Day ] -> rate_limiter

  val logger : handler -> handler

  include IO_RESPONSE
  include Server_impl.S with module IO := IO
end

module Make
    (PClock : Mirage_clock.PCLOCK)
    (Stack : Tcpip.Stack.V4V6)
    (Time : Mirage_time.S) : S with type stack = Stack.t = struct
  module IO = Lwt
  module Addr = Ipaddr

  module Clock = struct
    type t = unit

    let now_d_ps () = PClock.now_d_ps ()
  end

  module RateLimiter = Rate_limiter_impl.Make (Clock) (IO) (Addr)

  module Logger =
    Logger_impl.Make
      (Clock)
      (struct
        include Lwt

        let finally = try_bind
      end)
      (Addr)

  module Router = Router_impl.Make (RateLimiter) (Logger)
  module Server = Server_impl.Make (Stack) (Time) (Logger)

  type addr = Addr.t
  type handler = Router.handler
  type middleware = handler -> handler
  type route = Router.route
  type rate_limiter = RateLimiter.t
  type stack = Stack.t

  let respond s i = Mehari.response s i |> IO.return
  let respond_body b m = Mehari.response_body b m |> IO.return
  let respond_text t = Mehari.response_text t |> IO.return

  let respond_gemtext ?charset ?lang g =
    Mehari.response_gemtext ?charset ?lang g |> IO.return

  let respond_raw g = Mehari.response_raw g |> IO.return
  let set_log_lvl = Logger.set_level
  let logger = Logger.logger ()
  let debug = Logger.debug
  let info = Logger.info
  let warning = Logger.warning
  let error = Logger.error
  let no_middleware = Router.no_middleware
  let pipeline = Router.pipeline
  let router = Router.router
  let route = Router.route
  let scope = Router.scope
  let no_route = Router.no_route
  let virtual_hosts = Router.virtual_hosts
  let make_rate_limit = RateLimiter.make ()
  let run = Server.run
end