Source file web.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
type meth =
| Get
| Head
| Options
| Post
| Put
| Patch
| Delete
| Any
type handler = Rock.Request.t -> Rock.Response.t Lwt.t
type route = meth * string * handler
type router =
{ scope : string
; routes : route list
; middlewares : Rock.Middleware.t list
}
let trailing_char s =
let length = String.length s in
try Some (String.sub s (length - 1) 1) with
| _ -> None
;;
let tail s =
try String.sub s 1 (String.length s - 1) with
| _ -> ""
;;
let prefix prefix ((meth, path, handler) : route) =
if String.equal path ""
then meth, prefix, handler
else (
let path =
match trailing_char prefix, Astring.String.head path with
| Some "/", Some '/' -> Printf.sprintf "%s%s" prefix (tail path)
| Some "/", Some _ -> Printf.sprintf "%s%s" prefix path
| Some _, Some '/' -> Printf.sprintf "%s%s" prefix path
| None, Some '/' -> Printf.sprintf "%s%s" prefix path
| Some "/", None -> Printf.sprintf "%s%s" prefix path
| _, _ -> Printf.sprintf "%s/%s" prefix path
in
let path = CCString.replace ~sub:"//" ~by:"/" path in
meth, path, handler)
;;
let apply_middleware_stack
(middleware_stack : Rock.Middleware.t list)
((meth, path, handler) : route)
=
let middleware_stack = List.rev middleware_stack in
let wrapped_handler =
List.fold_left
(fun handler middleware -> Rock.Middleware.apply middleware handler)
handler
middleware_stack
in
meth, path, wrapped_handler
;;
let get path ?(middlewares = []) handler =
{ scope = ""; routes = [ Get, path, handler ]; middlewares }
;;
let head path ?(middlewares = []) handler =
{ scope = ""; routes = [ Head, path, handler ]; middlewares }
;;
let options path ?(middlewares = []) handler =
{ scope = ""; routes = [ Options, path, handler ]; middlewares }
;;
let post path ?(middlewares = []) handler =
{ scope = ""; routes = [ Post, path, handler ]; middlewares }
;;
let put path ?(middlewares = []) handler =
{ scope = ""; routes = [ Put, path, handler ]; middlewares }
;;
let patch path ?(middlewares = []) handler =
{ scope = ""; routes = [ Patch, path, handler ]; middlewares }
;;
let delete path ?(middlewares = []) handler =
{ scope = ""; routes = [ Delete, path, handler ]; middlewares }
;;
let any path ?(middlewares = []) handler =
{ scope = ""; routes = [ Any, path, handler ]; middlewares }
;;
let routes_of_router ({ scope; routes; middlewares } : router) : route list =
routes
|> List.map (prefix scope)
|> List.map (apply_middleware_stack middlewares)
;;
let choose ?(scope = "/") ?(middlewares = []) (routers : router list) : router =
let scope =
match CCString.chop_prefix ~pre:"/" scope with
| Some prefix -> "/" ^ prefix
| None -> "/" ^ scope
in
let routes = routers |> List.map routes_of_router |> List.concat in
{ scope; routes; middlewares }
;;
let externalize_path ?prefix path =
let prefix =
match prefix, Core_configuration.read_string "PREFIX_PATH" with
| Some prefix, _ -> prefix
| _, Some prefix -> prefix
| _ -> ""
in
path
|> String.split_on_char '/'
|> List.cons prefix
|> String.concat "/"
|> Stringext.replace_all ~pattern:"//" ~with_:"/"
;;