ocaml http/1, http/2 and websocket client and server library
gdiazlo.tngl.sh
1(** Type-safe router with radix trie, scopes, and per-route plugs. *)
2
3type segment = Literal of string | Param of string | Wildcard
4type params = (string * string) list
5type 'a handler_entry = { handler : 'a; plugs : Pipeline.t }
6
7type 'a trie_node = {
8 mutable handlers : (H1.Method.t option * 'a handler_entry) list;
9 literal_children : (string, 'a trie_node) Hashtbl.t;
10 mutable param_child : (string * 'a trie_node) option;
11 mutable wildcard_child : 'a trie_node option;
12}
13
14type 'a t = { root : 'a trie_node }
15type 'a match_result = { handler : 'a; params : params; plugs : Pipeline.t }
16
17let empty_node () =
18 {
19 handlers = [];
20 literal_children = Hashtbl.create 8;
21 param_child = None;
22 wildcard_child = None;
23 }
24
25let empty () = { root = empty_node () }
26
27let parse_path path =
28 let path =
29 if String.length path > 0 && path.[0] = '/' then
30 String.sub path 1 (String.length path - 1)
31 else path
32 in
33 if path = "" then []
34 else
35 String.split_on_char '/' path
36 |> List.filter (fun s -> s <> "")
37 |> List.map (fun s ->
38 if String.length s > 0 && s.[0] = ':' then
39 Param (String.sub s 1 (String.length s - 1))
40 else if s = "*" then Wildcard
41 else Literal s)
42
43let find_or_create_child node seg =
44 match seg with
45 | Literal s -> (
46 match Hashtbl.find_opt node.literal_children s with
47 | Some child -> child
48 | None ->
49 let child = empty_node () in
50 Hashtbl.add node.literal_children s child;
51 child)
52 | Param name -> (
53 match node.param_child with
54 | Some (_, child) -> child
55 | None ->
56 let child = empty_node () in
57 node.param_child <- Some (name, child);
58 child)
59 | Wildcard -> (
60 match node.wildcard_child with
61 | Some child -> child
62 | None ->
63 let child = empty_node () in
64 node.wildcard_child <- Some child;
65 child)
66
67let add_route router ~method_ ~path ~handler ~plugs =
68 let segments = parse_path path in
69 let entry = { handler; plugs } in
70 let rec insert node = function
71 | [] -> node.handlers <- (method_, entry) :: node.handlers
72 | seg :: rest ->
73 let child = find_or_create_child node seg in
74 insert child rest
75 in
76 insert router.root segments
77
78let lookup router ~method_ ~path =
79 let len = String.length path in
80 let start = if len > 0 && path.[0] = '/' then 1 else 0 in
81
82 let rec search node pos params =
83 if pos >= len then
84 match
85 List.find_opt
86 (fun (m, _) -> match m with None -> true | Some m' -> m' = method_)
87 node.handlers
88 with
89 | Some (_, entry) ->
90 Some { handler = entry.handler; params; plugs = entry.plugs }
91 | None -> None
92 else
93 let seg_end =
94 try String.index_from path pos '/' with Not_found -> len
95 in
96 if seg_end = pos then search node (pos + 1) params
97 else
98 let seg = String.sub path pos (seg_end - pos) in
99 let next_pos = if seg_end < len then seg_end + 1 else len in
100 match Hashtbl.find_opt node.literal_children seg with
101 | Some child -> search child next_pos params
102 | None -> (
103 match node.param_child with
104 | Some (name, child) -> search child next_pos ((name, seg) :: params)
105 | None -> (
106 match node.wildcard_child with
107 | Some child ->
108 let rest_path = String.sub path pos (len - pos) in
109 search child len (("*", rest_path) :: params)
110 | None -> None))
111 in
112 search router.root start []
113
114module Route = struct
115 type 'a t = {
116 method_ : H1.Method.t option;
117 path : string;
118 handler : 'a;
119 plugs : Pipeline.t;
120 }
121
122 let make ?method_ path handler = { method_; path; handler; plugs = [] }
123 let get path handler = { method_ = Some `GET; path; handler; plugs = [] }
124 let post path handler = { method_ = Some `POST; path; handler; plugs = [] }
125 let put path handler = { method_ = Some `PUT; path; handler; plugs = [] }
126
127 let delete path handler =
128 { method_ = Some `DELETE; path; handler; plugs = [] }
129
130 let patch path handler =
131 { method_ = Some (`Other "PATCH"); path; handler; plugs = [] }
132
133 let head path handler = { method_ = Some `HEAD; path; handler; plugs = [] }
134
135 let options path handler =
136 { method_ = Some `OPTIONS; path; handler; plugs = [] }
137
138 let any path handler = { method_ = None; path; handler; plugs = [] }
139 let plug p route = { route with plugs = Pipeline.plug route.plugs p }
140end
141
142let normalize_path path =
143 if String.length path = 0 then "/"
144 else if path.[0] <> '/' then "/" ^ path
145 else path
146
147let join_paths prefix path =
148 let prefix = normalize_path prefix in
149 let path = normalize_path path in
150 if prefix = "/" then path else if path = "/" then prefix else prefix ^ path
151
152let scope ?(through = Pipeline.empty) prefix routes =
153 List.map
154 (fun (r : 'a Route.t) ->
155 {
156 r with
157 path = join_paths prefix r.path;
158 plugs = Pipeline.compose through r.plugs;
159 })
160 routes
161
162let compile routes =
163 let router = empty () in
164 List.iter
165 (fun r ->
166 add_route router ~method_:r.Route.method_ ~path:r.Route.path
167 ~handler:r.Route.handler ~plugs:r.Route.plugs)
168 routes;
169 router
170
171let compile_scopes scopes =
172 let all_routes = List.concat scopes in
173 compile all_routes
174
175let param name params = List.assoc_opt name params
176
177let param_or name ~default params =
178 match List.assoc_opt name params with Some v -> v | None -> default
179
180let param_int name params =
181 match List.assoc_opt name params with
182 | Some v -> int_of_string_opt v
183 | None -> None
184
185let param_int_or name ~default params =
186 match param_int name params with Some v -> v | None -> default