Source file `rock.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
open Sexplib.Std
open Misc

module Header = Cohttp.Header

module Service = struct
  type ('req, 'rep) t = 'req -> 'rep Lwt.t [@@deriving sexp]
  let id req = return req
  let const resp = Fn.compose return (Fn.const resp)
end

module Filter = struct
  type ('req, 'rep, 'req_, 'rep_) t =
    ('req, 'rep) Service.t -> ('req_, 'rep_) Service.t [@@deriving sexp]
  type ('req, 'rep) simple = ('req, 'rep, 'req, 'rep) t [@@deriving sexp]
  let id s = s
  let (>>>) f1 f2 s = s |> f1 |> f2
  let apply_all filters service =
    List.fold_left filters ~init:service ~f:(|>)
end

module Request = struct
  type t = {
    request: Cohttp.Request.t;
    body: Cohttp_lwt.Body.t;
    env: Hmap0.t;
  } [@@deriving fields, sexp_of]

  let create ?(body=Cohttp_lwt.Body.empty) ?(env=Hmap0.empty) request =
    { request; env ; body }
  let uri     { request; _ } = Cohttp.Request.uri request
  let meth    { request; _ } = Cohttp.Request.meth request
  let headers { request; _ } = Cohttp.Request.headers request
end

module Response = struct
  type t = {
    code: Cohttp.Code.status_code;
    headers: Header.t;
    body: Cohttp_lwt.Body.t;
    env: Hmap0.t
  } [@@deriving fields, sexp_of]

  let default_header = Option.value ~default:(Header.init ())

  let create ?(env=Hmap0.empty) ?(body=Cohttp_lwt.Body.empty)
        ?headers ?(code=`OK) () =
    { code
    ; env
    ; headers = Option.value ~default:(Header.init ()) headers
    ; body
    }

  let of_string_body ?(env=Hmap0.empty) ?headers ?(code=`OK) body =
    { env
    ; code
    ; headers = default_header headers
    ; body = Cohttp_lwt.Body.of_string body }

  let of_response_body (resp, body) =
    let code = Cohttp.Response.status resp in
    let headers = Cohttp.Response.headers resp in
    create ~code ~headers ~body ()
end

module Handler = struct
  type t = (Request.t, Response.t) Service.t [@@deriving sexp_of]

  let default _ = return (Response.of_string_body "route failed (404)")

  let not_found _ =
    return (Response.of_string_body
              ~code:`Not_found
              "<html><body><h1>404 - Not found</h1></body></html>")
end

module Middleware = struct
  type t =
    { filter: (Request.t, Response.t) Filter.simple
    ; name: string
    } [@@deriving fields, sexp_of]

  let create ~filter ~name = { filter ; name }

  let apply { filter; _ } handler = filter handler

  (* wrap_debug/apply_middlewares_debug are used for debugging when
     middlewares are stepping over each other *)
  (* let wrap_debug handler ({ Request.env ; request; _ } as req) =
   *   let env = Hmap0.sexp_of_t env in
   *   let req' = request
   *              |> Cohttp.Request.headers
   *              |> Cohttp.Header.to_lines in
   *   Printf.printf "Env:\n%s\n" (Sexplib.Sexp.to_string_hum env);
   *   Printf.printf "%s\n" (String.concat "" req');
   *   let resp = handler req in
   *   resp >>| (fun ({Response.headers; _} as resp) ->
   *     Printf.printf "%s\n" (headers |> Cohttp.Header.to_lines |> String.concat "\n");
   *     resp) *)

  (* let apply_middlewares_debug (middlewares : t list) handler =
   *   ListLabels.fold_left middlewares ~init:handler ~f:(fun h m ->
   *     wrap_debug (apply m h)) *)
end

module App = struct
  type t = {
    middlewares: Middleware.t list;
    handler: Handler.t;
  } [@@deriving fields, sexp_of]

  let append_middleware t m =
    { t with middlewares=(t.middlewares @ [m]) }

  let create ?(middlewares=[]) ~handler = { middlewares; handler }
end