package opium_kernel

  1. Overview
  2. Docs

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
117
118
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_stream ?(env = Hmap0.empty) ?headers ?(code = `OK) body =
    { env
    ; code
    ; headers= default_header headers
    ; body= Cohttp_lwt.Body.of_stream 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
OCaml

Innovation. Community. Security.