├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── LICENSE.md ├── README.md ├── dune-project ├── example ├── Makefile ├── config.json ├── example.ml └── static │ └── test.html ├── src ├── dune ├── yurt.ml ├── yurt.mli ├── yurt_client.ml ├── yurt_form.ml ├── yurt_header.ml ├── yurt_html.ml ├── yurt_html.mli ├── yurt_request_ctx.ml ├── yurt_route.ml ├── yurt_server.ml └── yurt_util.ml └── yurt.opam /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.o 3 | *.a 4 | *.cmxa 5 | *.cma 6 | *.cmi 7 | *.cmo 8 | *.cmx 9 | *.swp 10 | *.native 11 | *.byte 12 | yurt.install 13 | .merlin 14 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.14.1 2 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ### 0.7 2 | 3 | * Conduit 3.0 4 | * API cleanup 5 | * Dune 2.0/ocamlformat 6 | 7 | ### 0.6 8 | 9 | * Switch to dune 10 | * Major API cleanup 11 | - Removed `respond_` prefix from response functions 12 | - Reorganized package layout 13 | - Removed `status_code` type 14 | 15 | ### 0.5 16 | 17 | * Update to latest Lwt 18 | * Added configuration file for server 19 | 20 | ### 0.4 21 | 22 | * Update to latest cohttp 23 | 24 | ### 0.1 25 | 26 | * Use topkg 27 | * Regex routing 28 | * Form parsing 29 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | ISC License 2 | 3 | Copyright (c) 2017, Zach Shipko 4 | 5 | Permission to use, copy, modify, and/or distribute this software for any 6 | purpose with or without fee is hereby granted, provided that the above 7 | copyright notice and this permission notice appear in all copies. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Yurt 2 | ==== 3 | 4 | `yurt` is an HTTP microframework for OCaml based on [Cohttp](https://github.com/mirage/ocaml-cohttp). 5 | 6 | ## Features 7 | 8 | * Simple API 9 | * Multipart forms 10 | * Regex based URL routing 11 | * Functional templates 12 | 13 | ## Installation 14 | 15 | opam install yurt 16 | 17 | ## Usage 18 | 19 | ```ocaml 20 | open Yurt 21 | 22 | let _ = 23 | let open Server in 24 | 25 | (* Create a server *) 26 | server "127.0.0.1" 1234 27 | 28 | (* Add a handler *) 29 | >| get "/" (fun req params body -> 30 | (* Get the url parameter called `name` *) 31 | let name = Route.string params "name" in 32 | let body = Yurt_html.h1 (Printf.sprintf "Hello %s!\n" name) in 33 | html body) 34 | 35 | (* Run it *) 36 | |> run 37 | ``` 38 | 39 | See `example/example.ml` for more examples. 40 | 41 | 42 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | 3 | (name bimage) 4 | (version 0.7) 5 | -------------------------------------------------------------------------------- /example/Makefile: -------------------------------------------------------------------------------- 1 | example: 2 | ocamlbuild -pkg yurt example.native 3 | 4 | clean: 5 | rm -rf _build 6 | -------------------------------------------------------------------------------- /example/config.json: -------------------------------------------------------------------------------- 1 | { 2 | "host": "127.0.0.1", 3 | "port": 8888 4 | } 5 | -------------------------------------------------------------------------------- /example/example.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Yurt 3 | 4 | let _ = 5 | let open Server in 6 | server_from_config "config.json" 7 | 8 | (* or server "127.0.0.1" 8880 *) 9 | 10 | (** Uncomment this block to configure TLS 11 | |> fun ctx -> 12 | configure_tls ctx "./server.crt" "./server.key" *) 13 | 14 | (** A directory of static files *) 15 | >| folder "./static" "files" 16 | 17 | (** A single static file *) 18 | >| static_file "./static/test.html" "testing" 19 | 20 | (** Reading query string value *) 21 | >| get "" (fun req params body -> 22 | match Query.string req "test" with 23 | | Some s -> string s 24 | | None -> string "TEST") 25 | 26 | (** Multipart form parsing *) 27 | >| post "/multipart" (fun req params body -> 28 | Form.multipart req body >>= fun m -> 29 | let body = Printf.sprintf "%d file(s)\n" (List.length m) in 30 | string body) 31 | 32 | (** Url parameters *) 33 | >| get "//" (fun req params body -> 34 | let a = Route.int params "a" in 35 | let b = Route.int params "b" in 36 | let body = string_of_int (a + b) in 37 | string body) 38 | 39 | (** Convert all query string arguments to json *) 40 | >| get "/tojson" (fun req params body -> 41 | json (Query.to_json req)) 42 | 43 | (** Convert all posted arguments to json *) 44 | >| post (Route.to_string (`Path "tojson")) (fun req params body-> 45 | Form.urlencoded_json body >>= fun p -> 46 | json (Query.to_json req)) 47 | 48 | (* Uncomment this to daemonize the process 49 | >|| (fun ctx -> daemonize ctx) *) 50 | 51 | |> run 52 | -------------------------------------------------------------------------------- /example/static/test.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 |

Multipart form

7 |
8 | 9 | 10 |
11 | 12 | 13 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name yurt) 3 | (public_name yurt) 4 | (wrapped false) 5 | (libraries dynlink str cohttp-lwt-unix conduit-lwt-unix.tls ezjsonm lwt_log)) 6 | -------------------------------------------------------------------------------- /src/yurt.ml: -------------------------------------------------------------------------------- 1 | (** The Yurt module provides a simple interface for building HTTP servers *) 2 | 3 | module Route = Yurt_route 4 | (** Routing *) 5 | 6 | module Server = Yurt_server 7 | module Client = Yurt_client 8 | module Util = Yurt_util 9 | module Form = Yurt_form 10 | include Server 11 | include Yurt_request_ctx 12 | -------------------------------------------------------------------------------- /src/yurt.mli: -------------------------------------------------------------------------------- 1 | (** [Route]s are used to build URLs with types variables *) 2 | module Route : sig 3 | type route = 4 | [ `String of string 5 | | `Int of string 6 | | `Float of string 7 | | `Path of string 8 | | `Match of string * string 9 | | `Route of route list ] 10 | 11 | exception Invalid_route_type 12 | (** [Invalid_route_type] is raised when a value of the wrong type is requested *) 13 | 14 | type params = (string, route) Hashtbl.t 15 | (** Param map *) 16 | 17 | val to_string : route -> string 18 | (** Convert a route to string *) 19 | 20 | val to_regexp : route -> Str.regexp 21 | (** Convert a route to regular expressions *) 22 | 23 | val of_string : string -> route 24 | (** Create a [Route] from the given string *) 25 | 26 | val params : route -> string -> params 27 | (** Get parameters from a route *) 28 | 29 | val string : params -> string -> string 30 | (** Get a string parameter *) 31 | 32 | val int : params -> string -> int 33 | (** Get an int parameter *) 34 | 35 | val float : params -> string -> float 36 | (** Get a float parameter *) 37 | 38 | val to_json : params -> Ezjsonm.t 39 | (** Convert parameters to JSON *) 40 | end 41 | 42 | (** The [Body] module contains methods needed for creating, reading and modifying request data *) 43 | module Body : sig 44 | type t = Cohttp_lwt.Body.t 45 | 46 | type transfer_encoding = Cohttp.Transfer.encoding 47 | 48 | val to_string : t -> string Lwt.t 49 | (** Convert body to string *) 50 | 51 | val to_stream : t -> string Lwt_stream.t 52 | (** Convert body to stream *) 53 | 54 | val to_json : t -> Ezjsonm.t Lwt.t 55 | (** Convert body to JSON *) 56 | 57 | val of_string : string -> t 58 | (** Create body from string *) 59 | 60 | val of_stream : string Lwt_stream.t -> t 61 | (** Create body from stream *) 62 | 63 | val of_json : Ezjsonm.t -> t 64 | (** Create body from JSON *) 65 | 66 | val map : (string -> string) -> t -> t 67 | (** Modify body *) 68 | 69 | val length : t -> (int64 * t) Lwt.t 70 | (** Get body length *) 71 | 72 | val is_empty : t -> bool Lwt.t 73 | (** Returns true when body has no content *) 74 | 75 | val drain : t -> unit Lwt.t 76 | (** Ignore body content *) 77 | 78 | val transfer_encoding : t -> transfer_encoding 79 | end 80 | 81 | module Request = Cohttp_lwt_unix.Request 82 | module Response = Cohttp.Response 83 | module Header = Cohttp.Header 84 | 85 | type response = (Response.t * Body.t) Lwt.t 86 | (** Response type *) 87 | 88 | and endpoint = Request.t -> Route.params -> Body.t -> response 89 | (** HTTP handler *) 90 | 91 | (** [Query] contains methods for reading query string parameters *) 92 | module Query : sig 93 | type t = (string, string list) Hashtbl.t 94 | 95 | val get : Request.t -> t 96 | (** Parse the request's query string *) 97 | 98 | val to_json : Request.t -> Ezjsonm.t 99 | (** Convert query string to JSON *) 100 | 101 | val string : Request.t -> string -> string option 102 | (** Get string query string parameter *) 103 | 104 | val int : Request.t -> string -> int option 105 | (** Get int query string parameter *) 106 | 107 | val float : Request.t -> string -> float option 108 | (** Get float query string parameter *) 109 | 110 | (* Get json query string parameter *) 111 | val json : Request.t -> string -> Ezjsonm.value option 112 | end 113 | 114 | (** [Server] contains the methods needed to build a [Yurt] server *) 115 | module Server : sig 116 | include Cohttp_lwt.S.Server with module IO = Cohttp_lwt_unix.IO 117 | 118 | val resolve_file : docroot:string -> uri:Uri.t -> string 119 | 120 | type server = { 121 | host : string; 122 | port : int; 123 | mutable routes : (string * Route.route * endpoint) list; 124 | mutable tls_config : Tls.Config.server option; 125 | mutable logger : Lwt_log.logger; 126 | } 127 | 128 | val server : 129 | ?tls_config:Tls.Config.server -> 130 | ?logger:Lwt_log.logger -> 131 | string -> 132 | int -> 133 | server 134 | (** Create a new server *) 135 | 136 | val server_from_config : string -> server 137 | (** Create a new server from an existing configuration file *) 138 | 139 | val log_debug : server -> string -> string -> unit 140 | 141 | val log_info : server -> string -> string -> unit 142 | 143 | val log_notice : server -> string -> string -> unit 144 | 145 | val log_error : server -> string -> string -> unit 146 | 147 | val log_fatal : server -> string -> string -> unit 148 | 149 | val configure_tls : server -> string -> string -> server 150 | (** Configure TLS after the server has been created *) 151 | 152 | val stream : 153 | ?flush:bool -> 154 | ?headers:Header.t -> 155 | ?status:int -> 156 | string Lwt_stream.t -> 157 | (Response.t * Body.t) Lwt.t 158 | (** Respond with a stream *) 159 | 160 | val json : 161 | ?flush:bool -> 162 | ?headers:Header.t -> 163 | ?status:int -> 164 | Ezjsonm.t -> 165 | (Response.t * Body.t) Lwt.t 166 | (** Respond with JSON data *) 167 | 168 | val html : 169 | ?flush:bool -> 170 | ?headers:Header.t -> 171 | ?status:int -> 172 | Yurt_html.t -> 173 | (Response.t * Body.t) Lwt.t 174 | (** Respond with HTML data *) 175 | 176 | val string : 177 | ?flush:bool -> 178 | ?headers:Header.t -> 179 | ?status:int -> 180 | string -> 181 | (Response.t * Body.t) Lwt.t 182 | (** Respond with string data *) 183 | 184 | val redirect : ?headers:Header.t -> string -> (Response.t * Body.t) Lwt.t 185 | (** Redirect client *) 186 | 187 | val file : ?headers:Header.t -> string -> (Response.t * Body.t) Lwt.t 188 | (** Respond with datas from file *) 189 | 190 | val register : server -> (string * Route.route * endpoint) list -> server 191 | (** Register a list of routes with the server *) 192 | 193 | val register_route : server -> string -> Route.route -> endpoint -> server 194 | (** Register a single route with the server *) 195 | 196 | val register_route_string : server -> string -> string -> endpoint -> server 197 | (** Register a single route, formatted as a string, with the server *) 198 | 199 | val options : string -> endpoint -> server -> server 200 | (** Register OPTIONS endpoint *) 201 | 202 | val get : string -> endpoint -> server -> server 203 | (** Register GET endpoint *) 204 | 205 | val post : string -> endpoint -> server -> server 206 | (** Register POST endpoint *) 207 | 208 | val put : string -> endpoint -> server -> server 209 | (** Register PUT endpoint *) 210 | 211 | val update : string -> endpoint -> server -> server 212 | (** Register UPDATE endpoint *) 213 | 214 | val delete : string -> endpoint -> server -> server 215 | (** Register delete endpoint *) 216 | 217 | val static_file : string -> string -> server -> server 218 | (** Regster endpoint that returns a single static file for all requests *) 219 | 220 | val static_files : string -> string -> server -> server 221 | (** Reqister endpoint that will serve files from a firectory *) 222 | 223 | val daemonize : ?directory:string -> ?syslog:bool -> server -> unit 224 | (** Daemonize the server *) 225 | 226 | exception Cannot_start_server 227 | 228 | val start : server -> unit Lwt.t 229 | 230 | val run : server -> unit 231 | 232 | val route : server -> (server -> server) -> server 233 | 234 | val ( >| ) : server -> (server -> server) -> server 235 | 236 | val ( >|| ) : server -> (server -> unit) -> server 237 | end 238 | 239 | (** [Client] contains functions for sending HTTP requests *) 240 | module Client : sig 241 | val get : 242 | ?resolvers:Conduit.resolvers -> 243 | ?headers:Header.t -> 244 | string -> 245 | (Response.t * string) Lwt.t 246 | (** Send a GET request *) 247 | 248 | val post : 249 | ?resolvers:Conduit.resolvers -> 250 | ?headers:Header.t -> 251 | ?body:Body.t -> 252 | string -> 253 | (Response.t * string) Lwt.t 254 | (** Send a POST request *) 255 | 256 | val post_form : 257 | ?resolvers:Conduit.resolvers -> 258 | ?headers:Header.t -> 259 | params:(string * string list) list -> 260 | string -> 261 | (Response.t * string) Lwt.t 262 | (** Send a POST request with form encoded data *) 263 | 264 | val request : 265 | ?resolvers:Conduit.resolvers -> 266 | ?headers:Header.t -> 267 | ?body:Body.t -> 268 | Cohttp.Code.meth -> 269 | string -> 270 | (Response.t * string) Lwt.t 271 | (** Send another type of request other than POST or GET *) 272 | 273 | val get_json : 274 | ?resolvers:Conduit.resolvers -> 275 | ?headers:Header.t -> 276 | string -> 277 | (Response.t * Ezjsonm.t) Lwt.t 278 | (** Send a get request and return JSON response *) 279 | 280 | val post_json : 281 | ?resolvers:Conduit.resolvers -> 282 | ?headers:Header.t -> 283 | ?body:Body.t -> 284 | string -> 285 | (Response.t * Ezjsonm.t) Lwt.t 286 | (** Send a post request and return JSON response *) 287 | 288 | val post_form_json : 289 | ?resolvers:Conduit.resolvers -> 290 | ?headers:Header.t -> 291 | ?params:(string * string list) list -> 292 | string -> 293 | (Response.t * Ezjsonm.t) Lwt.t 294 | (** Send a POST request with from encoded data and return JSON response *) 295 | end 296 | 297 | module Form : sig 298 | exception Invalid_multipart_form 299 | 300 | val urlencoded : Body.t -> (string, string list) Hashtbl.t Lwt.t 301 | 302 | val urlencoded_list : Body.t -> (string * string list) list Lwt.t 303 | 304 | val urlencoded_json : Body.t -> Ezjsonm.t Lwt.t 305 | 306 | type multipart = { 307 | mutable data : char Lwt_stream.t; 308 | mutable name : string; 309 | attr : (string, string list) Hashtbl.t; 310 | } 311 | 312 | val get_attr : multipart -> string -> string list 313 | 314 | val is_multipart : Request.t -> bool 315 | 316 | val multipart : Request.t -> Body.t -> multipart list Lwt.t 317 | 318 | type form = 319 | | Multipart of multipart list 320 | | Urlencoded of (string, string list) Hashtbl.t 321 | 322 | val parse_form : Request.t -> Body.t -> form Lwt.t 323 | end 324 | 325 | module Util : sig 326 | val unwrap_option : 'a option -> 'a 327 | 328 | val unwrap_option_default : 'a option -> 'a -> 'a 329 | 330 | val uuid4 : unit -> string 331 | 332 | val is_safe_path : ?prefix:string -> string -> bool 333 | end 334 | -------------------------------------------------------------------------------- /src/yurt_client.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Cohttp_lwt_unix 3 | 4 | let get ?resolvers ?headers url = 5 | Client.get ?resolvers ?headers (Uri.of_string url) >>= fun (res, body) -> 6 | Cohttp_lwt.Body.to_string body >|= fun body_string -> (res, body_string) 7 | 8 | let post ?resolvers ?headers ?body url = 9 | Client.post ?resolvers ?headers ?body (Uri.of_string url) 10 | >>= fun (res, body) -> 11 | Cohttp_lwt.Body.to_string body >|= fun body_string -> (res, body_string) 12 | 13 | let post_form ?resolvers ?headers ~params url = 14 | Client.post_form ?resolvers ?headers ~params (Uri.of_string url) 15 | >>= fun (res, body) -> 16 | Cohttp_lwt.Body.to_string body >|= fun body_string -> (res, body_string) 17 | 18 | let request ?resolvers ?headers ?body meth url = 19 | Client.call ?resolvers ?headers ?body meth (Uri.of_string url) 20 | >>= fun (res, body) -> 21 | Cohttp_lwt.Body.to_string body >|= fun body_string -> (res, body_string) 22 | 23 | let get_json ?resolvers ?headers url = 24 | get ?resolvers ?headers url >|= fun (r, b) -> (r, Ezjsonm.from_string b) 25 | 26 | let post_json ?resolvers ?headers ?body url = 27 | post ?resolvers ?headers ?body url >|= fun (r, b) -> (r, Ezjsonm.from_string b) 28 | 29 | let post_form_json ?resolvers ?headers ?(params = []) url = 30 | post_form ?resolvers ?headers ~params url >|= fun (r, b) -> 31 | (r, Ezjsonm.from_string b) 32 | -------------------------------------------------------------------------------- /src/yurt_form.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Yurt_request_ctx 3 | open Cohttp_lwt_unix 4 | 5 | exception Invalid_multipart_form 6 | 7 | (** Parse URL encoded form *) 8 | let urlencoded body : (string, string list) Hashtbl.t Lwt.t = 9 | let dst = Hashtbl.create 16 in 10 | Body.to_string body >|= Uri.query_of_encoded 11 | >|= Lwt_list.iter_s (fun (k, v) -> 12 | Lwt.return 13 | ( if Hashtbl.mem dst k then 14 | let l = Hashtbl.find dst k in 15 | Hashtbl.replace dst k (l @ v) 16 | else Hashtbl.replace dst k v )) 17 | >>= fun _ -> Lwt.return dst 18 | 19 | let urlencoded_list body : (string * string list) list Lwt.t = 20 | Body.to_string body >|= Uri.query_of_encoded 21 | 22 | (** Parse URL encoded form into JSON *) 23 | let urlencoded_json body : Ezjsonm.t Lwt.t = 24 | urlencoded_list body >|= fun f -> 25 | `O (List.map (fun (k, v) -> (k, `A (List.map Ezjsonm.encode_string v))) f) 26 | 27 | (** There are a couple of big things from RFC2388 that aren't implemented yet: 28 | * 1. multipart/mixed content type may not be parsed correctly. 29 | * 2. content-transfer-encoding is currently ignored. *) 30 | 31 | type multipart = { 32 | mutable data : char Lwt_stream.t; 33 | mutable name : string; 34 | attr : (string, string list) Hashtbl.t; 35 | } 36 | 37 | let line_regexp = Str.regexp "\r\n" 38 | 39 | let equal_regexp = Str.regexp "=" 40 | 41 | let semicolon_regexp = Str.regexp "; ?" 42 | 43 | let split_semicolon (s : string) : string list = Str.split semicolon_regexp s 44 | 45 | let get_attr (m : multipart) (attr : string) : string list = 46 | try Hashtbl.find m.attr attr with Not_found -> [] 47 | 48 | (** Return true when the multipart object has a filename attribute *) 49 | let is_file (m : multipart) : bool = 50 | match get_attr m "filename" with [] -> false | _ -> true 51 | 52 | let is_multipart_regexp = Str.regexp "multipart/.*" 53 | 54 | let is_multipart req : bool = 55 | let content_type = 56 | Yurt_util.unwrap_option_default 57 | (Header.get req.Request.headers "Content-Type") 58 | "" 59 | in 60 | Str.string_match is_multipart_regexp content_type 0 61 | 62 | let multipart req body : multipart list Lwt.t = 63 | (* Output *) 64 | let out = ref [] in 65 | 66 | let content_type = 67 | Yurt_util.unwrap_option_default 68 | (Header.get req.Request.headers "Content-Type") 69 | "" 70 | in 71 | 72 | let b = split_semicolon content_type in 73 | let boundary = 74 | match b with 75 | | [ _; y ] -> String.sub y 9 (String.length y - 9) 76 | | _ -> raise Invalid_multipart_form 77 | in 78 | let boundary_a = "--" ^ boundary in 79 | let boundary_b = boundary_a ^ "--" in 80 | 81 | (* Current multipart context *) 82 | let current = 83 | ref { data = Lwt_stream.of_string ""; attr = Hashtbl.create 16; name = "" } 84 | in 85 | 86 | (* Body buffer *) 87 | let buffer = Buffer.create 512 in 88 | 89 | (* True when the parser is in a header section *) 90 | let in_header = ref false in 91 | 92 | (* Input lines *) 93 | Body.to_string body 94 | >>= (fun s -> Lwt.return (Str.split line_regexp s)) 95 | >|= Lwt_list.iter_s (fun line -> 96 | let _ = 97 | match line with 98 | (* Boundary *) 99 | | x when x = boundary || x = boundary_a || x = boundary_b -> 100 | let c = !current in 101 | let _ = in_header := true in 102 | let bl = Buffer.length buffer in 103 | if bl > 0 || Hashtbl.length c.attr > 0 then 104 | (* The new buffer contains an extra "\r\n" that needs to be removed *) 105 | let b = Buffer.sub buffer 0 (bl - 2) in 106 | let _ = !current.data <- Lwt_stream.of_string b in 107 | let _ = Buffer.reset buffer in 108 | let _ = out := !out @ [ c ] in 109 | current := 110 | { 111 | data = Lwt_stream.of_string ""; 112 | attr = Hashtbl.create 16; 113 | name = ""; 114 | } 115 | (* End of header *) 116 | | x when !in_header && x = "" -> in_header := false 117 | (* Get attributes *) 118 | | x when !in_header -> 119 | let m = "Content-Disposition: form-data; " in 120 | let mlen = String.length m in 121 | if String.length x >= String.length m && String.sub x 0 mlen = m 122 | then 123 | let x = 124 | String.sub x mlen (String.length x - String.length m) 125 | in 126 | let parts = split_semicolon x in 127 | List.iter 128 | (fun part -> 129 | let p = Str.split equal_regexp part in 130 | let k = String.trim (List.hd p) in 131 | let v = List.tl p |> String.concat "=" in 132 | let v = String.sub v 1 (String.length v - 2) in 133 | if k == "name" then !current.name <- v 134 | else if Hashtbl.mem !current.attr k then 135 | let dst = Hashtbl.find !current.attr k in 136 | Hashtbl.replace !current.attr k (dst @ [ v ]) 137 | else Hashtbl.replace !current.attr k [ v ]) 138 | parts 139 | (* In body *) 140 | | x -> 141 | Buffer.add_string buffer x; 142 | Buffer.add_string buffer "\r\n" 143 | in 144 | Lwt.return_unit) 145 | >>= fun _ -> Lwt.return !out 146 | 147 | type form = 148 | | Multipart of multipart list 149 | | Urlencoded of (string, string list) Hashtbl.t 150 | 151 | (** Parse URL encoded form *) 152 | let parse_form req body : form Lwt.t = 153 | if is_multipart req then multipart req body >|= fun f -> Multipart f 154 | else urlencoded body >|= fun f -> Urlencoded f 155 | -------------------------------------------------------------------------------- /src/yurt_header.ml: -------------------------------------------------------------------------------- 1 | open Yurt_request_ctx 2 | 3 | module Cookie = struct 4 | include Cohttp.Cookie.Set_cookie_hdr 5 | end 6 | 7 | type cookie = Cookie.t 8 | 9 | (** Write cookie to request *) 10 | let set_cookie h (c : cookie) = 11 | let k, v = Cookie.serialize c in 12 | Header.replace h k v 13 | 14 | (** Get from request cookies *) 15 | let cookies req = Cookie.extract Request.(req.headers) 16 | 17 | (** Find a cookie by name *) 18 | let find_cookie req name = 19 | List.fold_left 20 | (fun acc (k, v) -> if k = name then Some v else acc) 21 | None (cookies req) 22 | -------------------------------------------------------------------------------- /src/yurt_html.ml: -------------------------------------------------------------------------------- 1 | module Tag = struct 2 | type t = 3 | [ `A 4 | | `ADDR 5 | | `ADDRESS 6 | | `AREA 7 | | `ARTICLE 8 | | `ASIDE 9 | | `AUDIO 10 | | `B 11 | | `BASE 12 | | `BLOCKQUOTE 13 | | `BODY 14 | | `BR 15 | | `BUTTON 16 | | `CANVAS 17 | | `CAPTION 18 | | `CODE 19 | | `COL 20 | | `COLGROUP 21 | | `DATALIST 22 | | `DD 23 | | `DETAILS 24 | | `DIV 25 | | `DL 26 | | `DT 27 | | `EM 28 | | `EMBED 29 | | `FIELDSET 30 | | `FIGCAPTION 31 | | `FIGURE 32 | | `FOOTER 33 | | `FORM 34 | | `H1 35 | | `H2 36 | | `H3 37 | | `H4 38 | | `H5 39 | | `H6 40 | | `HEAD 41 | | `HEADER 42 | | `HGROUP 43 | | `HR 44 | | `HTML 45 | | `I 46 | | `IFRAME 47 | | `IMG 48 | | `INPUT 49 | | `KEYGEN 50 | | `LABEL 51 | | `LEGEND 52 | | `LI 53 | | `LINK 54 | | `META 55 | | `MAIN 56 | | `NAV 57 | | `NOSCRIPT 58 | | `OBJECT 59 | | `OL 60 | | `OPTGROUP 61 | | `OPTION 62 | | `P 63 | | `PRE 64 | | `PROGRESS 65 | | `Q 66 | | `SCRIPT 67 | | `SECTION 68 | | `SELECT 69 | | `SOURCE 70 | | `SPAN 71 | | `STRONG 72 | | `STYLE 73 | | `SUB 74 | | `SUP 75 | | `TABLE 76 | | `TBODY 77 | | `TD 78 | | `TEXTAREA 79 | | `TFOOT 80 | | `TH 81 | | `THEAD 82 | | `TIME 83 | | `TITLE 84 | | `TR 85 | | `TRACK 86 | | `U 87 | | `UL 88 | | `VIDEO 89 | | `WBR 90 | | `RAW 91 | | `NAME of string 92 | | `VAR of string ] 93 | 94 | let to_string (tag : t) : string = 95 | match tag with 96 | | `A -> "a" 97 | | `ADDR -> "addr" 98 | | `ADDRESS -> "address" 99 | | `AREA -> "area" 100 | | `ARTICLE -> "article" 101 | | `ASIDE -> "aside" 102 | | `AUDIO -> "audio" 103 | | `B -> "b" 104 | | `BASE -> "base" 105 | | `BLOCKQUOTE -> "blockquote" 106 | | `BODY -> "body" 107 | | `BR -> "br" 108 | | `BUTTON -> "button" 109 | | `CANVAS -> "canvas" 110 | | `CAPTION -> "caption" 111 | | `CODE -> "code" 112 | | `COL -> "col" 113 | | `COLGROUP -> "colgroup" 114 | | `DATALIST -> "datalist" 115 | | `DD -> "dd" 116 | | `DETAILS -> "details" 117 | | `DIV -> "div" 118 | | `DL -> "dl" 119 | | `DT -> "dt" 120 | | `EM -> "em" 121 | | `EMBED -> "embed" 122 | | `FIELDSET -> "fieldset" 123 | | `FIGCAPTION -> "figcaption" 124 | | `FIGURE -> "figure" 125 | | `FOOTER -> "footer" 126 | | `FORM -> "form" 127 | | `H1 -> "h1" 128 | | `H2 -> "h2" 129 | | `H3 -> "h3" 130 | | `H4 -> "h4" 131 | | `H5 -> "h5" 132 | | `H6 -> "h6" 133 | | `HEAD -> "head" 134 | | `HEADER -> "header" 135 | | `HGROUP -> "hgroup" 136 | | `HR -> "hr" 137 | | `HTML -> "html" 138 | | `I -> "i" 139 | | `IFRAME -> "iframe" 140 | | `IMG -> "img" 141 | | `INPUT -> "input" 142 | | `KEYGEN -> "keygen" 143 | | `LABEL -> "label" 144 | | `LEGEND -> "legend" 145 | | `LI -> "li" 146 | | `LINK -> "link" 147 | | `MAIN -> "main" 148 | | `META -> "meta" 149 | | `NAV -> "nav" 150 | | `NOSCRIPT -> "noscript" 151 | | `OBJECT -> "object" 152 | | `OL -> "ol" 153 | | `OPTGROUP -> "optgroup" 154 | | `OPTION -> "option" 155 | | `P -> "p" 156 | | `PRE -> "pre" 157 | | `PROGRESS -> "progress" 158 | | `Q -> "q" 159 | | `SCRIPT -> "script" 160 | | `SECTION -> "section" 161 | | `SELECT -> "select" 162 | | `SOURCE -> "source" 163 | | `SPAN -> "span" 164 | | `STRONG -> "strong" 165 | | `STYLE -> "style" 166 | | `SUB -> "sub" 167 | | `SUP -> "sup" 168 | | `TABLE -> "table" 169 | | `TBODY -> "tbody" 170 | | `TD -> "td" 171 | | `TEXTAREA -> "textarea" 172 | | `TFOOT -> "tfoot" 173 | | `TH -> "th" 174 | | `THEAD -> "thead" 175 | | `TIME -> "time" 176 | | `TITLE -> "title" 177 | | `TR -> "tr" 178 | | `TRACK -> "track" 179 | | `U -> "u" 180 | | `UL -> "ul" 181 | | `VIDEO -> "video" 182 | | `WBR -> "wbr" 183 | | `RAW -> "raw" 184 | | `NAME s -> s 185 | | `VAR _ -> failwith "Cannot convert var to string" 186 | 187 | let nonclosing = [ `IMG; `INPUT; `HR; `META; `BR; `WBR; `LINK ] 188 | end 189 | 190 | type t = { 191 | tag : Tag.t; 192 | mutable attrs : (string * string) list; 193 | mutable content : string option; 194 | mutable children : t list; 195 | } 196 | (** HTML node type *) 197 | 198 | let rec replace (a : t) (name : string) (b : t) : t = 199 | match a.tag with 200 | | `VAR s when s = name -> b 201 | | _ -> 202 | { 203 | tag = a.tag; 204 | attrs = a.attrs; 205 | content = a.content; 206 | children = List.map (fun i -> replace i name b) a.children; 207 | } 208 | 209 | let tag ?(attr = []) ?(content = None) ?(children = []) (tag : Tag.t) : t = 210 | { tag; attrs = attr; content; children } 211 | 212 | let var name = tag (`VAR name) 213 | 214 | let import name = 215 | let ic = open_in name in 216 | let n = in_channel_length ic in 217 | let s = Bytes.create n in 218 | really_input ic s 0 n; 219 | close_in ic; 220 | tag ~content:(Some (Bytes.to_string s)) `RAW 221 | 222 | let html ?(attr = []) ?content children = tag ~attr ~content ~children `HTML 223 | 224 | let body ?(attr = []) ?content children = tag ~attr ~content ~children `BODY 225 | 226 | let head ?(attr = []) ?content children = tag ~attr ~content ~children `HEAD 227 | 228 | let meta attr = tag ~attr `META 229 | 230 | let script ?(attr = []) content = tag ~attr ~content:(Some content) `SCRIPT 231 | 232 | let canvas ?content attr = tag ~attr ~content `CANVAS 233 | 234 | let style ?(attr = []) content = tag ~attr ~content:(Some content) `STYLE 235 | 236 | let iframe attr = tag ~attr `IFRAME 237 | 238 | let div ?(attr = []) ?content children = tag ~attr ~content ~children `DIV 239 | 240 | let p ?(attr = []) ?(children = []) content = 241 | tag ~attr ~content:(Some content) ~children `P 242 | 243 | let span ?(attr = []) ?content children = tag ~attr ~content ~children `SPAN 244 | 245 | let h1 ?(attr = []) ?(children = []) content = 246 | tag ~attr ~content:(Some content) ~children `H1 247 | 248 | let h2 ?(attr = []) ?(children = []) content = 249 | tag ~attr ~content:(Some content) ~children `H2 250 | 251 | let h3 ?(attr = []) ?(children = []) content = 252 | tag ~attr ~content:(Some content) ~children `H3 253 | 254 | let h4 ?(attr = []) ?(children = []) content = 255 | tag ~attr ~content:(Some content) ~children `H4 256 | 257 | let h5 ?(attr = []) ?(children = []) content = 258 | tag ~attr ~content:(Some content) ~children `H5 259 | 260 | let h6 ?(attr = []) ?(children = []) content = 261 | tag ~attr ~content:(Some content) ~children `H6 262 | 263 | let header ?(attr = []) ?content children = tag ~attr ~content ~children `HEADER 264 | 265 | let main ?(attr = []) ?content children = tag ~attr ~content ~children `MAIN 266 | 267 | let nav ?(attr = []) ?content children = tag ~attr ~content ~children `NAV 268 | 269 | let article ?(attr = []) ?content children = 270 | tag ~attr ~content ~children `ARTICLE 271 | 272 | let section ?(attr = []) ?content children = 273 | tag ~attr ~content ~children `SECTION 274 | 275 | let aside ?(attr = []) ?content children = tag ~attr ~content ~children `ASIDE 276 | 277 | let footer ?(attr = []) ?content children = tag ~attr ~content ~children `FOOTER 278 | 279 | let ul ?(attr = []) ?content children = tag ~attr ~content ~children `UL 280 | 281 | let ol ?(attr = []) ?content children = tag ~attr ~content ~children `OL 282 | 283 | let li ?(attr = []) ?content children = tag ~attr ~content ~children `LI 284 | 285 | let text ?(attr = []) (s : string) = tag ~attr ~content:(Some s) `SPAN 286 | 287 | let label ?(attr = []) (s : string) = tag ~attr ~content:(Some s) `LABEL 288 | 289 | let link ?(children = []) ?content attr = tag ~attr ~content ~children `LINK 290 | 291 | let a ?(children = []) attr content = 292 | tag ~attr ~content:(Some content) ~children `A 293 | 294 | let img attr = tag ~attr `IMG 295 | 296 | let textarea ?(attr = []) (s : string) = tag ~attr ~content:(Some s) `TEXTAREA 297 | 298 | let input attr = tag ~attr `INPUT 299 | 300 | let select ?(attr = []) children = tag ~attr ~children `SELECT 301 | 302 | let opt ?(attr = []) (s : string) = tag ~attr ~content:(Some s) `OPTION 303 | 304 | let form ?(attr = []) children = tag ~attr ~children `FORM 305 | 306 | let mk_form ?attr attrs submit_text = 307 | form ?attr 308 | ( List.map (fun a -> input a) attrs 309 | @ [ input [ ("type", "submit"); ("value", submit_text) ] ] ) 310 | 311 | let audio ?(attr = []) ?content children = tag ~attr ~content ~children `AUDIO 312 | 313 | let video ?(attr = []) ?content children = tag ~attr ~content ~children `VIDEO 314 | 315 | let source attr = tag ~attr `SOURCE 316 | 317 | let title content = tag ~content:(Some content) `TITLE 318 | 319 | let inline (s : string) = tag ~content:(Some s) `RAW 320 | 321 | let rec string_of_attrs (node : t) : string = 322 | (if List.length node.attrs > 0 then " " else "") 323 | ^ String.concat " " (List.map (fun (k, v) -> k ^ "=\"" ^ v ^ "\"") node.attrs) 324 | 325 | and string_of_content (node : t) : string = 326 | match node.content with Some s -> s | None -> "" 327 | 328 | and string_of_children (node : t) : string = 329 | String.concat "\n" (List.map to_string node.children) 330 | 331 | and to_string (node : t) : string = 332 | let tag = Tag.to_string node.tag in 333 | match node with 334 | | _ when tag = "raw" -> ( match node.content with Some s -> s | None -> "" ) 335 | | _ when List.mem node.tag Tag.nonclosing -> 336 | "<" ^ tag ^ string_of_attrs node ^ " />" 337 | | _ -> 338 | "<" ^ tag ^ string_of_attrs node ^ ">" ^ string_of_content node 339 | ^ string_of_children node ^ "" 340 | 341 | let templates : (string, t) Hashtbl.t = Hashtbl.create 16 342 | 343 | let template_exists name = Hashtbl.mem templates name 344 | 345 | let get_template name = Hashtbl.find templates name 346 | 347 | let set_template name tmpl = Hashtbl.replace templates name tmpl 348 | 349 | (** Loading compiled templates *) 350 | let loadfile filename = Dynlink.loadfile filename 351 | -------------------------------------------------------------------------------- /src/yurt_html.mli: -------------------------------------------------------------------------------- 1 | module Tag : sig 2 | type t = 3 | [ `A 4 | | `ADDR 5 | | `ADDRESS 6 | | `AREA 7 | | `ARTICLE 8 | | `ASIDE 9 | | `AUDIO 10 | | `B 11 | | `BASE 12 | | `BLOCKQUOTE 13 | | `BODY 14 | | `BR 15 | | `BUTTON 16 | | `CANVAS 17 | | `CAPTION 18 | | `CODE 19 | | `COL 20 | | `COLGROUP 21 | | `DATALIST 22 | | `DD 23 | | `DETAILS 24 | | `DIV 25 | | `DL 26 | | `DT 27 | | `EM 28 | | `EMBED 29 | | `FIELDSET 30 | | `FIGCAPTION 31 | | `FIGURE 32 | | `FOOTER 33 | | `FORM 34 | | `H1 35 | | `H2 36 | | `H3 37 | | `H4 38 | | `H5 39 | | `H6 40 | | `HEAD 41 | | `HEADER 42 | | `HGROUP 43 | | `HR 44 | | `HTML 45 | | `I 46 | | `IFRAME 47 | | `IMG 48 | | `INPUT 49 | | `KEYGEN 50 | | `LABEL 51 | | `LEGEND 52 | | `LI 53 | | `LINK 54 | | `MAIN 55 | | `META 56 | | `NAME of string 57 | | `NAV 58 | | `NOSCRIPT 59 | | `OBJECT 60 | | `OL 61 | | `OPTGROUP 62 | | `OPTION 63 | | `P 64 | | `PRE 65 | | `PROGRESS 66 | | `Q 67 | | `RAW 68 | | `SCRIPT 69 | | `SECTION 70 | | `SELECT 71 | | `SOURCE 72 | | `SPAN 73 | | `STRONG 74 | | `STYLE 75 | | `SUB 76 | | `SUP 77 | | `TABLE 78 | | `TBODY 79 | | `TD 80 | | `TEXTAREA 81 | | `TFOOT 82 | | `TH 83 | | `THEAD 84 | | `TIME 85 | | `TITLE 86 | | `TR 87 | | `TRACK 88 | | `U 89 | | `UL 90 | | `VAR of string 91 | | `VIDEO 92 | | `WBR ] 93 | 94 | val to_string : t -> string 95 | 96 | val nonclosing : [> `BR | `HR | `IMG | `INPUT | `LINK | `META | `WBR ] list 97 | end 98 | 99 | type t = { 100 | tag : Tag.t; 101 | mutable attrs : (string * string) list; 102 | mutable content : string option; 103 | mutable children : t list; 104 | } 105 | 106 | val replace : t -> string -> t -> t 107 | 108 | val tag : 109 | ?attr:(string * string) list -> 110 | ?content:string option -> 111 | ?children:t list -> 112 | Tag.t -> 113 | t 114 | 115 | val var : string -> t 116 | 117 | val import : string -> t 118 | 119 | val html : ?attr:(string * string) list -> ?content:string -> t list -> t 120 | 121 | val body : ?attr:(string * string) list -> ?content:string -> t list -> t 122 | 123 | val head : ?attr:(string * string) list -> ?content:string -> t list -> t 124 | 125 | val meta : (string * string) list -> t 126 | 127 | val script : ?attr:(string * string) list -> string -> t 128 | 129 | val canvas : ?content:string -> (string * string) list -> t 130 | 131 | val style : ?attr:(string * string) list -> string -> t 132 | 133 | val iframe : (string * string) list -> t 134 | 135 | val div : ?attr:(string * string) list -> ?content:string -> t list -> t 136 | 137 | val p : ?attr:(string * string) list -> ?children:t list -> string -> t 138 | 139 | val span : ?attr:(string * string) list -> ?content:string -> t list -> t 140 | 141 | val h1 : ?attr:(string * string) list -> ?children:t list -> string -> t 142 | 143 | val h2 : ?attr:(string * string) list -> ?children:t list -> string -> t 144 | 145 | val h3 : ?attr:(string * string) list -> ?children:t list -> string -> t 146 | 147 | val h4 : ?attr:(string * string) list -> ?children:t list -> string -> t 148 | 149 | val h5 : ?attr:(string * string) list -> ?children:t list -> string -> t 150 | 151 | val h6 : ?attr:(string * string) list -> ?children:t list -> string -> t 152 | 153 | val header : ?attr:(string * string) list -> ?content:string -> t list -> t 154 | 155 | val main : ?attr:(string * string) list -> ?content:string -> t list -> t 156 | 157 | val nav : ?attr:(string * string) list -> ?content:string -> t list -> t 158 | 159 | val article : ?attr:(string * string) list -> ?content:string -> t list -> t 160 | 161 | val section : ?attr:(string * string) list -> ?content:string -> t list -> t 162 | 163 | val aside : ?attr:(string * string) list -> ?content:string -> t list -> t 164 | 165 | val footer : ?attr:(string * string) list -> ?content:string -> t list -> t 166 | 167 | val ul : ?attr:(string * string) list -> ?content:string -> t list -> t 168 | 169 | val ol : ?attr:(string * string) list -> ?content:string -> t list -> t 170 | 171 | val li : ?attr:(string * string) list -> ?content:string -> t list -> t 172 | 173 | val text : ?attr:(string * string) list -> string -> t 174 | 175 | val label : ?attr:(string * string) list -> string -> t 176 | 177 | val link : ?children:t list -> ?content:string -> (string * string) list -> t 178 | 179 | val a : ?children:t list -> (string * string) list -> string -> t 180 | 181 | val img : (string * string) list -> t 182 | 183 | val textarea : ?attr:(string * string) list -> string -> t 184 | 185 | val input : (string * string) list -> t 186 | 187 | val select : ?attr:(string * string) list -> t list -> t 188 | 189 | val opt : ?attr:(string * string) list -> string -> t 190 | 191 | val form : ?attr:(string * string) list -> t list -> t 192 | 193 | val mk_form : 194 | ?attr:(string * string) list -> (string * string) list list -> string -> t 195 | 196 | val audio : ?attr:(string * string) list -> ?content:string -> t list -> t 197 | 198 | val video : ?attr:(string * string) list -> ?content:string -> t list -> t 199 | 200 | val source : (string * string) list -> t 201 | 202 | val title : string -> t 203 | 204 | val inline : string -> t 205 | 206 | val string_of_attrs : t -> string 207 | 208 | val string_of_content : t -> string 209 | 210 | val string_of_children : t -> string 211 | 212 | val to_string : t -> string 213 | 214 | val templates : (string, t) Hashtbl.t 215 | 216 | val template_exists : string -> bool 217 | 218 | val get_template : string -> t 219 | 220 | val set_template : string -> t -> unit 221 | 222 | val loadfile : string -> unit 223 | -------------------------------------------------------------------------------- /src/yurt_request_ctx.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | module Request = Cohttp_lwt_unix.Request 3 | module Response = Cohttp.Response 4 | module Header = Cohttp.Header 5 | 6 | module Body = struct 7 | include Cohttp_lwt.Body 8 | 9 | type transfer_encoding = Cohttp.Transfer.encoding 10 | 11 | let to_string = Cohttp_lwt.Body.to_string 12 | 13 | let to_stream = Cohttp_lwt.Body.to_stream 14 | 15 | let to_json body = 16 | Cohttp_lwt.Body.to_string body >|= fun s -> Ezjsonm.from_string s 17 | 18 | let of_string = Cohttp_lwt.Body.of_string 19 | 20 | let of_stream = Cohttp_lwt.Body.of_stream 21 | 22 | let of_json j = Ezjsonm.to_string j |> Cohttp_lwt.Body.of_string 23 | 24 | let map = Cohttp_lwt.Body.map 25 | 26 | let length = Cohttp_lwt.Body.length 27 | 28 | let is_empty = Cohttp_lwt.Body.is_empty 29 | 30 | let drain = Cohttp_lwt.Body.drain_body 31 | 32 | let transfer_encoding = Cohttp_lwt.Body.transfer_encoding 33 | end 34 | 35 | type status_code = Cohttp.Code.status_code 36 | (** Response status code *) 37 | 38 | and response = (Response.t * Body.t) Lwt.t 39 | (** Response type *) 40 | 41 | and endpoint = Request.t -> Yurt_route.params -> Body.t -> response 42 | (** HTTP handler *) 43 | 44 | module Query = struct 45 | type t = (string, string list) Hashtbl.t 46 | 47 | let query_all (req : Request.t) : (string * string list) list = 48 | Uri.query (Request.uri req) 49 | 50 | let query_dict_of_query (q : (string * string list) list) = 51 | let d = Hashtbl.create 16 in 52 | List.iter 53 | (fun (k, v) -> 54 | if Hashtbl.mem d k then 55 | let l = Hashtbl.find d k in 56 | Hashtbl.replace d k (l @ v) 57 | else Hashtbl.replace d k v) 58 | q; 59 | d 60 | 61 | (** Get a hashtable of all query string parameters *) 62 | let get req : (string, string list) Hashtbl.t = 63 | query_dict_of_query (query_all req) 64 | 65 | (** Convert all query string paramters to a json object *) 66 | let to_json req : Ezjsonm.t = 67 | let f = query_all req in 68 | `O 69 | (List.map 70 | (fun (k, v) -> 71 | if List.length v = 1 then (k, Ezjsonm.encode_string (List.nth v 0)) 72 | else (k, `A (List.map Ezjsonm.encode_string v))) 73 | f) 74 | 75 | (** Get a string value for a single query string value by key *) 76 | let string req (name : string) : string option = 77 | Uri.get_query_param (Request.uri req) name 78 | 79 | (** Get an int value for a single query string value by key *) 80 | let int req (name : string) : int option = 81 | let qs = string req name in 82 | match qs with 83 | | Some s -> ( try Some (int_of_string s) with _ -> None ) 84 | | None -> None 85 | 86 | (** Get a float value for a single query string value by key*) 87 | let float req (name : string) : float option = 88 | let qe = string req name in 89 | match qe with 90 | | Some s -> ( try Some (float_of_string s) with _ -> None ) 91 | | None -> None 92 | 93 | (** Get a json value for a single query string value by key*) 94 | let json req (name : string) = 95 | let qe = string req name in 96 | match qe with 97 | | Some s -> ( try Some (Ezjsonm.from_string s) with _ -> None ) 98 | | None -> None 99 | end 100 | -------------------------------------------------------------------------------- /src/yurt_route.ml: -------------------------------------------------------------------------------- 1 | exception Invalid_route_type 2 | 3 | (** The `Route module helps with building routes *) 4 | 5 | type route = 6 | [ `String of string 7 | | `Int of string 8 | | `Float of string 9 | | `Path of string 10 | | `Match of string * string 11 | | `Route of route list ] 12 | (** The route type allows for URL routes to be built using strong types *) 13 | 14 | type params = (string, route) Hashtbl.t 15 | (** The type that contains parsed URL parameters *) 16 | 17 | (** The route cache allows the route -> regexp process to be memoized *) 18 | let route_cache : (route, Str.regexp) Hashtbl.t = Hashtbl.create 16 19 | 20 | let concat_filenames (s : string list) : string = 21 | if List.length s = 0 then "" 22 | else if List.length s = 1 then List.hd s 23 | else 24 | List.fold_left (fun acc p -> Filename.concat acc p) (List.hd s) (List.tl s) 25 | 26 | let slash_regexp = Str.regexp "/" 27 | 28 | let routevar_regexp = Str.regexp "<\\([a-z]+\\):\\([^>]+\\)>" 29 | 30 | (** Convert a route to string *) 31 | let rec to_string (r : route) : string = 32 | match r with 33 | | `String _ -> "\\([^/]+\\)" 34 | | `Int _ -> "\\(-?[0-9]+\\)" 35 | | `Float _ -> "\\(-?[0-9]*[.e][0-9]*\\)" 36 | | `Path s -> s 37 | | `Match (_, s) -> "\\(" ^ s ^ "\\)" 38 | | `Route p -> "/" ^ concat_filenames (List.map to_string p) ^ "/?" 39 | 40 | (** Convert a route to regexp *) 41 | let to_regexp r : Str.regexp = 42 | try Hashtbl.find route_cache r 43 | with Not_found -> 44 | let rx = Str.regexp (to_string r) in 45 | Hashtbl.replace route_cache r rx; 46 | rx 47 | 48 | (** "/user/" -> `Path "user", `Int "name" *) 49 | let of_string (s : string) = 50 | let args = Str.split slash_regexp s in 51 | `Route 52 | (List.map 53 | (fun arg -> 54 | if Str.string_match routevar_regexp arg 0 then 55 | let name = Str.matched_group 1 arg in 56 | let kind = Str.matched_group 2 arg in 57 | match kind with 58 | | "int" -> `Int name 59 | | "float" -> `Float name 60 | | "string" -> `String name 61 | | _ -> `Match (name, kind) 62 | else `Path arg) 63 | args) 64 | 65 | (** Returns a list of variables found in a route *) 66 | let rec variables r = 67 | match r with 68 | | `String _ | `Int _ | `Float _ | `Match _ -> [ r ] 69 | | `Route (h :: t) -> variables h @ variables (`Route t) 70 | | `Route [] -> [] 71 | | `Path _ -> [] 72 | 73 | (** Check to see if a string matches the route's regexp *) 74 | let matches r s : bool = 75 | Str.string_match (to_regexp r) s 0 76 | && Str.match_beginning () = 0 77 | && Str.match_end () = String.length s 78 | 79 | (** Get a parameters after a successful route match *) 80 | let params r s = 81 | let p = Hashtbl.create 16 in 82 | let idx = ref 1 in 83 | let rec findvar rt = 84 | match rt with 85 | | `String key -> 86 | Hashtbl.replace p key (`String (Str.matched_group !idx s)); 87 | idx := !idx + 1 88 | | `Int key -> 89 | Hashtbl.replace p key (`Int (Str.matched_group !idx s)); 90 | idx := !idx + 1 91 | | `Float key -> 92 | Hashtbl.replace p key (`Float (Str.matched_group !idx s)); 93 | idx := !idx + 1 94 | | `Match (key, _) -> 95 | Hashtbl.replace p key (`String (Str.matched_group !idx s)); 96 | idx := !idx + 1 97 | | `Path _ -> () 98 | | `Route (h :: t) -> 99 | findvar h; 100 | findvar (`Route t) 101 | | `Route [] -> () 102 | in 103 | findvar r; 104 | p 105 | 106 | (** Get a single parameter as int by name *) 107 | let int p s : int = 108 | match Hashtbl.find p s with 109 | | `Int i -> int_of_string i 110 | | `Float i -> int_of_float (float_of_string i) 111 | | `String s | `Match (_, s) -> ( 112 | try int_of_string s with _ -> raise Invalid_route_type ) 113 | | _ -> raise Invalid_route_type 114 | 115 | (** Get a single parameter as float by name *) 116 | let float p s : float = 117 | match Hashtbl.find p s with 118 | | `Int i -> float_of_string i 119 | | `Float i -> float_of_string i 120 | | `String s | `Match (_, s) -> ( 121 | try float_of_string s with _ -> raise Invalid_route_type ) 122 | | _ -> raise Invalid_route_type 123 | 124 | (** Get a single parameter as string by name *) 125 | let string p s : string = 126 | match Hashtbl.find p s with 127 | | `Int s | `String s | `Float s | `Match (_, s) -> s 128 | | _ -> raise Invalid_route_type 129 | 130 | (* Convert a route element to JSON value *) 131 | let rec json_of_route r : Ezjsonm.value = 132 | match r with 133 | | `Int i -> `Float (float_of_string i) 134 | | `Float i -> `Float (float_of_string i) 135 | | `String "true" -> `Bool true 136 | | `String "false" -> `Bool false 137 | | `String i -> `String i 138 | | `Path i -> `String i 139 | | `Match (_, i) -> `String i 140 | | `Route i -> `A (List.map json_of_route i) 141 | 142 | (* Convert params to JSON value *) 143 | let to_json p = 144 | let dst = Hashtbl.fold (fun k v acc -> (k, json_of_route v) :: acc) p [] in 145 | `O dst 146 | -------------------------------------------------------------------------------- /src/yurt_server.ml: -------------------------------------------------------------------------------- 1 | open Yurt_route 2 | open Yurt_request_ctx 3 | include Cohttp_lwt_unix.Server 4 | 5 | type server = { 6 | host : string; 7 | port : int; 8 | mutable routes : (string * route * endpoint) list; 9 | mutable tls_config : Tls.Config.server option; 10 | mutable logger : Lwt_log.logger; 11 | } 12 | 13 | let server ?tls_config ?(logger = !Lwt_log.default) (host : string) (port : int) 14 | : server = 15 | { host; port; routes = []; tls_config; logger } 16 | 17 | let find_string j path = 18 | match Ezjsonm.find j path with 19 | | `String s -> s 20 | | `Float f -> string_of_float f 21 | | _ -> raise Not_found 22 | 23 | let find_float j path = 24 | match Ezjsonm.find j path with 25 | | `String s -> float_of_string s 26 | | `Float f -> f 27 | | _ -> raise Not_found 28 | 29 | let find_tls_config j = 30 | try 31 | let crts = find_string j [ "ssl-certificate" ] in 32 | let key = find_string j [ "ssl-key" ] in 33 | match 34 | ( X509.Certificate.decode_pem_multiple (Cstruct.of_string crts), 35 | X509.Private_key.decode_pem (Cstruct.of_string key) ) 36 | with 37 | | Ok crts, Ok (`RSA key) -> 38 | Some (Tls.Config.server ~certificates:(`Single (crts, key)) ()) 39 | | _ -> None 40 | with Not_found -> None 41 | 42 | let server_from_config filename = 43 | try 44 | let ic = open_in filename in 45 | let j = Ezjsonm.from_channel ic in 46 | let host = find_string j [ "host" ] in 47 | let port = find_float j [ "port" ] |> int_of_float in 48 | let () = close_in ic in 49 | let tls_config = find_tls_config j in 50 | server ?tls_config host port 51 | with Not_found -> 52 | print_endline "Invalid config file"; 53 | exit 1 54 | 55 | exception End_route_iteration of (Response.t * Body.t) Lwt.t 56 | 57 | (* Logging *) 58 | 59 | let log_debug (s : server) section msg = 60 | Lwt_log.ign_debug ~section:(Lwt_log.Section.make section) ~logger:s.logger msg 61 | 62 | let log_info (s : server) section msg = 63 | Lwt_log.ign_info ~section:(Lwt_log.Section.make section) ~logger:s.logger msg 64 | 65 | let log_notice (s : server) section msg = 66 | Lwt_log.ign_notice 67 | ~section:(Lwt_log.Section.make section) 68 | ~logger:s.logger msg 69 | 70 | let log_warning (s : server) section msg = 71 | Lwt_log.ign_warning 72 | ~section:(Lwt_log.Section.make section) 73 | ~logger:s.logger msg 74 | 75 | let log_error (s : server) section msg = 76 | Lwt_log.ign_error ~section:(Lwt_log.Section.make section) ~logger:s.logger msg 77 | 78 | let log_fatal (s : server) section msg = 79 | Lwt_log.ign_fatal ~section:(Lwt_log.Section.make section) ~logger:s.logger msg 80 | 81 | let load_file filename = 82 | let ic = open_in_bin filename in 83 | let ln = in_channel_length ic in 84 | let rs = Bytes.create ln in 85 | really_input ic rs 0 ln; 86 | close_in ic; 87 | Cstruct.of_bytes rs 88 | 89 | (** Configure TLS for server *) 90 | let configure_tls (s : server) (crt_file : string) (key_file : string) : server 91 | = 92 | match 93 | ( X509.Certificate.decode_pem_multiple (load_file crt_file), 94 | X509.Private_key.decode_pem (load_file key_file) ) 95 | with 96 | | Ok crts, Ok (`RSA key) -> 97 | let cfg = Tls.Config.server ~certificates:(`Single (crts, key)) () in 98 | s.tls_config <- Some cfg; 99 | s 100 | | _ -> s 101 | 102 | (** Finish with a string stream *) 103 | let stream ?flush ?headers ?(status = 200) (s : string Lwt_stream.t) = 104 | let status = Cohttp.Code.status_of_code status in 105 | respond ?flush ?headers ~status ~body:(Body.of_stream s) () 106 | 107 | let string ?flush ?headers ?(status = 200) string = 108 | let status = Cohttp.Code.status_of_code status in 109 | respond ?flush ?headers ~status ~body:(Body.of_string string) () 110 | 111 | (** Finish with JSON *) 112 | let json ?flush ?headers ?(status = 200) j = 113 | let status = Cohttp.Code.status_of_code status in 114 | respond_string ?flush ?headers ~status ~body:(Ezjsonm.to_string j) () 115 | 116 | (** Finish with HTML *) 117 | let html ?flush ?headers ?(status = 200) (h : Yurt_html.t) = 118 | let status = Cohttp.Code.status_of_code status in 119 | respond_string ?flush ?headers ~status ~body:(Yurt_html.to_string h) () 120 | 121 | let file ?headers filename = respond_file ?headers ~fname:filename () 122 | 123 | let redirect ?headers (url : string) = 124 | respond_redirect ?headers ~uri:(Uri.of_string url) () 125 | 126 | (** Sets a route for a compiled regex + endpoint function *) 127 | let register (s : server) (r : (string * route * endpoint) list) = 128 | s.routes <- 129 | s.routes 130 | @ List.map (fun (meth, x, ep) -> (String.uppercase_ascii meth, x, ep)) r; 131 | s 132 | 133 | (** Register a single route *) 134 | let register_route_string (s : server) (meth : string) (route : string) 135 | (ep : endpoint) = 136 | register s [ (meth, Yurt_route.of_string route, ep) ] 137 | 138 | (** Register a single route *) 139 | let register_route (s : server) (meth : string) (r : route) (ep : endpoint) = 140 | register s [ (meth, r, ep) ] 141 | 142 | (** Register a route for a directory *) 143 | let register_static_file_route ?headers (s : server) (path : string) 144 | (prefix : string) = 145 | register_route s "GET" 146 | (`Route [ `Path prefix; `Match ("path", ".*") ]) 147 | (fun _req params _body -> 148 | if not (Yurt_util.is_safe_path path) then respond_not_found () 149 | else 150 | let filename = Filename.concat path (Yurt_route.string params "path") in 151 | respond_file ?headers ~fname:filename ()) 152 | 153 | (** Register a route for single file *) 154 | let register_single_file_route ?headers (s : server) (filename : string) 155 | (rt : string) = 156 | register_route s "GET" 157 | (`Route [ `Path rt ]) 158 | (fun _req _body _params -> respond_file ?headers ~fname:filename ()) 159 | 160 | let options (r : string) (ep : endpoint) (s : server) = 161 | register_route_string s "OPTIONS" r ep 162 | 163 | let get (r : string) (ep : endpoint) (s : server) = 164 | register_route_string s "GET" r ep 165 | 166 | let post (r : string) (ep : endpoint) (s : server) = 167 | register_route_string s "POST" r ep 168 | 169 | let put (r : string) (ep : endpoint) (s : server) = 170 | register_route_string s "PUT" r ep 171 | 172 | let update (r : string) (ep : endpoint) (s : server) = 173 | register_route_string s "UPDATE" r ep 174 | 175 | let delete (r : string) (ep : endpoint) (s : server) = 176 | register_route_string s "DELETE" r ep 177 | 178 | let static_files (p : string) (r : string) (s : server) = 179 | register_static_file_route s p r 180 | 181 | let static_file (p : string) (f : string) (s : server) = 182 | register_single_file_route s p f 183 | 184 | (** Start the server *) 185 | let cohttp_server (s : server) = 186 | let callback _conn req body = 187 | let uri = Uri.path (Request.uri req) in 188 | try 189 | let _, _route, _endpoint = 190 | List.find 191 | (fun (_method, _route, _endpoint) -> 192 | _method = Cohttp.Code.string_of_method (Request.meth req) 193 | && Yurt_route.matches _route uri) 194 | s.routes 195 | in 196 | _endpoint req (params _route uri) body 197 | with _ -> respond_not_found () 198 | in 199 | make ~callback () 200 | 201 | (** Run as daemon *) 202 | let daemonize ?directory ?syslog (s : server) = 203 | Lwt_daemon.daemonize ~stdin:`Close ~stdout:(`Log s.logger) 204 | ~stderr:(`Log s.logger) ?directory ?syslog () 205 | 206 | (** Start a configured server with attached endpoints *) 207 | let start (s : server) = 208 | let sockaddr = 209 | match Unix.gethostbyname s.host with 210 | | { Unix.h_addrtype = Unix.PF_UNIX; Unix.h_name; _ } -> 211 | Unix.ADDR_UNIX h_name 212 | | { Unix.h_addrtype = _; Unix.h_addr_list; _ } -> 213 | if Array.length h_addr_list > 0 then 214 | Unix.ADDR_INET (h_addr_list.(0), s.port) 215 | else Unix.ADDR_INET (Unix.inet_addr_loopback, s.port) 216 | | exception _ -> Unix.ADDR_INET (Unix.inet_addr_loopback, s.port) 217 | in 218 | match s.tls_config with 219 | | Some tls_config -> 220 | let key = Conduit_lwt_unix_tls.TCP.configuration in 221 | let cfg = 222 | ({ Conduit_lwt_unix_tcp.sockaddr; capacity = 40 }, tls_config) 223 | in 224 | let service = Conduit_lwt_unix_tls.TCP.service in 225 | create key cfg service (cohttp_server s) 226 | | None -> 227 | let key = Conduit_lwt_unix_tcp.configuration in 228 | let cfg = { Conduit_lwt_unix_tcp.sockaddr; capacity = 40 } in 229 | let service = Conduit_lwt_unix_tcp.service in 230 | create key cfg service (cohttp_server s) 231 | 232 | exception Cannot_start_server 233 | 234 | let run s = try Lwt_main.run (start s) with _ -> raise Cannot_start_server 235 | 236 | let route (s : server) (fn : server -> server) : server = fn s 237 | 238 | (** Add a handler *) 239 | let ( >| ) (s : server) (fn : server -> server) : server = route 240 | 241 | (** Run a function that returns unit in the handler definition chain *) 242 | let ( >|| ) (s : server) (fn : server -> unit) : server = 243 | fn s; 244 | s 245 | -------------------------------------------------------------------------------- /src/yurt_util.ml: -------------------------------------------------------------------------------- 1 | let _ = Random.self_init () 2 | 3 | (** Unwrap option and raise Not_found if opt is None *) 4 | let unwrap_option opt = match opt with Some a -> a | None -> raise Not_found 5 | 6 | (** Get the value of an option type or return `d` *) 7 | let unwrap_option_default opt d = match opt with Some a -> a | None -> d 8 | 9 | (** Generate a UUID (verison 4) *) 10 | let uuid4 () = 11 | let four_digits () = Random.int 64096 in 12 | let three_digits () = Random.int 4096 in 13 | Printf.sprintf "%x-%x-4%x-a%x-%x%x" (Random.bits ()) (four_digits ()) 14 | (three_digits ()) (three_digits ()) (Random.bits ()) (four_digits ()) 15 | 16 | let safe_path_regexp = Str.regexp ".*/?\\.\\./?.*" 17 | 18 | (** Check if a path contains '/..' *) 19 | let is_safe_path ?prefix path = 20 | (not (Str.string_match safe_path_regexp path 0)) 21 | && 22 | match prefix with 23 | | Some s -> String.sub path 0 (String.length s) = s 24 | | None -> true 25 | -------------------------------------------------------------------------------- /yurt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "Zach Shipko " 3 | authors: ["Zach Shipko"] 4 | license: "ISC" 5 | homepage: "https://github.com/zshipko/yurt" 6 | bug-reports: "https://github.com/zshipko/yurt/issues" 7 | dev-repo: "https://github.com/zshipko/yurt.git" 8 | doc: "https://zshipko.github.io/yurt/doc" 9 | 10 | depends: [ 11 | "dune" {build} 12 | "conduit-lwt-unix" {>= "1.0.0"} 13 | "cohttp-lwt-unix" {>= "1.0.0"} 14 | "lwt_log" {>= "1.0.0"} 15 | "ezjsonm" {>= "0.5.0"} 16 | ] 17 | 18 | build: [[ 19 | "dune" "build" "-p" name "-j" jobs 20 | ]] 21 | available: [ ocaml-version >= "4.03.0" ] 22 | 23 | --------------------------------------------------------------------------------