doc
37 |
38 | %%
39 |
40 | doc :
41 | | opens=Open* fun_args=Func? doctype=Dtd? root=html_element { {Doc.opens; fun_args; doctype; root } }
42 | | Eof { failwith "empty view not allowwed" }
43 |
44 | html_element :
45 | | Tag_open tag_name=Tag_name attributes=attribute* Tag_close
46 | children=html_content*
47 | Tag_open_slash Tag_name Tag_close
48 | { Doc.Element {tag_name;attributes; children} }
49 | | Tag_open tag_name=Tag_name attributes=attribute* Tag_slash_close
50 | { Doc.Element {tag_name; attributes;children=[]} }
51 |
52 | html_content :
53 | | Code_open code=code* Code_close { Doc.Code code }
54 | | view_name=Apply_view { Doc.Apply_view view_name }
55 | | string_val=Code_at { Doc.Element_code_at string_val }
56 | | comment=html_comment { comment }
57 | | cdata=Cdata { Doc.Cdata cdata }
58 | | text=Html_text { Doc.Html_text text }
59 | | el=html_element { el }
60 |
61 | code :
62 | | code_block=Code_block { Doc.Code_block code_block }
63 | | el=code_element { el }
64 | | string_val=Code_at { Doc.Code_at string_val }
65 | | text=Html_text { Doc.Code_text text }
66 |
67 | code_element :
68 | | Tag_open tag_name=Tag_name attributes=attribute* Tag_close
69 | children=code*
70 | Tag_open_slash Tag_name Tag_close
71 | { Doc.Code_element {tag_name; attributes; children } }
72 | | Tag_open tag_name=Tag_name attributes=attribute* Tag_slash_close
73 | { Doc.Code_element {tag_name; attributes; children = [] } }
74 |
75 | html_comment :
76 | | comment=Html_comment {Doc.Html_comment comment }
77 | | comment=Html_conditional_comment {Doc.Html_conditional_comment comment }
78 |
79 | attribute :
80 | | code_block = Code_attr { Doc.Code_attribute code_block }
81 | | name=Attr_name { Doc.Bool_attribute name }
82 | | name=Attr_name Tag_equals attr_val=Single_quoted_attr_val { Doc.Single_quoted_attribute (name, attr_val) }
83 | | name=Attr_name Tag_equals attr_val=Double_quoted_attr_val { Doc.Double_quoted_attribute (name, attr_val) }
84 | | name=Attr_name Tag_equals attr_val=Unquoted_attr_val { Doc.Unquoted_attribute (name, attr_val) }
85 | | name=Attr_name Tag_equals attr_val=Code_attr_val { Doc.Name_code_val_attribute (name, attr_val) }
86 |
--------------------------------------------------------------------------------
/lib_spring/body.ml:
--------------------------------------------------------------------------------
1 | type writable =
2 | { write_body : Eio.Buf_write.t -> unit
3 | ; write_headers : Eio.Buf_write.t -> unit
4 | }
5 |
6 | let make_writable ~write_body ~write_headers = { write_body; write_headers }
7 |
8 | let none = { write_body = (fun _ -> ()); write_headers = (fun _ -> ()) }
9 |
10 | let write_body buf_write body = body.write_body buf_write
11 |
12 | let write_headers buf_write body = body.write_headers buf_write
13 |
14 | let writable_content content_type content =
15 | let content_length = String.length content in
16 | { write_body = (fun w -> Eio.Buf_write.string w content)
17 | ; write_headers =
18 | (fun w ->
19 | Headers.write_header w Headers.content_length content_length;
20 | Headers.write_header w Headers.content_type content_type)
21 | }
22 |
23 | let writable_form_values assoc_list =
24 | let content = Uri.pct_encode_name_values assoc_list in
25 | let content_type =
26 | Content_type.make ("application", "x-www-form-urlencoded")
27 | in
28 | writable_content content_type content
29 |
30 | type readable =
31 | { headers : Headers.t
32 | ; buf_read : Eio.Buf_read.t
33 | }
34 |
35 | let make_readable headers buf_read = { headers; buf_read }
36 |
37 | let headers r = r.headers
38 |
39 | let buf_read r = r.buf_read
40 |
41 | let ( let* ) o f = Option.bind o f
42 |
43 | let read_content (t : readable) =
44 | match Headers.(find_opt content_length t.headers) with
45 | | Some len -> ( try Some (Buf_read.take len t.buf_read) with _ -> None)
46 | | None -> None
47 |
48 | let read_form_values (t : readable) =
49 | match
50 | let* content = read_content t in
51 | let* content_type = Headers.(find_opt content_type t.headers) in
52 | match (Content_type.media_type content_type :> string * string) with
53 | | "application", "x-www-form-urlencoded" ->
54 | Uri.query content |> Uri.query_name_values |> Option.some
55 | | _ -> None
56 | with
57 | | Some l -> l
58 | | None -> []
59 |
--------------------------------------------------------------------------------
/lib_spring/body.mli:
--------------------------------------------------------------------------------
1 | (** HTTP request and response body. *)
2 |
3 | (** {1 Writable}
4 |
5 | Request/Response body that can be written. *)
6 |
7 | type writable
8 | (** [writable] encapsulates a specific mechanism to write a request/response
9 | body. *)
10 |
11 | val make_writable :
12 | write_body:(Eio.Buf_write.t -> unit)
13 | -> write_headers:(Eio.Buf_write.t -> unit)
14 | -> writable
15 | (** [make_writable ~write_body ~write_headers] creates a writable [body].
16 |
17 | [write_body] writes reqeust/response [body].
18 |
19 | [write_headers] writes headers associated with [body] *)
20 |
21 | val none : writable
22 | (** [none] is a no-op [writable] that represents the absence of HTTP request or
23 | response body, for e.g. http GET. HEAD, OPTIONS request. *)
24 |
25 | val write_body : Eio.Buf_write.t -> writable -> unit
26 | (** [write_body buf_write body] writes [body] onto [buf_write]. *)
27 |
28 | val write_headers : Eio.Buf_write.t -> writable -> unit
29 | (** [write_headers buf_write body] writes [body] onto [buf_write]. *)
30 |
31 | (** {2 Common Writable Bodies}
32 |
33 | Request/Response bodies that can be written.
34 |
35 | Additional [writable] bodies :
36 |
37 | + {{!section:Chunked.writable} Writable HTTP Chunked Body}
38 | + {{!section:Multipart.writable} Writable Multipart/Form Body} *)
39 |
40 | val writable_content : Content_type.t -> string -> writable
41 | (** [writable_content content_type content] is a fixed-length writable [body]
42 | with content [content].
43 |
44 | [content_type] denotes the type of [content] encoded in [body]. It manifests
45 | in HTTP request/response [Content-Type] header. *)
46 |
47 | val writable_form_values : (string * string) list -> writable
48 | (** [writable_form_values key_values] is a writable [body] which encodes a form
49 | submission content. Its [Content-Type] header is encoded as
50 | "application/x-www.form-urlencoded". *)
51 |
52 | (** {1 Readable} *)
53 |
54 | type readable
55 | (** [readable] is a request/response body that can be read.
56 |
57 | See {!val:Request.readable} and {!val:Response.readable}. *)
58 |
59 | val make_readable : Headers.t -> Eio.Buf_read.t -> readable
60 | (** [make_readable headers buf_read] makes a readable body from [headers] and
61 | [buf_read]. *)
62 |
63 | val headers : readable -> Headers.t
64 | (** [headers r] is HTTP headers {!type:Headers.t} associated with readable body
65 | [r]. *)
66 |
67 | val buf_read : readable -> Eio.Buf_read.t
68 | (** [buf_read r] is buffered reader {!type:Eio.Buf_read.t} associated with
69 | readable body [r]. *)
70 |
71 | (** {2:readers Readers}
72 |
73 | Some common request/response readers.
74 |
75 | Additional readers :
76 |
77 | + {{!section:Multipart.streaming} Multipart Streaming}
78 | + {{!section:Multipart.form} Multipart Form}
79 | + {{!section:Chunked.reader} Reading HTTP Chunked Body} *)
80 |
81 | val read_content : readable -> string option
82 | (** [read_content readable] is [Some content], where [content] is of length [n]
83 | if "Content-Length" header is a valid integer value [n] in [readable].
84 |
85 | If ["Content-Length"] header is missing or is an invalid value, then [None]
86 | is returned. *)
87 |
88 | val read_form_values : readable -> (string * string) list
89 | (** [read_form_values readable] is [form_values] if [readable] body
90 | [Content-Type] is ["application/x-www-form-urlencoded"] and [Content-Length]
91 | is a valid integer value.
92 |
93 | [form_values] is a list of tuple of form [(name, values)] where [name] is
94 | the name of the form field and [values] is a list of values corresponding to
95 | the [name]. *)
96 |
--------------------------------------------------------------------------------
/lib_spring/buf_read.ml:
--------------------------------------------------------------------------------
1 | include Eio.Buf_read
2 |
3 | let take_while1_err () = failwith "take_while1"
4 |
5 | let take_while1 ?(on_error = take_while1_err) p r =
6 | match take_while p r with
7 | | "" -> on_error ()
8 | | x -> x
9 |
10 | let token =
11 | take_while1 (function
12 | | '0' .. '9'
13 | | 'a' .. 'z'
14 | | 'A' .. 'Z'
15 | | '!'
16 | | '#'
17 | | '$'
18 | | '%'
19 | | '&'
20 | | '\''
21 | | '*'
22 | | '+'
23 | | '-'
24 | | '.'
25 | | '^'
26 | | '_'
27 | | '`'
28 | | '|'
29 | | '~' -> true
30 | | _ -> false)
31 |
32 | let ows =
33 | skip_while (function
34 | | ' ' | '\t' -> true
35 | | _ -> false)
36 |
37 | let crlf = string "\r\n"
38 |
39 | let not_cr = function
40 | | '\r' -> false
41 | | _ -> true
42 |
43 | let space = char '\x20'
44 |
45 | open Syntax
46 |
47 | let quoted_pair =
48 | char '\\'
49 | *> let+ c = any_char in
50 | match c with
51 | | '\x09' | ' ' | '\x21' .. '\x7E' | '\x80' .. '\xFF' -> c
52 | | _ -> failwith ("Invalid quoted pair '" ^ Char.escaped c ^ "'")
53 |
54 | let quoted_text =
55 | let+ c = any_char in
56 | match c with
57 | | '\t' | ' ' | '\x21' | '\x23' .. '\x5B' | '\x5D' .. '\x7E' | '\x80' .. '\xFF'
58 | -> c
59 | | _ -> failwith ("Invalid qd_text '" ^ Char.escaped c ^ "'")
60 |
61 | let quoted_string =
62 | let rec aux r =
63 | let c = peek_char r in
64 | match c with
65 | | Some '"' -> []
66 | | Some '\\' ->
67 | let c = quoted_pair r in
68 | c :: aux r
69 | | Some _ ->
70 | let c = quoted_text r in
71 | c :: aux r
72 | | None ->
73 | failwith "Invalid quoted_string. Looking for '\"', '\\' or qd_text value"
74 | in
75 | (char '"'
76 | *> let+ str = aux in
77 | Stdlib.String.of_seq @@ List.to_seq str)
78 | <* char '"'
79 |
80 | let parameter =
81 | let* name = char ';' *> ows *> token in
82 | let name = String.Ascii.lowercase name in
83 | let+ value =
84 | char '='
85 | *> let* c = peek_char in
86 | match c with
87 | | Some '"' -> quoted_string
88 | | Some _ -> token
89 | | None -> failwith "parameter: expecting '\"' or token chars buf got EOF"
90 | in
91 | (name, value)
92 |
93 | let rec parameters r =
94 | let c = (ows *> peek_char) r in
95 | match c with
96 | | Some ';' ->
97 | let param = parameter r in
98 | param :: parameters r
99 | | Some _ | None -> []
100 |
101 | let cookie_octet =
102 | take_while (function
103 | | '\x21'
104 | | '\x23' .. '\x2B'
105 | | '\x2D' .. '\x3A'
106 | | '\x3C' .. '\x5B'
107 | | '\x5D' .. '\x7E' -> true
108 | | _ -> false)
109 |
110 | let cookie_value : string parser =
111 | let* c = peek_char in
112 | match c with
113 | | Some '"' ->
114 | let+ v = char '"' *> cookie_octet <* char '"' in
115 | "\"" ^ v ^ "\""
116 | | Some _ | None -> cookie_octet
117 |
118 | (* +-- Cookie Pair --+ *)
119 |
120 | (* https://datatracker.ietf.org/doc/html/rfc6265#section-4.1 *)
121 | let cookie_pair : (string * string) parser =
122 | ows *> token <* ows <* char '=' *> ows <*> cookie_value
123 |
124 | (* +-- #element - https://www.rfc-editor.org/rfc/rfc9110#name-lists-rule-abnf-extension --+ *)
125 |
126 | let rec next_element p t =
127 | match (ows *> peek_char) t with
128 | | Some ',' -> (
129 | char ',' t;
130 | ows t;
131 | match peek_char t with
132 | | Some ',' -> next_element p t
133 | | Some _ ->
134 | let x = p t in
135 | x :: next_element p t
136 | | None -> [])
137 | | Some c -> failwith @@ Printf.sprintf "[list1] expected ',' but got %c" c
138 | | None -> []
139 |
140 | let list1 (p : 'a parser) t =
141 | (* TODO why doesn't this code work (p t :: next_element p t)? but the one below
142 | works. Is this mis compilation ? *)
143 | let x = p t in
144 | let l = x :: next_element p t in
145 | match l with
146 | | [] -> failwith "[list1] empty elements, requires at least one element"
147 | | l -> l
148 |
149 | let digit =
150 | take_while1 (function
151 | | '0' .. '9' -> true
152 | | _ -> false)
153 |
154 | let delta_seconds t = digit t |> int_of_string
155 |
156 | let validate param_name p v =
157 | match parse_string p v with
158 | | Ok v -> v
159 | | Error (`Msg err) -> Fmt.invalid_arg "[%s] is invalid. %s" param_name err
160 |
--------------------------------------------------------------------------------
/lib_spring/buf_read.mli:
--------------------------------------------------------------------------------
1 | include module type of Eio.Buf_read
2 |
3 | val take_while1 : ?on_error:(unit -> string) -> (char -> bool) -> string parser
4 | (** [take_while1 p] is like {!val:Eio.Buf_read.take_while1} except calls
5 | [on_error] when it consumes less than one character of input.
6 |
7 | @param on_error By default it fails with "take_while1". *)
8 |
9 | val token : string parser
10 |
11 | val crlf : unit parser
12 |
13 | val not_cr : char -> bool
14 |
15 | val ows : unit parser
16 |
17 | val space : unit parser
18 |
19 | val quoted_pair : char parser
20 |
21 | val quoted_text : char parser
22 |
23 | val quoted_string : string parser
24 |
25 | val parameters : (string * string) list parser
26 |
27 | val cookie_value : string parser
28 | (** [cookie_value] parses cookie value. *)
29 |
30 | val cookie_pair : (string * string) parser
31 | (** [cookie_pair] parses cookie name and value. See
32 | {{!https://httpwg.org/http-extensions/draft-ietf-httpbis-rfc6265bis.html#name-syntax}
33 | Cookie/Set-Cookie Syntax} *)
34 |
35 | val list1 : 'a parser -> 'a list parser
36 | (** [list1 p] is a parser that parses at least one element as defined by [p].
37 |
38 | Implement HTTP RFC list element syntax - #element. See
39 | https://www.rfc-editor.org/rfc/rfc9110#name-lists-rule-abnf-extension *)
40 |
41 | val delta_seconds : int parser
42 | (** [delta_seconds] parses [s]. [s] is a non-negative integer representing time
43 | span in seconds.
44 |
45 | See {{!https://www.rfc-editor.org/rfc/rfc9111#delta-seconds} HTTP
46 | delta-seconds}. *)
47 |
48 | val validate : string -> 'a parser -> string -> 'a
49 | (** [validate param_name p v] -> [v] if parser [p] successfully parses [v].
50 |
51 | @raise Invalid_arg
52 | if parsing of [v] by [p] results in an error. [param_name] is used to in
53 | the [Invalid_arg] exception message. *)
54 |
--------------------------------------------------------------------------------
/lib_spring/cache_control.ml:
--------------------------------------------------------------------------------
1 | module Directive = struct
2 | type 'a decode = string -> 'a
3 |
4 | type 'a encode = 'a -> string
5 |
6 | type name = string
7 |
8 | type 'a name_val =
9 | { name : name
10 | ; decode : 'a decode
11 | ; encode : 'a encode
12 | }
13 |
14 | type 'a t =
15 | | Bool : name -> bool t
16 | | Name_val : 'a name_val -> 'a t
17 |
18 | let name : type a. a t -> string = function
19 | | Bool name -> name
20 | | Name_val { name; _ } -> name
21 |
22 | let is_bool : type a. a t -> bool = function
23 | | Bool _ -> true
24 | | Name_val _ -> false
25 |
26 | let make name decode encode = Name_val { name; decode; encode }
27 |
28 | let decode : type a. a t -> a decode option = function
29 | | Bool _ -> None
30 | | Name_val { decode; _ } -> Some decode
31 |
32 | let encode : type a. a t -> a encode option = function
33 | | Bool _ -> None
34 | | Name_val { encode; _ } -> Some encode
35 |
36 | type nonrec bool = bool t
37 |
38 | let make_bool_directive name = Bool name
39 | end
40 |
41 | type t = (string * string option) list
42 |
43 | let empty = []
44 |
45 | let add : type a. ?v:a -> a Directive.t -> t -> t =
46 | fun ?v d t ->
47 | let v =
48 | match d with
49 | | Bool _ -> None
50 | | Name_val { encode; _ } -> (
51 | match v with
52 | | Some v -> Some (encode v)
53 | | None ->
54 | invalid_arg "[v] is [None] but is required for non bool directives")
55 | in
56 | (Directive.name d, v) :: t
57 |
58 | let decode_value : type a. a Directive.t -> string option -> a option =
59 | fun d v ->
60 | match d with
61 | | Directive.Bool _ -> Some true
62 | | Name_val { decode; _ } -> Option.map decode v
63 |
64 | let find_opt : type a. a Directive.t -> t -> a option =
65 | fun d t ->
66 | let find_name = Directive.name d in
67 | let rec loop = function
68 | | [] -> None
69 | | (directive_name, v) :: l ->
70 | if String.equal directive_name find_name then decode_value d v else loop l
71 | in
72 | loop t
73 |
74 | let coerce_bool_directive : type a. a Directive.t -> a = function
75 | | Bool _ -> false
76 | | _ -> raise Not_found
77 |
78 | let find : type a. a Directive.t -> t -> a =
79 | fun d t ->
80 | match find_opt d t with
81 | | Some v -> v
82 | | None -> coerce_bool_directive d
83 |
84 | let exists : type a. a Directive.t -> t -> bool =
85 | fun d t ->
86 | match find_opt d t with
87 | | Some _ -> true
88 | | None -> false
89 |
90 | let remove : type a. a Directive.t -> t -> t =
91 | fun d t ->
92 | let find_name = Directive.name d in
93 | let rec loop t =
94 | match t with
95 | | [] -> t
96 | | ((directive_name, _) as x) :: t ->
97 | if String.equal directive_name find_name then loop t else x :: loop t
98 | in
99 | loop t
100 |
101 | let equal a b =
102 | List.equal
103 | (fun (name1, v1) (name2, v2) ->
104 | let value_equal = Option.equal String.equal v1 v2 in
105 | let name_equal = String.equal name1 name2 in
106 | name_equal && value_equal)
107 | a b
108 |
109 | (* +-- Codec --+ *)
110 |
111 | let decode_cache_directive buf_read =
112 | let name = Buf_read.token buf_read in
113 | match Buf_read.peek_char buf_read with
114 | | Some '=' ->
115 | Buf_read.char '=' buf_read;
116 | (* -- token / quoted_string -- *)
117 | let v =
118 | match Buf_read.peek_char buf_read with
119 | | Some '"' -> "\"" ^ Buf_read.quoted_string buf_read ^ "\""
120 | | Some _ -> Buf_read.token buf_read
121 | | None ->
122 | failwith
123 | @@ Printf.sprintf "[cache_directive: %s] value missing after '='" name
124 | in
125 | (name, Some v)
126 | | Some _ | None -> (name, None)
127 |
128 | let decode s =
129 | let buf_read = Buf_read.of_string s in
130 | Buf_read.list1 decode_cache_directive buf_read
131 |
132 | let encode_cache_directive buf (name, v) =
133 | Buffer.add_string buf name;
134 | match v with
135 | | Some v ->
136 | Buffer.add_char buf '=';
137 | Buffer.add_string buf v
138 | | None -> ()
139 |
140 | let encode = function
141 | | [] -> ""
142 | | v :: t ->
143 | let buf = Buffer.create 10 in
144 | encode_cache_directive buf v;
145 | List.iter
146 | (fun v ->
147 | Buffer.add_string buf ", ";
148 | encode_cache_directive buf v)
149 | t;
150 | Buffer.contents buf
151 |
152 | (* +-- Standard Directives --+ *)
153 | type delta_seconds = int
154 |
155 | let delta_seconds_directive name =
156 | let decode = int_of_string in
157 | let encode = string_of_int in
158 | Directive.make name decode encode
159 |
160 | let max_age = delta_seconds_directive "max-age"
161 |
162 | let max_stale = delta_seconds_directive "max-stale"
163 |
164 | let min_fresh = delta_seconds_directive "min-fresh"
165 |
166 | let no_cache = Directive.make_bool_directive "no-cache"
167 |
168 | let no_store = Directive.make_bool_directive "no-store"
169 |
170 | let no_transform = Directive.make_bool_directive "no-transform"
171 |
172 | let only_if_cached = Directive.make_bool_directive "only-if-cached"
173 |
174 | let must_revalidate = Directive.make_bool_directive "must-revalidate"
175 |
176 | let must_understand = Directive.make_bool_directive "must-understand"
177 |
178 | let private' = Directive.make_bool_directive "private"
179 |
180 | let proxy_revalidate = Directive.make_bool_directive "proxy-revalidate"
181 |
182 | let public = Directive.make_bool_directive "public"
183 |
184 | let s_maxage = delta_seconds_directive "s-maxage"
185 |
186 | (* +-- Pretty Printer --+ *)
187 |
188 | let pp fmt t = Format.fprintf fmt "%s" @@ encode t
189 |
--------------------------------------------------------------------------------
/lib_spring/chunked.mli:
--------------------------------------------------------------------------------
1 | (** [Chunked_body] is HTTP [chunked] Transfer-Encoding encoder and decoders as
2 | described in https://datatracker.ietf.org/doc/html/rfc7230#section-4.1.3. *)
3 |
4 | type t
5 | (** [t] is a HTTP chunk. *)
6 |
7 | val make : ?extensions:(string * string option) list -> string -> t
8 | (** [make data] is a chunk [t]. [t] encapsulates data [data]. If
9 | [String.length data = 0], then the chunk [t] denotes an end of chunked
10 | transfer-encoding transmission.
11 |
12 | @param extensions
13 | is a list of extensions associted with [t]. Chunk extension encodes
14 | additional information about [data] in [t]. An extension is a tuple of
15 | [(name, value)] where [value] is optional. *)
16 |
17 | val data : t -> string option
18 | (** [data t] is [Some data] if a chunk [t] holds data. Otherwise it is [None]. A
19 | [None] data denotes an end of the chunked transfer encoding. *)
20 |
21 | val extensions : t -> (string * string option) list
22 | (** [extensions t] is a list of extensions associated with chunk [t].*)
23 |
24 | (** {1:writable Writable Bodies} *)
25 |
26 | type write_chunk = (t -> unit) -> unit
27 | (** [write_chunk f] specifies HTTP chunks to be written by a
28 | {!type:Body.writer}. We specify chunks by applying [f chunk].
29 |
30 | For example, to write a "Hello, world!" in two chunks of "Hello, " and
31 | "world!", an implementation could be as following :
32 |
33 | {[
34 | let write_chunk f =
35 | f (Chunk {data="Hello, "; extensions = []);
36 | f (Chunk {data="world!"; extension = []);
37 | f (Last_chunk {extensions = []);
38 | ]} *)
39 |
40 | type write_trailer = (Headers.t -> unit) -> unit
41 | (** [write_trailer f] specifies HTTP chunked trailer headers to be written by a
42 | {!type:Body.writer}. We specify the trailer headers by applying [f headers].
43 |
44 | {[
45 | let write_trailer f =
46 | let headers =
47 | Http.Headers.init_with
48 | [ ("Expires", "Wed, 21 Oct 2015 07:28:00 GMT") ]
49 | in
50 | f headers
51 | ]} *)
52 |
53 | val writable :
54 | ua_supports_trailer:bool -> write_chunk -> write_trailer -> Body.writable
55 | (** [writable ~ua_supports_trailer write_chunk write_trailer] is
56 | {!type:Body.writer} for HTTP [chunked] transfer encoding.
57 |
58 | The writer is usually used as a body in HTTP {!type:Request.client} and
59 | {!type:Response.server_response}.
60 |
61 | @param ua_supports_trailer
62 | indicates whether an user-agent such as browsers or HTTP clients supports
63 | receiving chunked trailer headers. This is usually done by adding HTTP
64 | header "TE" with value "trailers" in requests. See
65 | {!val:Request.supports_chunked_trailers}. *)
66 |
67 | (** {1:reader Reader} *)
68 |
69 | val read_chunked : (t -> unit) -> Body.readable -> Headers.t option
70 | (** [read_chunked f readable] is [Some updated_headers] if "Transfer-Encoding"
71 | header value is "chunked" in [request]. Each chunk is applied as [f chunk].
72 | [updated_headers] is the updated headers as specified by the chunked
73 | encoding algorithm in
74 | https://datatracker.ietf.org/doc/html/rfc7230#section-4.1.3.
75 |
76 | Returns [None] if [Transfer-Encoding] header in [headers] is not specified
77 | as "chunked" *)
78 |
79 | (** {1 Pretty Printers} *)
80 |
81 | val pp : Format.formatter -> t -> unit
82 |
--------------------------------------------------------------------------------
/lib_spring/client.mli:
--------------------------------------------------------------------------------
1 | (** HTTP/1.1 client.
2 |
3 | [Client] implements connection reuse based on [host] and [port] attributes
4 | of a HTTP/1.1 connection.
5 |
6 | See {{!common} for common client use cases}. *)
7 |
8 | type t
9 | (** [t] is a HTTP client. It encapsulates client buffered reader/writer initial
10 | sizes, timeout settings for HTTP client calls, and connection reuse
11 | functionality.
12 |
13 | It is safe for concurrent usage.
14 |
15 | See {!val:make}. *)
16 |
17 | val make :
18 | ?timeout:Eio.Time.Timeout.t
19 | -> ?read_initial_size:int
20 | -> ?write_initial_size:int
21 | -> ?maximum_conns_per_host:int
22 | -> ?authenticate_tls:bool
23 | -> Eio.Switch.t
24 | -> #Eio.Net.t
25 | -> t
26 | (** [make sw net] is [t]. [net] is used to create/establish connections to
27 | remote HTTP/1.1 server.
28 |
29 | [sw] is the client resource manager for [t]. All connections are added to
30 | [sw] upon creation and automatically closed when [sw] goes out of scope or
31 | is cancelled. [t] does not outlive [sw]. Attempting to use [t] outside of
32 | scope of [sw] is an error. However, this is not enforced statically by the
33 | type system.
34 |
35 | @param timeout
36 | is the total time limit for establishing a connection, making a request
37 | and getting a response back from the server. However, this value doesn't
38 | include reading response body. Default is [Eio.Time.Timeout.none].
39 | @param read_initial_size
40 | is the initial client buffered reader size. Default is [0x1000].
41 | @param write_initial_size
42 | is the initial client buffered writer size. Default is [0x1000].
43 | @param max_conns_per_host
44 | is the maximum number of connections cached per host,port. The default is
45 | [5].
46 | @param authenticate_tls
47 | if [true] authenticates HTTPS/TLS certificates. Default is [true]. *)
48 |
49 | (** {1:common Common Client Use-Cases}
50 |
51 | Common client use-cases optimized for convenience. *)
52 |
53 | type uri = string
54 | (** [uri] is the full HTTP request uri. [http://www.example.com/products] or
55 | [wwww.example.com/products].
56 |
57 | If HTTP uri scheme - [http/htttps] - is not given, then [http] is assumed. *)
58 |
59 | type request = Request.client Request.t
60 |
61 | type response = Response.client Response.t
62 |
63 | type 'a handler = response -> 'a
64 | (** [handler] is the response handler. [Response.close] is called after
65 | executing the [handler]. *)
66 |
67 | val get : t -> uri -> 'a handler -> 'a
68 | (** [get t uri] is [response] after making a HTTP GET request call to [uri].
69 |
70 | {[
71 | Client.get t "www.example.com"
72 | ]}
73 | @raise Invalid_argument if [uri] is invalid.
74 | @raise Eio.Exn.Io in cases of connection errors. *)
75 |
76 | val head : t -> uri -> 'a handler -> 'a
77 | (** [head t uri] is [response] after making a HTTP HEAD request call to [uri].
78 |
79 | {[
80 | Client.head t "www.example.com"
81 | ]}
82 | @raise Invalid_argument if [uri] is invalid.
83 | @raise Eio.Exn.Io in cases of connection errors. *)
84 |
85 | val post : t -> Body.writable -> uri -> 'a handler -> 'a
86 | (** [post t body uri] is [response] after making a HTTP POST request call with
87 | body [body] to [uri].
88 |
89 | {[
90 | Client.port t body_w "www.example.com/update"
91 | ]}
92 | @raise Invalid_argument if [uri] is invalid.
93 | @raise Eio.Exn.Io in cases of connection errors. *)
94 |
95 | val post_form_values : t -> (string * string) list -> uri -> 'a handler -> 'a
96 | (** [post_form_values t form_values uri] is [response] after making a HTTP POST
97 | request call to [uri] with form values [form_values].
98 |
99 | {[
100 | Client.post_form_values t
101 | [ ("field_a", "val a2"); ("field_b", "val b"]) ]
102 | uri
103 | ]}
104 | @raise Invalid_argument if [uri] is invalid.
105 | @raise Eio.Exn.Io in cases of connection errors. *)
106 |
107 | (** {1 Generic Client Call} *)
108 |
109 | val do_call : t -> request -> 'a handler -> 'a
110 | (** [do_call t req] makes a HTTP request using [req] and returns
111 | {!type:response}.
112 |
113 | @raise Eio.Exn.Io in cases of connection errors. *)
114 |
115 | val call : conn:#Eio.Flow.two_way -> request -> response
116 | (** [call conn req] makes a HTTP client call using connection [conn] and request
117 | [req]. It returns a {!type:response} upon a successfull call.
118 |
119 | {i Note} The function doesn't use connection cache or implement request
120 | redirection or cookie functionality.
121 |
122 | @raise Eio.Exn.Io in cases of connection errors. *)
123 |
124 | (** {1 Client Configuration} *)
125 |
126 | val buf_write_initial_size : t -> int
127 | (** [buf_write_initial_size] is the buffered writer iniital size. *)
128 |
129 | val buf_read_initial_size : t -> int
130 | (** [buf_read_initial_size] is the buffered reader initial size. *)
131 |
132 | val timeout : t -> Eio.Time.Timeout.t
133 | (** [timeout] specifies total time limit for establishing a connection, calling
134 | a request and getting a response back.
135 |
136 | A client request is cancelled if the specified timeout limit is exceeded. *)
137 |
--------------------------------------------------------------------------------
/lib_spring/content_disposition.ml:
--------------------------------------------------------------------------------
1 | type t =
2 | { disposition : string
3 | ; parameters : string String.Map.t
4 | }
5 |
6 | let make ?(params = []) disposition =
7 | let parameters = String.Map.of_seq @@ List.to_seq params in
8 | { disposition = String.Ascii.lowercase disposition; parameters }
9 |
10 | let decode v =
11 | let open Buf_read in
12 | let r = of_string v in
13 | let disposition = token r in
14 | let parameters = parameters r |> String.Map.of_list in
15 | { disposition = String.Ascii.lowercase disposition; parameters }
16 |
17 | let encode t =
18 | let buf = Buffer.create 10 in
19 | Buffer.add_string buf t.disposition;
20 | String.Map.iter
21 | (fun name value ->
22 | Buffer.add_string buf "; ";
23 | Buffer.add_string buf name;
24 | Buffer.add_string buf "=\"";
25 | Buffer.add_string buf value;
26 | Buffer.add_string buf "\"")
27 | t.parameters;
28 | Buffer.contents buf
29 |
30 | let disposition t = t.disposition
31 |
32 | let find_param t param =
33 | let param = String.Ascii.lowercase param in
34 | String.Map.find_opt param t.parameters
35 |
--------------------------------------------------------------------------------
/lib_spring/content_disposition.mli:
--------------------------------------------------------------------------------
1 | (** [Content_disposition] implements [Content-Disposition] header as specified
2 | in https://httpwg.org/specs/rfc6266.html#top *)
3 |
4 | type t
5 | (** [t] is the [Content-Disposition] header value. *)
6 |
7 | val make : ?params:(string * string) list -> string -> t
8 |
9 | val decode : string -> t
10 | (** [decode v] decodes [v] into [t] where [v] holds [Content-Disposition] header
11 | value in textual format.
12 |
13 | {[
14 | Content_disposition.decode "formdata; filename=example.html;"
15 | ]} *)
16 |
17 | val encode : t -> string
18 | (** [encode t] encodes [t] into a textual representation of
19 | [Content-Disposition] header value. *)
20 |
21 | val disposition : t -> string
22 | (** [disposition t] returns the disposition value of [t].
23 |
24 | {[
25 | Content_disposition.decode "formdata; filename=example.html;"
26 | |> Content_disposition.disposition
27 | ]}
28 |
29 | returns ["formdata"]. *)
30 |
31 | val find_param : t -> string -> string option
32 | (** [find_param t param_name] is [Some param_value] if [param_name] exists in
33 | [t]. It is [None] otherwise. *)
34 |
--------------------------------------------------------------------------------
/lib_spring/content_type.ml:
--------------------------------------------------------------------------------
1 | type t =
2 | { type_ : string
3 | ; sub_type : string
4 | ; parameters : string String.Map.t
5 | }
6 |
7 | type media_type = string * string
8 |
9 | open Buf_read.Syntax
10 | open Buf_read
11 |
12 | let p r =
13 | let type_ = token r |> String.Ascii.lowercase in
14 | let sub_type = (char '/' *> token) r |> String.Ascii.lowercase in
15 | let parameters = parameters r in
16 | let parameters = String.Map.of_list parameters in
17 | { type_; sub_type; parameters }
18 |
19 | let make ?(params = []) (type_, sub_type) =
20 | let parameters =
21 | List.map (fun (k, v) -> (String.Ascii.lowercase k, v)) params
22 | |> String.Map.of_list
23 | in
24 | let type_ = String.Ascii.lowercase type_ in
25 | let sub_type = String.Ascii.lowercase sub_type in
26 | { type_; sub_type; parameters }
27 |
28 | let decode v = p (of_string v)
29 |
30 | let encode t =
31 | let buf = Buffer.create 10 in
32 | Buffer.add_string buf t.type_;
33 | Buffer.add_string buf "/";
34 | Buffer.add_string buf t.sub_type;
35 | String.Map.iter
36 | (fun name value ->
37 | Buffer.add_string buf "; ";
38 | Buffer.add_string buf name;
39 | Buffer.add_string buf "=";
40 | Buffer.add_string buf value)
41 | t.parameters;
42 | Buffer.contents buf
43 |
44 | let media_type t = (t.type_, t.sub_type)
45 |
46 | let find_param t name =
47 | String.Map.find_opt (String.Ascii.lowercase name) t.parameters
48 |
49 | let charset t = String.Map.find_opt "charset" t.parameters
50 |
--------------------------------------------------------------------------------
/lib_spring/content_type.mli:
--------------------------------------------------------------------------------
1 | (** [Content_type] implements "Content-Type" header value encoding/decoding as
2 | specified in https://httpwg.org/specs/rfc9110.html#rfc.section.8.3 *)
3 |
4 | type t
5 | (** [t] is the HTTP [Content-Type] header value. *)
6 |
7 | type media_type = private string * string
8 | (** [media_type] is a tuple of [(type, subtype)]. e.g. text/plain, text/html,
9 | multipart/formdata etc. It is in ASCII lowercase.
10 |
11 | See https://httpwg.org/specs/rfc9110.html#rfc.section.8.3.1 *)
12 |
13 | val make : ?params:(string * string) list -> string * string -> t
14 | (** [make media_type] is [t].
15 |
16 | @param params is the list of parameters encoded in [t]. Default is [[]]. *)
17 |
18 | (** {1 Codec} *)
19 |
20 | val decode : string -> t
21 | (** [decode v] decodes [v] into [t].
22 |
23 | {i example} Decode a following content type header:
24 | [Content-Type: multipart/form-data; boundary=------------------3862150; charset="utf-8"]
25 |
26 | {[
27 | Content_type.decode
28 | "multipart/form-data; boundary=------------------3862150; \
29 | charset=\"utf-8\""
30 | ]} *)
31 |
32 | val encode : t -> string
33 | (** [encode t] encodes [t] into a string. *)
34 |
35 | (** {1 Media Type, Charset} *)
36 |
37 | val media_type : t -> media_type
38 | (** [media_type t] is the media type of [t]. *)
39 |
40 | val charset : t -> string option
41 | (** [charset t] is [Some charset] if a character encoding is provided in [t]. It
42 | is [None] otherwise.
43 |
44 | [charset] is the textual character encoding scheme in [t], e.g.
45 | [charset=utf8]. [charset] value is case-insensitive.
46 |
47 | See https://httpwg.org/specs/rfc9110.html#rfc.section.8.3.2 *)
48 |
49 | (** {1 Params} *)
50 |
51 | val find_param : t -> string -> string option
52 | (** [find_param t param] is [Some v] is [param] exists in [t]. It is [None]
53 | otherwise. *)
54 |
--------------------------------------------------------------------------------
/lib_spring/cookie.ml:
--------------------------------------------------------------------------------
1 | module Map = Map.Make (String)
2 |
3 | type cookie_value =
4 | { name_prefix : Cookie_name_prefix.t option
5 | ; value : string
6 | }
7 |
8 | type t = cookie_value Map.t
9 |
10 | let decode v =
11 | let r = Buf_read.of_string v in
12 | let rec aux m =
13 | let name, value = Buf_read.cookie_pair r in
14 | let name, name_prefix =
15 | Cookie_name_prefix.cut_prefix ~case_sensitive:true name
16 | in
17 | let m = Map.add name { name_prefix; value } m in
18 | match Buf_read.peek_char r with
19 | | Some ';' ->
20 | Buf_read.char ';' r;
21 | Buf_read.ows r;
22 | aux m
23 | | Some _ | None -> m
24 | in
25 | aux Map.empty
26 |
27 | let encode t =
28 | let buf = Buffer.create 10 in
29 | let i = ref 1 in
30 | Map.iter
31 | (fun name { name_prefix; value } ->
32 | if !i > 1 then Buffer.add_char buf ';';
33 | (match name_prefix with
34 | | Some prefix ->
35 | Buffer.add_string buf @@ Cookie_name_prefix.to_string prefix
36 | | None -> ());
37 | Buffer.add_string buf name;
38 | Buffer.add_char buf '=';
39 | Buffer.add_string buf value;
40 | i := !i + 1)
41 | t;
42 | Buffer.contents buf
43 |
44 | let empty = Map.empty
45 |
46 | let is_empty t = Map.is_empty t
47 |
48 | let name_prefix name t =
49 | Option.bind (Map.find_opt name t) @@ fun { name_prefix; _ } -> name_prefix
50 |
51 | let find_opt cookie_name t =
52 | Option.map (fun { value; _ } -> value) @@ Map.find_opt cookie_name t
53 |
54 | let add ?name_prefix ~name ~value t =
55 | let name = Buf_read.(validate "name" token name) in
56 | let value = Buf_read.(validate "value" cookie_value value) in
57 | Map.add name { name_prefix; value } t
58 |
59 | let remove ~name t = Map.remove name t
60 |
--------------------------------------------------------------------------------
/lib_spring/cookie.mli:
--------------------------------------------------------------------------------
1 | (** HTTP Cookie header functionality as specified in
2 | https://datatracker.ietf.org/doc/html/rfc6265#section-4.2
3 |
4 | Additionally, cookie name prefixes - [__Host-] and [__Secure-] are
5 | supported. See
6 | {{!https://httpwg.org/http-extensions/draft-ietf-httpbis-rfc6265bis.html#name-cookie-name-prefixes-2}
7 | Cookie Name Prefixes}.
8 |
9 | The cookie-name-prefix decoding is case-sensitive. *)
10 |
11 | type t
12 | (** [t] represents a collection of HTTP cookies. [t] holds one or more values
13 | indexed via a case-sensitive cookie name. *)
14 |
15 | val decode : string -> t
16 | (** [decode s] decodes [s] into [t].
17 |
18 | {b Note} Cookie name prefix is decoded case-sensitively. *)
19 |
20 | val encode : t -> string
21 | (** [encode t] encodes [t] into a string representation. *)
22 |
23 | val empty : t
24 | (** [empty] is an HTTP Cookie header with zero cookie pair (name, value) *)
25 |
26 | val is_empty : t -> bool
27 | (** [is_empty t] is [true] iff [t] doesn't contain any cookie. *)
28 |
29 | val name_prefix : string -> t -> Cookie_name_prefix.t option
30 | (** [name_prefix name t] is [Some prefix] if cookie with name [name] exists in
31 | [t] and the cookie has a name prefix. It is [None] otherwise.
32 |
33 | See
34 | {{!https://httpwg.org/http-extensions/draft-ietf-httpbis-rfc6265bis.html#name-cookie-name-prefixes-2}
35 | Cookie Name Prefixes}. *)
36 |
37 | val find_opt : string -> t -> string option
38 | (** [find_opt cookie_name t] is [Some v] if [cookie_name] exists in [t]. It is
39 | [None] otherwise. *)
40 |
41 | val add :
42 | ?name_prefix:Cookie_name_prefix.t -> name:string -> value:string -> t -> t
43 | (** [add ~name ~value t] adds a cookie [name] and [value] pair to [t].
44 |
45 | @raise Invalid_arg if [name] or [value] parameter is invalid. *)
46 |
47 | val remove : name:string -> t -> t
48 | (** [remove ~name t] is [t] with cookie [name] removed from [t]. *)
49 |
--------------------------------------------------------------------------------
/lib_spring/cookie_name_prefix.ml:
--------------------------------------------------------------------------------
1 | type t = string * string
2 |
3 | let host = ("__Host-", "__host-")
4 |
5 | let host_len = String.length @@ fst host
6 |
7 | let secure = ("__Secure-", "__secure-")
8 |
9 | let secure_len = String.length @@ fst secure
10 |
11 | let contains_prefix ?(case_sensitive = true) name (t, t_lowercase) =
12 | let name', t' =
13 | if case_sensitive then (name, t)
14 | else (String.Ascii.lowercase name, t_lowercase)
15 | in
16 | String.is_prefix ~affix:t' name'
17 |
18 | let cut_prefix ?case_sensitive name =
19 | let name', t' =
20 | if contains_prefix ?case_sensitive name host then
21 | (String.with_range ~first:host_len name, Some host)
22 | else if contains_prefix ?case_sensitive name secure then
23 | (String.with_range ~first:secure_len name, Some secure)
24 | else (name, None)
25 | in
26 | (name', t')
27 |
28 | let to_string (t, _) = t
29 |
30 | let compare (t0, _) (t1, _) = String.compare t0 t1
31 |
32 | let equal (t0, _) (t1, _) = String.equal t0 t1
33 |
34 | let pp fmt (t, _) = Format.fprintf fmt "%s" t
35 |
--------------------------------------------------------------------------------
/lib_spring/cookie_name_prefix.mli:
--------------------------------------------------------------------------------
1 | (** [Cookie_name_prefix] is the cookie name prefix - [__Host-] or [__Secure-].
2 |
3 | See
4 | {{!https://httpwg.org/http-extensions/draft-ietf-httpbis-rfc6265bis.html#name-cookie-name-prefixes}
5 | Cookie Name Prefix}. *)
6 |
7 | type t
8 | (** [t] is the Cookie name prefix value. It can be either [__Host-] or
9 | [__Secure-] prefix. *)
10 |
11 | val host : t
12 | (** [host] is the [__Host-] cookie name prefix.*)
13 |
14 | val secure : t
15 | (** [secure] is the [__Secure-] cookie name prefix.*)
16 |
17 | val contains_prefix : ?case_sensitive:bool -> string -> t -> bool
18 | (** [contains_prefix name t] is [true] if cookie name [name] starts with the
19 | prefix value [t].
20 |
21 | @param case_sensitive
22 | if [true] then the prefix matching is case-sensitive. Default is [true]. *)
23 |
24 | val cut_prefix : ?case_sensitive:bool -> string -> string * t option
25 | (** [cut_prefix ?case_sensitive name] is [name', Some t] if [name] starts with
26 | one of {!val:host} or {!val:secure} prefix. [name'] is the cookie name after
27 | removing the matched cookie name prefix from [name]. [Some t] is the matched
28 | cookie name prefix.
29 |
30 | If [name] doesn't contain either of the two prefixes, then it is
31 | [name, None] .i.e. [name] is unchanged. *)
32 |
33 | val to_string : t -> string
34 | (** [to_string t] is the string representation of [t]. *)
35 |
36 | val compare : t -> t -> int
37 | (** [compare t0 t1] orders [t0] and [t1]. The comparison is case-sensitive. *)
38 |
39 | val equal : t -> t -> bool
40 | (** [equal t0 t1] is [true] iff [t0] and [t1] are equal. *)
41 |
42 | val pp : Format.formatter -> t -> unit
43 | (** [pp fmt t] pretty prints [t] onto [fmt]. *)
44 |
--------------------------------------------------------------------------------
/lib_spring/csrf.ml:
--------------------------------------------------------------------------------
1 | type token = string
2 |
3 | type key = string
4 |
5 | type request = Request.server Request.t
6 |
7 | type response = Response.server Response.t
8 |
9 | type codec =
10 | { token_name : string
11 | ; encode : token -> string
12 | ; decode : request -> token option
13 | }
14 |
15 | let form_codec ?(token_name = "__csrf_token__") key =
16 | let encode tok =
17 | let nonce = Mirage_crypto_rng.generate Secret.nonce_size in
18 | Secret.encrypt_base64 nonce key tok
19 | in
20 | let decode (req : request) =
21 | let open Option.Syntax in
22 | let headers = Request.headers req in
23 | let* ct = Headers.(find_opt content_type headers) in
24 | let* tok =
25 | match (Content_type.media_type ct :> string * string) with
26 | | "application", "x-www-form-urlencoded" ->
27 | Request.readable req
28 | |> Body.read_form_values
29 | |> List.assoc_opt token_name
30 | | "multipart", "formdata" ->
31 | let rdr = Request.readable req |> Multipart.stream in
32 | (* Note: anticsrf field must be the first field in multipart/formdata form. *)
33 | let anticsrf_part = Multipart.next_part rdr in
34 | let anticsrf_field = Multipart.form_name anticsrf_part in
35 | if String.equal anticsrf_field token_name then
36 | Some (Multipart.read_all anticsrf_part)
37 | else None
38 | | _ -> None
39 | in
40 | Secret.decrypt_base64 key tok |> Option.some
41 | in
42 | { token_name; encode; decode }
43 |
44 | let token_name (c : codec) = c.token_name
45 |
46 | let token (req : request) (c : codec) =
47 | Request.find_session_data c.token_name req
48 |
49 | let enable_protection (req : request) (c : codec) =
50 | match Request.find_session_data c.token_name req with
51 | | Some _ -> ()
52 | | None ->
53 | let tok = Mirage_crypto_rng.generate 32 |> Cstruct.to_string in
54 | Request.add_session_data ~name:c.token_name ~value:tok req
55 |
56 | let encode_token tok (c : codec) = c.encode tok
57 |
58 | exception Csrf_protection_not_enabled
59 |
60 | let form_field (req : request) (c : codec) (b : Buffer.t) =
61 | let tok =
62 | match token req c with
63 | | Some tok -> encode_token tok c
64 | | None -> raise Csrf_protection_not_enabled
65 | in
66 | let input =
67 | Printf.sprintf ""
68 | c.token_name tok
69 | in
70 | Buffer.add_string b input
71 |
72 | let protect_request
73 | ?(on_fail = fun () -> Response.bad_request)
74 | (c : codec)
75 | (req : request)
76 | f =
77 | let open Option.Syntax in
78 | match
79 | let* csrf_session_tok = token req c in
80 | let+ csrf_tok = c.decode req in
81 | (csrf_session_tok, csrf_tok)
82 | with
83 | | Some (tok1, tok2) when String.equal tok1 tok2 -> f req
84 | | _ -> on_fail ()
85 |
--------------------------------------------------------------------------------
/lib_spring/csrf.mli:
--------------------------------------------------------------------------------
1 | (** [Csrf] implements CSRF protection mechanism employing the
2 | {b Synchronizer Token Pattern}.
3 |
4 | {b Usage}
5 |
6 | + When a user requests a HTML form - perhpas as GET request - ensure you
7 | call {!val:enable_protection}. Use {!form_field} to CSRF protect a HTTP
8 | form submission. Use {!encode_token} with {!token} to CSRF protect request
9 | in other contexts.
10 |
11 | + When a use submits a HTTP request that needs to be protected from CSRF -
12 | possibly in a POST request - use {!protect_request}.
13 |
14 | {b References}
15 |
16 | - {{:https://cheatsheetseries.owasp.org/cheatsheets/Cross-Site_Request_Forgery_Prevention_Cheat_Sheet.html#synchronizer-token-pattern}
17 | "Synchronizer Token Pattern"} *)
18 |
19 | type token = private string
20 | (** [token] is a 32 bytes long randomly generated value. *)
21 |
22 | type key = string
23 | (** [key] is an alias for 32 bytes long randomly generated string. *)
24 |
25 | type request = Request.server Request.t
26 |
27 | type response = Response.server Response.t
28 |
29 | type codec
30 | (** [codec] encapsulates decoding CSRF token from request. *)
31 |
32 | (** {1 Codec Creation} *)
33 |
34 | val form_codec : ?token_name:string -> key -> codec
35 | (** [form_codec key] is [t] where [t] implements CSRF token decoding
36 | functionality from request forms. The [Content-Type] of requests must be one
37 | of [application/x-www-form-urlencoded] or [multipart/formdata].
38 |
39 | If [Content-Type] is [multipart/formdata], then the first defined field in
40 | the form must be the csrf token field.
41 |
42 | [key] is used to decrypt CSRF token.
43 |
44 | @param token_name
45 | is the name of the form field encapsulating the CSRF token. The default
46 | value is [__csrf_token__].
47 |
48 | See {!val:form_field} for using CSRF token in a HTML form. See
49 | {!val:encode_token} for using CSRF token in contexts other than a HTML
50 | form. *)
51 |
52 | (** {1 CSRF Protection} *)
53 |
54 | val token_name : codec -> string
55 | (** [token_name codec] is the name of the CSRF token encoded in HTTP request
56 | artefacts such as session, forms or headers. *)
57 |
58 | val token : request -> codec -> token option
59 | (** [token req t] is [Some tok] where [tok] is the CSRF token encapsulated in
60 | [req]. It is [None] if [req] doesn't hold the CSRF token. *)
61 |
62 | val enable_protection : request -> codec -> unit
63 | (** [enable_protection req t] enables csrf protection for request [req]. It does
64 | this by adding CSRF token to request session if one doesn't already exist. *)
65 |
66 | val encode_token : token -> codec -> string
67 | (** [encode_token tok t] is [tok'] where [tok'] contains a CSRF token that is
68 | encrypted and base64 encoded. [tok'] can be used in HTTP request artefacts
69 | such as headers, body and request path.
70 |
71 | See {!val:form_field} if you require to use [tok'] in a HTML request form
72 | setting. *)
73 |
74 | exception Csrf_protection_not_enabled
75 |
76 | val form_field : request -> codec -> Ohtml.t
77 | (** [form_field req t] is an Ohtml component [v]. [v] contains hidden HTML input
78 | element which encapsulates CSRF token. Use [v] in the context of a HTML
79 | request form.
80 |
81 | {b Note} Guidelines on usage of the component [v]:
82 |
83 | - Ensure {!val:enable_protection} is called before using the component [v].
84 |
85 | - Ensure component [v] is the first defined form field when using it in the
86 | context of a [multipart/formdata] form.
87 |
88 | Example [hello.ohtml] form:
89 |
90 | {[
91 | fun req csrf ->
92 |
96 | ]}
97 | @raise Csrf_protected_not_enabled if CSRF is not enabled for the request. *)
98 |
99 | val protect_request :
100 | ?on_fail:(unit -> response)
101 | -> codec
102 | -> (request as 'a)
103 | -> ('a -> response)
104 | -> response
105 | (** [protect_request t req f] protects request [req] from CSRF.
106 |
107 | [f] is the lambda that is executed as [f req] after [req] passes CSRF
108 | protection mechanism.
109 |
110 | [t] determins the CSRF token decoding functionality from [req].
111 |
112 | @param on_fail
113 | is the lambda that is executed if [req] fails CSRF protection mechanism.
114 | By default the lambda returns a [Bad Request] response. *)
115 |
--------------------------------------------------------------------------------
/lib_spring/date.ml:
--------------------------------------------------------------------------------
1 | type t = Ptime.t
2 |
3 | open Buf_read.Syntax
4 |
5 | let day_name =
6 | let+ dn = Buf_read.take 3 in
7 | match dn with
8 | | "Mon" | "Tue" | "Wed" | "Thu" | "Fri" | "Sat" | "Sun" -> ()
9 | | x -> failwith @@ "day_name : unrecognized day name '" ^ x ^ "'"
10 |
11 | let digit n =
12 | let+ v = Buf_read.take n in
13 | int_of_string v
14 |
15 | let comma = Buf_read.char ','
16 |
17 | let day_l =
18 | let+ day =
19 | Buf_read.take_while (function
20 | | 'a' .. 'z' | 'A' .. 'Z' -> true
21 | | _ -> false)
22 | in
23 | match day with
24 | | "Monday"
25 | | "Tuesday"
26 | | "Wednesday"
27 | | "Thursday"
28 | | "Friday"
29 | | "Saturday"
30 | | "Sunday" -> ()
31 | | _ -> failwith "day_l : expected long day name"
32 |
33 | let month =
34 | let+ m = Buf_read.take 3 in
35 | match m with
36 | | "Jan" -> 1
37 | | "Feb" -> 2
38 | | "Mar" -> 3
39 | | "Apr" -> 4
40 | | "May" -> 5
41 | | "Jun" -> 6
42 | | "Jul" -> 7
43 | | "Aug" -> 8
44 | | "Sep" -> 9
45 | | "Oct" -> 10
46 | | "Nov" -> 11
47 | | "Dec" -> 12
48 | | _ -> failwith "month: expected month"
49 |
50 | let gmt = Buf_read.string "GMT"
51 |
52 | let space = Buf_read.space
53 |
54 | let date1 =
55 | let* d = digit 2 <* space in
56 | let* m = month <* space in
57 | let+ y = digit 4 in
58 | (y, m, d)
59 |
60 | let colon = Buf_read.char ':'
61 |
62 | let time_of_day =
63 | let* hour = digit 2 <* colon in
64 | let* minute = digit 2 <* colon in
65 | let+ second = digit 2 in
66 | (hour, minute, second)
67 |
68 | let fix_date =
69 | let* date1 = day_name *> comma *> space *> date1 <* space in
70 | let+ tod = time_of_day <* space <* gmt in
71 | (date1, tod)
72 |
73 | let dash = Buf_read.char '-'
74 |
75 | let date2 =
76 | let* d = digit 2 <* dash in
77 | let* m = month <* dash in
78 | let+ y = digit 2 in
79 | let y = if y >= 50 then 1900 + y else 2000 + y in
80 | (y, m, d)
81 |
82 | let rfc850_date =
83 | let* date2 = day_l *> comma *> space *> date2 <* space in
84 | let+ tod = time_of_day <* space <* gmt in
85 | (date2, tod)
86 |
87 | let date3 =
88 | let* m = month <* space in
89 | let+ day =
90 | let+ s = Buf_read.take 2 in
91 | let buf =
92 | String.fold_left
93 | (fun buf c ->
94 | match c with
95 | | '0' .. '9' ->
96 | Buffer.add_char buf c;
97 | buf
98 | | ' ' -> buf
99 | | _ -> failwith "Invalid date3 value")
100 | (Buffer.create 2) s
101 | in
102 | int_of_string (Buffer.contents buf)
103 | in
104 | (m, day)
105 |
106 | let asctime_date =
107 | let* m, d = day_name *> space *> date3 <* space in
108 | let* tod = time_of_day <* space in
109 | let+ y = digit 4 in
110 | ((y, m, d), tod)
111 |
112 | let of_ptime ptime = Ptime.truncate ~frac_s:0 ptime
113 |
114 | let of_float_s d = Float.trunc d |> Ptime.of_float_s
115 |
116 | let decode v =
117 | let r () = Buf_read.of_string v in
118 | let date, time =
119 | try fix_date @@ r ()
120 | with _ -> ( try rfc850_date @@ r () with _ -> asctime_date @@ r ())
121 | in
122 | Ptime.of_date_time (date, (time, 0)) |> Option.get
123 |
124 | let encode now =
125 | let (year, mm, dd), ((hh, min, ss), _) = Ptime.to_date_time now in
126 | let weekday = Ptime.weekday now in
127 | let weekday =
128 | match weekday with
129 | | `Mon -> "Mon"
130 | | `Tue -> "Tue"
131 | | `Wed -> "Wed"
132 | | `Thu -> "Thu"
133 | | `Fri -> "Fri"
134 | | `Sat -> "Sat"
135 | | `Sun -> "Sun"
136 | in
137 | let month =
138 | match mm with
139 | | 1 -> "Jan"
140 | | 2 -> "Feb"
141 | | 3 -> "Mar"
142 | | 4 -> "Apr"
143 | | 5 -> "May"
144 | | 6 -> "Jun"
145 | | 7 -> "Jul"
146 | | 8 -> "Aug"
147 | | 9 -> "Sep"
148 | | 10 -> "Oct"
149 | | 11 -> "Nov"
150 | | 12 -> "Dec"
151 | | _ -> failwith "Invalid HTTP datetime value"
152 | in
153 | Format.sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT" weekday dd month year hh
154 | min ss
155 |
156 | let now (clock : #Eio.Time.clock) =
157 | let now = Eio.Time.now clock in
158 | of_float_s now |> Option.get
159 |
160 | let compare = Ptime.compare
161 |
162 | let equal = Ptime.equal
163 |
164 | let is_later = Ptime.is_later
165 |
166 | let is_earlier = Ptime.is_earlier
167 |
168 | let pp fmt t = Format.fprintf fmt "%s" @@ encode t
169 |
--------------------------------------------------------------------------------
/lib_spring/date.mli:
--------------------------------------------------------------------------------
1 | (** [Date] implements HTTP Date specification as specified in
2 | https://httpwg.org/specs/rfc9110.html#rfc.section.5.6.7.
3 |
4 | Specifically it supports the following date formats
5 |
6 | - IMF fixdate - [Sun, 06 Nov 1994 08:49:37 GMT]
7 | - obsolete RFC 850 format - [Sunday, 06-Nov-94 08:49:37 GMT]
8 | - ANSI C's asctime() format - [Sun Nov 6 08:49:37 1994]
9 |
10 | {b IMF fixdate is the recommended date format.}
11 |
12 | For RFC 850 if the year value is [>= 50] then the century value of the year
13 | is [19] else it is [20]. *)
14 |
15 | type t
16 |
17 | val of_ptime : Ptime.t -> t
18 | (** [of_ptime ptime] is HTTP timestamp created using date/time values in
19 | [ptime].
20 |
21 | {b Note} Decimal fractional seconds in [ptime] are truncated since HTTP
22 | timestamp doesn't represent time beyond the seconds. *)
23 |
24 | val of_float_s : float -> t option
25 | (** [of_float_s d] is the HTTP timestamp [t] created using date/time values in
26 | [d].
27 |
28 | [d] is floating point seconds since 00:00:00 GMT, Jan. 1, 1970. It is
29 | compatible with {!val:Unix.gettimeofday} value.
30 |
31 | [t] is [None] if [d] is not within valid HTTP timestamp range.
32 |
33 | {b Note} Decimal fractional seconds in [ptime] are truncated since HTTP
34 | timestamp doesn't represent time beyond the seconds. *)
35 |
36 | val decode : string -> t
37 | (** [decode v] decodes [v] into a {!val:Ptime.t} value.
38 |
39 | {[
40 | Date.decode "Sun, 06 Nov 1994 08:49:37 GMT"
41 | ]} *)
42 |
43 | val encode : t -> string
44 | (** [encode date] converts [date] into IMF fixdate format. *)
45 |
46 | val now : #Eio.Time.clock -> t
47 | (** [now clock] is [t] where [t] is the current datetime timestamp. *)
48 |
49 | (** {1 Comparision} *)
50 |
51 | val compare : t -> t -> int
52 | (** [compare a b] is [-1] if [a] is less than [b], [1] if [a] is greater than
53 | [b] and [0] if [a] is equal to [b]. *)
54 |
55 | val equal : t -> t -> bool
56 | (** [equal a b] is [true] if [a] and [b] are the same values. Otherwise it is
57 | [false].
58 |
59 | [equal a b = (compare a b = 0)]. *)
60 |
61 | val is_later : t -> than:t -> bool
62 | (** [is_later t ~than] is [true] iff [compare t than = 1]. *)
63 |
64 | val is_earlier : t -> than:t -> bool
65 | (** [is_earlier t ~than] is [true] iff [compare t than = -1]. *)
66 |
67 | (** {1 Pretty Printing} *)
68 |
69 | val pp : Format.formatter -> t -> unit
70 | (** [pp fmt t] pretty prints [t] onto [fmt]. *)
71 |
--------------------------------------------------------------------------------
/lib_spring/dune:
--------------------------------------------------------------------------------
1 | (library
2 | (name spring)
3 | (public_name spring)
4 | (kind ppx_rewriter)
5 | (preprocess
6 | (pps ppxlib.metaquot))
7 | (libraries
8 | eio
9 | ptime
10 | astring
11 | fmt
12 | domain-name
13 | ppxlib
14 | csexp
15 | ipaddr
16 | base64
17 | fpath
18 | tls
19 | tls-eio
20 | ca-certs
21 | x509
22 | magic-mime
23 | mirage-crypto
24 | mirage-crypto-rng
25 | mirage-crypto-rng-eio))
26 |
--------------------------------------------------------------------------------
/lib_spring/etag.ml:
--------------------------------------------------------------------------------
1 | type etag_chars = string
2 |
3 | type t =
4 | | Weak of etag_chars
5 | | Strong of etag_chars
6 |
7 | let etag_chars buf_read =
8 | Buf_read.take_while
9 | (function
10 | | '\x21' (* ! *)
11 | | '\x23' .. '\x7E' (* VCHAR except DQUOTE *)
12 | | '\x80' .. '\xFF' (* obs-text *) -> true
13 | | _ -> false)
14 | buf_read
15 |
16 | let make ?(weak = false) s =
17 | let buf_read = Buf_read.of_string s in
18 | let s = etag_chars buf_read in
19 | if Buf_read.at_end_of_input buf_read then
20 | match weak with
21 | | true -> Weak s
22 | | false -> Strong s
23 | else invalid_arg @@ "[s] contains invalid ETag value"
24 |
25 | let opaque_tag ~consume buf_read =
26 | let open Buf_read.Syntax in
27 | let tag = (Buf_read.char '"' *> etag_chars <* Buf_read.char '"') buf_read in
28 | match consume with
29 | | `All ->
30 | if Buf_read.at_end_of_input buf_read then tag
31 | else invalid_arg "[v] contains invalid ETag value"
32 | | `Prefix -> tag
33 |
34 | let parse ~consume buf_read =
35 | match Buf_read.peek_char buf_read with
36 | | Some 'W' ->
37 | Buf_read.string "W/" buf_read;
38 | let etag_chars = opaque_tag ~consume buf_read in
39 | Weak etag_chars
40 | | Some '"' -> Strong (opaque_tag ~consume buf_read)
41 | | Some _ | None -> invalid_arg "[v] contains invalid ETag value"
42 |
43 | let decode v =
44 | let buf_read = Buf_read.of_string v in
45 | parse ~consume:`All buf_read
46 |
47 | let chars = function
48 | | Weak v -> v
49 | | Strong v -> v
50 |
51 | let is_weak = function
52 | | Weak _ -> true
53 | | Strong _ -> false
54 |
55 | let is_strong = function
56 | | Weak _ -> false
57 | | Strong _ -> true
58 |
59 | type equal = t -> t -> bool
60 |
61 | let strong_equal a b =
62 | match (a, b) with
63 | | Weak _, _ -> false
64 | | _, Weak _ -> false
65 | | Strong a, Strong b -> String.equal a b
66 |
67 | let weak_equal a b =
68 | match (a, b) with
69 | | Weak a, Weak b -> String.equal a b
70 | | Weak a, Strong b -> String.equal a b
71 | | Strong a, Weak b -> String.equal a b
72 | | Strong a, Strong b -> String.equal a b
73 |
74 | let encode = function
75 | | Weak etag_chars -> "W/\"" ^ etag_chars ^ "\""
76 | | Strong etag_chars -> "\"" ^ etag_chars ^ "\""
77 |
78 | let pp fmt t = Format.fprintf fmt "%s" @@ encode t
79 |
--------------------------------------------------------------------------------
/lib_spring/etag.mli:
--------------------------------------------------------------------------------
1 | (** HTTP ETag header value as specified in
2 | https://www.rfc-editor.org/rfc/rfc9110#field.etag *)
3 |
4 | type t
5 | (** [t] is a valid [ETag] header value. *)
6 |
7 | val make : ?weak:bool -> string -> t
8 | (** [make s] creates [ETag] value [t] from [s]. [s] is validated to ensure only
9 | valid [ETag] characters are present.
10 |
11 | @param weak
12 | if [true] then a weak [ETag] value is created. Default is [false].
13 | @raise Invalid_arg if [s] contains invalid [ETag] characters. *)
14 |
15 | val parse : consume:[ `All | `Prefix ] -> Buf_read.t -> t
16 | (** [parse ~consume buf_read] decodes [t] from [buf_read].
17 |
18 | [consume = `All] denotes that [buf_read] must be fully read when [t] is
19 | decoded.
20 |
21 | [consume = `Prefix] denotes that [buf_read] can contain additional data when
22 | [t] is decoded.
23 |
24 | @raise Invalid_arg
25 | if [consume = `All] and [buf_read] is not at the end of input. *)
26 |
27 | val decode : string -> t
28 | (** [decode v] decodes [v] into an [ETag] header value if [v] conforms to [ETag]
29 | value format. *)
30 |
31 | val chars : t -> string
32 | (** [chars t] is a string representing [ETag] characters in [t]. *)
33 |
34 | val is_weak : t -> bool
35 | (** [is_weak t] is [true] if [t] is a weak [ETag] value. Otherwise it is
36 | [false]. *)
37 |
38 | val is_strong : t -> bool
39 | (** [is_strong t] is [true] if [t] is a strong [ETag] value. Otherwise it is
40 | [false]. *)
41 |
42 | type equal = t -> t -> bool
43 | (** [equal] is an [ETag] comparison function. *)
44 |
45 | val strong_equal : equal
46 | (** [strong_equal a b] applies
47 | {{!https://datatracker.ietf.org/doc/html/rfc7232#section-2.3.2} Strong}
48 | comparison to determine if etag values [a] and [b] are the same. *)
49 |
50 | val weak_equal : equal
51 | (** [weak_equal a b] applies
52 | {{!https://datatracker.ietf.org/doc/html/rfc7232#section-2.3.2} Weak}
53 | comparison to determine if etag values [a] and [b] are the same. *)
54 |
55 | val encode : t -> string
56 | (** [encode t] encodes [t] to a string. *)
57 |
58 | val pp : Format.formatter -> t -> unit
59 | (** [pp fmt t] is pretty prints [t] onto fmt. *)
60 |
--------------------------------------------------------------------------------
/lib_spring/expires.ml:
--------------------------------------------------------------------------------
1 | type t =
2 | | Expired of string
3 | | Date of Date.t
4 |
5 | let of_date d = Date d
6 |
7 | let expired = Expired "0"
8 |
9 | let is_expired = function
10 | | Expired _ -> true
11 | | Date _ -> false
12 |
13 | let equal a b =
14 | match (a, b) with
15 | | Expired _, Expired _ -> true
16 | | Date a, Date b -> Date.equal a b
17 | | _ -> false
18 |
19 | let date = function
20 | | Expired _ -> None
21 | | Date d -> Some d
22 |
23 | let expired_value = function
24 | | Expired v -> Some v
25 | | Date _ -> None
26 |
27 | let decode v =
28 | match Date.decode v with
29 | | d -> Date d
30 | | exception _ -> Expired v
31 |
32 | let encode = function
33 | | Date d -> Date.encode d
34 | | Expired v -> v
35 |
36 | let pp fmt t = Format.fprintf fmt "%s" @@ encode t
37 |
--------------------------------------------------------------------------------
/lib_spring/expires.mli:
--------------------------------------------------------------------------------
1 | (** HTTP [Expires] response header as specified in
2 |
3 | https://www.rfc-editor.org/rfc/rfc9111#field.expires. *)
4 |
5 | type t
6 | (** [t] represents a [Expires] HTTP header value which holds a HTTP Date
7 | timestamp value.
8 |
9 | See {{!https://www.rfc-editor.org/rfc/rfc9110#field.date} HTTP Date
10 | timestamp}. *)
11 |
12 | val of_date : Date.t -> t
13 | (** [of_date d] creates [Expires] header value from HTTP Date timestamp [d]. *)
14 |
15 | val expired : t
16 | (** [expired] represents an invalid HTTP Date timestamp value.
17 |
18 | See {{!https://www.rfc-editor.org/rfc/rfc9111#section-5.3-7} 'expired'
19 | encoding}. *)
20 |
21 | val is_expired : t -> bool
22 | (** [is_expired t] is [true] if [t] is an expired value. [false] otherwise. An
23 | expired value [t] has an invalid HTTP date value. *)
24 |
25 | val equal : t -> t -> bool
26 | (** [equal a b] is [true] if [a] and [b] are equal to each other.
27 |
28 | {b Note:} if [is_expired a = true && is_expired b = true] then
29 | [equal a b = true], i.e. two expired values with two different invalid HTTP
30 | Date.t values are equal. *)
31 |
32 | (** {1 HTTP Date Timestamp} *)
33 |
34 | val date : t -> Date.t option
35 | (** [date t] is [Some date] if [t] holds a valid HTTP date time value. It is
36 | [None] otherwise. *)
37 |
38 | val expired_value : t -> string option
39 | (** [expired_value t] is [Some v] if [is_expired t = true]. Otherwise it is
40 | [None]. *)
41 |
42 | (** {1 Codec} *)
43 |
44 | val decode : string -> t
45 | (** [decode v] decodes string [v] into a valid expires value [t].
46 |
47 | Invalid [v] represents an {!val:expired} value. *)
48 |
49 | val encode : t -> string
50 | (** [encode t] converts [t] into a string representation *)
51 |
52 | (** {1 Pretty Printer} *)
53 |
54 | val pp : Format.formatter -> t -> unit
55 | (** [pp fmt t] pretty prints [t] onto [fmt]. *)
56 |
--------------------------------------------------------------------------------
/lib_spring/file_handler.ml:
--------------------------------------------------------------------------------
1 | (** File Handler - handles requests for files. *)
2 |
3 | let file_last_modified filepath =
4 | Eio.Path.with_open_in filepath @@ fun p -> (Eio.File.stat p).mtime
5 |
6 | let file_last_modified_header_v last_modified =
7 | Float.trunc last_modified |> Date.of_float_s |> Option.get
8 |
9 | let file_etag_header_v last_modified =
10 | Printf.sprintf "%.6f" last_modified
11 | |> Digest.string
12 | |> Digest.to_hex
13 | |> Etag.make
14 |
15 | let serve last_modified' etag' filepath =
16 | let content = Eio.Path.load filepath in
17 | let ct =
18 | Fpath.v @@ snd filepath
19 | |> Fpath.filename
20 | |> Magic_mime.lookup
21 | |> String.cut ~sep:"/"
22 | |> Option.get
23 | |> Content_type.make
24 | in
25 | let cache_control' =
26 | Cache_control.(add private' empty) |> Cache_control.(add must_revalidate)
27 | in
28 | let headers =
29 | Headers.(add last_modified last_modified' empty)
30 | |> Headers.(add etag etag')
31 | |> Headers.(add expires Expires.expired)
32 | |> Headers.(add cache_control cache_control')
33 | in
34 | let body = Body.writable_content ct content in
35 | Response.make_server_response ~headers body
36 |
37 | let file_not_modified_response headers req =
38 | let version = Request.version req in
39 | let status = Status.not_modified in
40 | Response.make_server_response ~version ~status ~headers Body.none
41 |
42 | let if_none f = function
43 | | Some _ as x -> x
44 | | None -> f ()
45 |
46 | let handle_get ~on_error filepath (req : Request.server Request.t) =
47 | let open Option.Syntax in
48 | try
49 | let last_modified_v = file_last_modified filepath in
50 | let last_modified' = file_last_modified_header_v last_modified_v in
51 | let etag' = file_etag_header_v last_modified_v in
52 | let headers = Request.headers req in
53 | match
54 | ((* +-- https://datatracker.ietf.org/doc/html/rfc7232#section-3.2 --+ *)
55 | let* if_none_match = Headers.(find_opt if_none_match headers) in
56 | let etag_matched =
57 | If_none_match.contains_entity_tag
58 | (fun etag -> Etag.weak_equal etag etag')
59 | if_none_match
60 | in
61 | if etag_matched then
62 | let headers = Headers.(add etag etag' empty) in
63 | Some (file_not_modified_response headers req)
64 | else None)
65 | |> if_none @@ fun () ->
66 | let* if_modified_since' =
67 | Headers.(find_opt if_modified_since headers)
68 | in
69 | if Date.is_later last_modified' ~than:if_modified_since' then None
70 | else
71 | let headers = Headers.(add last_modified last_modified' empty) in
72 | Some (file_not_modified_response headers req)
73 | with
74 | | Some res -> res
75 | | None -> serve last_modified' etag' filepath
76 | with
77 | | Eio.Io (Eio.Fs.E (Not_found _), _) -> Response.not_found
78 | | exn -> on_error exn
79 |
--------------------------------------------------------------------------------
/lib_spring/file_handler.mli:
--------------------------------------------------------------------------------
1 | val handle_get :
2 | on_error:(exn -> Response.server Response.t)
3 | -> _ Eio.Path.t
4 | -> Request.server Request.t
5 | -> Response.server Response.t
6 |
--------------------------------------------------------------------------------
/lib_spring/host.ml:
--------------------------------------------------------------------------------
1 | type t = Uri.authority
2 |
3 | let make ?port host = Uri.make_authority ?port host
4 |
5 | let host t = Uri.authority_host t
6 |
7 | let port t = Uri.authority_port t
8 |
9 | let decode s = Uri.authority s
10 |
11 | let encode t =
12 | let port =
13 | match Uri.authority_port t with
14 | | Some p -> ":" ^ string_of_int p
15 | | None -> ""
16 | in
17 | match Uri.authority_host t with
18 | | `IPv6 ip -> Fmt.str "%a%s" Ipaddr.V6.pp ip port
19 | | `IPv4 ip -> Fmt.str "%a%s" Ipaddr.V4.pp ip port
20 | | `Domain_name dn -> Fmt.str "%a%s" Domain_name.pp dn port
21 |
22 | let equal t0 t1 =
23 | let t0, p0 = (host t0, port t0) in
24 | let t1, p1 = (host t1, port t1) in
25 | let host_equal =
26 | match (t0, t1) with
27 | | `IPv6 ip0, `IPv6 ip1 -> Ipaddr.V6.compare ip0 ip1 = 0
28 | | `IPv4 ip0, `IPv4 ip1 -> Ipaddr.V4.compare ip0 ip1 = 0
29 | | `Domain_name dn0, `Domain_name dn1 -> Domain_name.equal dn0 dn1
30 | | _ -> false
31 | in
32 | let port_equal = Option.equal ( = ) p0 p1 in
33 | host_equal && port_equal
34 |
35 | let compare_port p0 p1 = Option.compare Int.compare p0 p1
36 |
37 | let compare t0 t1 =
38 | let t0 = (host t0, port t0) in
39 | let t1 = (host t1, port t1) in
40 | match (t0, t1) with
41 | | (`IPv6 ip0, p0), (`IPv6 ip1, p1) ->
42 | let cmp = Ipaddr.V6.compare ip0 ip1 in
43 | if cmp = 0 then compare_port p0 p1 else cmp
44 | | (`IPv4 ip0, p0), (`IPv4 ip1, p1) ->
45 | let cmp = Ipaddr.V4.compare ip0 ip1 in
46 | if cmp = 0 then compare_port p0 p1 else cmp
47 | | (`Domain_name dn0, p0), (`Domain_name dn1, p1) ->
48 | let cmp = Domain_name.compare dn0 dn1 in
49 | if cmp = 0 then compare_port p0 p1 else cmp
50 | | (`IPv6 _, _), _ -> 1
51 | | (`IPv4 _, _), (`IPv6 _, _) -> -1
52 | | (`Domain_name _, _), (`IPv6 _, _) -> -1
53 | | (`IPv4 _, _), (`Domain_name _, _) -> 1
54 | | (`Domain_name _, _), (`IPv4 _, _) -> -1
55 |
56 | let pp fmt t = Uri.pp_authority fmt t
57 |
--------------------------------------------------------------------------------
/lib_spring/host.mli:
--------------------------------------------------------------------------------
1 | (** HTTP [Host] header.
2 |
3 | See {{!https://www.rfc-editor.org/rfc/rfc9110#name-host-and-authority}
4 | Host}. *)
5 |
6 | type t
7 | (** [t] is the HTTP Host header value. It encapsulates host details of a HTTP
8 | request. *)
9 |
10 | val make : ?port:int -> Uri.host -> t
11 | (** [make host] is [t].
12 |
13 | @param port is the TCP/IP port. Default is [None] *)
14 |
15 | val host : t -> Uri.host
16 | (** [v t] is [host] component of [t]. *)
17 |
18 | val port : t -> Uri.port option
19 | (** [port t] is the [port] component of [t]. *)
20 |
21 | val decode : string -> t
22 | (** [decode s] is [t] if the authority information in [s] can be successfully
23 | parsed into [t]. *)
24 |
25 | val encode : t -> string
26 | (** [encode t] encodes [t] into a string representation. *)
27 |
28 | val equal : t -> t -> bool
29 | (** [equal t0 t1] is [treu] iff [t0] is equal to [t1]. *)
30 |
31 | val compare : t -> t -> int
32 | (** [compare t0 t1] orders [t0] and [t1] such that [compare t0 t1 = 0] is
33 | equivalent to [equal t0 t1 = true]. The ordering follows the host ordering
34 | as follows: [IPv6]. [IPv4] and [Domain_name] *)
35 |
36 | val pp : Format.formatter -> t -> unit
37 | (** [pp fmt t] pretty prints [t] onto [fmt]. *)
38 |
--------------------------------------------------------------------------------
/lib_spring/if_none_match.ml:
--------------------------------------------------------------------------------
1 | type t =
2 | | Any
3 | | Entity_tags of Etag.t list
4 |
5 | let any = Any
6 |
7 | let make = function
8 | | [] -> invalid_arg "[entity_tags] is empty"
9 | | etags -> Entity_tags etags
10 |
11 | let entity_tags = function
12 | | Any -> None
13 | | Entity_tags etags -> Some etags
14 |
15 | let is_any = function
16 | | Any -> true
17 | | Entity_tags (_ : Etag.t list) -> false
18 |
19 | let contains_entity_tag f = function
20 | | Any -> true
21 | | Entity_tags etags -> List.exists f etags
22 |
23 | let decode s =
24 | let buf_read = Buf_read.of_string s in
25 | let parse_etag = Etag.parse ~consume:`Prefix in
26 | let t =
27 | match Buf_read.peek_char buf_read with
28 | | Some '*' ->
29 | Buf_read.char '*' buf_read;
30 | Any
31 | | Some (_ : char) ->
32 | let etags = Buf_read.list1 parse_etag buf_read in
33 | Entity_tags etags
34 | | None -> invalid_arg "[s] contains invalid [If-None-Match] value"
35 | in
36 | if Buf_read.at_end_of_input buf_read then t
37 | else invalid_arg "[s] contains invalid [If-None-Match] value"
38 |
39 | let encode = function
40 | | Any -> "*"
41 | | Entity_tags etags ->
42 | let buf = Buffer.create 10 in
43 | let rec write_etag = function
44 | | [] -> Buffer.contents buf
45 | | etag :: [] ->
46 | Buffer.add_string buf (Etag.encode etag);
47 | Buffer.contents buf
48 | | etag :: etags ->
49 | Buffer.add_string buf (Etag.encode etag);
50 | Buffer.add_string buf ", ";
51 | write_etag etags
52 | in
53 | write_etag etags
54 |
55 | let pp fmt t = Format.fprintf fmt "%s" @@ encode t
56 |
--------------------------------------------------------------------------------
/lib_spring/if_none_match.mli:
--------------------------------------------------------------------------------
1 | (** HTTP [If-None-Match] header as specified in
2 | https://www.rfc-editor.org/rfc/rfc9110#field.if-match *)
3 |
4 | type t
5 | (** [t] is a [If-None-Match] header value. *)
6 |
7 | val any : t
8 | (** [any] is the [*] [If-None-Match] value. *)
9 |
10 | val make : Etag.t list -> t
11 | (** [make entity_tags] creates [If-None-Match] value from a list of Etag values
12 | [entity_tags].
13 |
14 | @raise Invalid_arg if [entity_tags = []]. *)
15 |
16 | val entity_tags : t -> Etag.t list option
17 | (** [entity_tags t] is [Some entity_tags] where [entity_tags] is a list of
18 | entity tags as exists in [t]. It is [None] if [any t = true]. *)
19 |
20 | val is_any : t -> bool
21 | (** [is_any t] is [true] if [t] is an {!val:any} value. Otherwise it is [false]. *)
22 |
23 | val contains_entity_tag : (Etag.t -> bool) -> t -> bool
24 | (** [contains_entity_tag f t] is [b]. [b] is [true] if [f] evaluates to [true]
25 | for at least one of the entity tags in [t]. Otherwise it is [false].
26 |
27 | If [any t = true] then [b] is always [true]. *)
28 |
29 | val decode : string -> t
30 | (** [decode s] decodes raw [If-None-Match] header value [s] into [t]. *)
31 |
32 | val encode : t -> string
33 | (** [encode t] encodes [t] into a raw [If-None-Match] header value. *)
34 |
35 | val pp : Format.formatter -> t -> unit
36 | (** [pp fmt t] pretty prints [t] onto [fmt]. *)
37 |
--------------------------------------------------------------------------------
/lib_spring/method.ml:
--------------------------------------------------------------------------------
1 | (* Why this design? So that method is extendable. For example WebDAV protocol defines extra methods. I want to cater to that scenario as well. *)
2 |
3 | type lowercase_string = string
4 |
5 | type t = lowercase_string
6 |
7 | let make t = String.Ascii.lowercase t
8 |
9 | let get = "get"
10 |
11 | let head = "head"
12 |
13 | let delete = "delete"
14 |
15 | let options = "options"
16 |
17 | let trace = "trace"
18 |
19 | let post = "post"
20 |
21 | let put = "put"
22 |
23 | let patch = "patch"
24 |
25 | let connect = "connect"
26 |
27 | let to_string t = t
28 |
29 | let equal a b = String.equal a b
30 |
31 | let pp fmt t = Format.fprintf fmt "%s" (String.Ascii.uppercase t)
32 |
--------------------------------------------------------------------------------
/lib_spring/method.mli:
--------------------------------------------------------------------------------
1 | (** [Method] implements HTTP request method as specified in
2 | https://httpwg.org/specs/rfc9110.html#methods *)
3 |
4 | type lowercase_string = private string
5 |
6 | type t = lowercase_string
7 | (** [t] represents an instance of HTTP request method. Its textual
8 | representation is an ASCII lowercase string. *)
9 |
10 | val make : string -> t
11 | (** [make meth] creates a HTTP request method [t] represented by [meth]. *)
12 |
13 | (** {1 Methods} *)
14 |
15 | val get : t
16 | (** [get] is HTTP GET method as defined in
17 | https://httpwg.org/specs/rfc9110.html#GET *)
18 |
19 | val head : t
20 | (** [head] is HTTP HEAD method as defined in
21 | https://httpwg.org/specs/rfc9110.html#rfc.section.9.3.2 *)
22 |
23 | val delete : t
24 | (** [delete] is HTTP DELETE method as defined in
25 | https://httpwg.org/specs/rfc9110.html#DELETE *)
26 |
27 | val options : t
28 | (** [options] is HTTP OPTIONS method as defined in
29 | https://httpwg.org/specs/rfc9110.html#OPTIONS *)
30 |
31 | val trace : t
32 | (** [trace] is HTTP TRACE method as defined in
33 | https://httpwg.org/specs/rfc9110.html#rfc.section.9.3.8 *)
34 |
35 | val post : t
36 | (** [post] is HTTP POST method as defined in
37 | https://httpwg.org/specs/rfc9110.html#rfc.section.9.3.3 *)
38 |
39 | val put : t
40 | (** [put] is HTTP PUT method as defined in
41 | https://httpwg.org/specs/rfc9110.html#rfc.section.9.3.4 *)
42 |
43 | val patch : t
44 | (** [patch] is HTTP PATCH method as defined in
45 | https://www.rfc-editor.org/rfc/rfc5789 *)
46 |
47 | val connect : t
48 | (** [connect] is HTTP CONNECT method as defined in
49 | https://httpwg.org/specs/rfc9110.html#CONNECT *)
50 |
51 | (** {1 Pretty Printers} *)
52 |
53 | val to_string : t -> lowercase_string
54 | (** [to_string t] is the textual representation of [t] in ASCII lowercase form. *)
55 |
56 | val equal : t -> t -> bool
57 | (** [equal a b] is [true] if both [a] and [b] represent the same HTTP request
58 | method value. *)
59 |
60 | val pp : Format.formatter -> t -> unit
61 |
--------------------------------------------------------------------------------
/lib_spring/multipart.mli:
--------------------------------------------------------------------------------
1 | (** [Multipart] is HTTP MIME multipart codec as defined in
2 | {{:https://tools.ietf.org/html/rfc7578} RFC 7578}. It is also known more
3 | popularly as forms in web development.
4 |
5 | It supports both {{!section:streaming} Streaming} and {{!section:form}
6 | Non-Streaming} processing of multipart/form data. *)
7 |
8 | (** {1 Part}
9 |
10 | A part is a form field in a form. It encapsulates two data types:
11 |
12 | + {i Value} is a key/value data value where [key] is the form field name.
13 | + {i File} holds data from a file. It has additional attributes such as
14 | headers, and filename in addition to the form field name and actual file
15 | content. *)
16 |
17 | type 'a part
18 | (** [part] is a single part of a multipart request/response body. *)
19 |
20 | val file_name : 'a part -> string option
21 | (** [file_name p] is [Some filename] if part [p] is a file part. Otherwise it is
22 | [None]. *)
23 |
24 | val form_name : 'a part -> string
25 | (** [form_name p] is the form field name of part [p]. *)
26 |
27 | val headers : 'a part -> Headers.t
28 | (** [headers p] is headers associated with part [p]. It is a
29 | {!val:Headers.empty} if part [p] is a form value field. *)
30 |
31 | (** {1:streaming Reading Parts as Streams}
32 |
33 | The streaming api supports processing multipart/form without a complete
34 | in-memory representation of data. *)
35 |
36 | type stream
37 | (** [stream] is a part/form-field stream. It reads parts/form-fields one at a
38 | time. *)
39 |
40 | val stream : Body.readable -> stream
41 | (** [stream body] creates a stream for multipart encoded HTTP request/response
42 | body [body].
43 |
44 | @raise Invalid_argument
45 | if [body] doesn't contain valid MIME [boundary] value in "Content-Type"
46 | header. *)
47 |
48 | val boundary : stream -> string
49 | (** [boundary s] is the Multipart MIME boundary value decoded by [s].
50 |
51 | Boundary value is specified in
52 | https://www.rfc-editor.org/rfc/rfc7578#section-4.1 *)
53 |
54 | val next_part : stream -> stream part
55 | (** [next_part s] is part [p] - the next multipart in stream [s].
56 |
57 | @raise End_of_file if there are no more parts in stream [s].
58 | @raise Failure
59 | if stream [s] encounters any error while parsing the next multipart. *)
60 |
61 | val as_flow : stream part -> Eio.Flow.source
62 | (** [as_flow p] creates an eio {!class:Eio.Flow.source} for content of part [p]. *)
63 |
64 | val read_all : stream part -> string
65 | (** [read_all p] reads content from part [p] until end-of-file. *)
66 |
67 | (** {1:form Reading Parts to a Form} *)
68 |
69 | type form
70 | (** [form] is a parsed, in-memory multipart/formdata representation. *)
71 |
72 | val form : Body.readable -> form
73 | (** [form readable] reads all parts of a multipart encoded [readable] into a
74 | {!type:Form.t}.
75 |
76 | The parts are read into a memory buffer; therefore it may not be an
77 | efficient way to read a multipart [readable] when there are a large number
78 | of parts or if individual parts are large.
79 |
80 | As an alternative memory efficient mechanism to this function, see
81 | {{!section:streaming} Streaming API}. *)
82 |
83 | type value_field = string
84 | (** [value_field] is a string value form field. *)
85 |
86 | type file_field = string part
87 | (** [file_field] is a form field which encapsulates a file content. *)
88 |
89 | val file_content : file_field -> string
90 | (** [file_content ff] is the content of file field [ff]. *)
91 |
92 | val find_value_field : string -> form -> value_field option
93 | (** [find_value_field name] is [Some v] if a form field with name [name] exists
94 | in [t]. Otherwise it is [None]. *)
95 |
96 | val find_file_field : string -> form -> file_field option
97 | (** [find_file_field name] is [Some ff] if a form field of type
98 | {!type:file_field} with name [name] exists in [t]. Otherwise it is [None]. *)
99 |
100 | (** {1:writable Writable Multipart} *)
101 |
102 | type writable
103 | (** [writable] is a part that can be written. *)
104 |
105 | val writable_value_part : form_name:string -> value:string -> writable part
106 | (** [writable_value_part ~form_name ~value] creates a writable part containing
107 | string [value] and a form field name of [form_name]. *)
108 |
109 | val writable_file_part :
110 | ?headers:Headers.t
111 | -> filename:string
112 | -> form_name:string
113 | -> #Eio.Flow.source
114 | -> writable part
115 | (** [writable_file_part ~filename ~form_name body] creates a file form field
116 | writable part. [body] points to a file source. [filename] is the name of the
117 | file pointed to by [body] and [form_name] is the name of the form field.
118 |
119 | @param headers
120 | is a set of HTTP headers for the created part. Default is
121 | {!val:Headers.empty}. *)
122 |
123 | val writable : boundary:string -> writable part list -> Body.writable
124 | (** [writeable ~boundary parts] creates a multipart request/response
125 | {!type:Body.writable} body with the boundary value [boundary].
126 |
127 | [boundary] is precisely defined at
128 | https://datatracker.ietf.org/doc/html/rfc7578#section-4.1 *)
129 |
--------------------------------------------------------------------------------
/lib_spring/ohtml.ml:
--------------------------------------------------------------------------------
1 | type t = Buffer.t -> unit
2 |
3 | (*
4 | HTML Escaping guidance -
5 | https://cheatsheetseries.owasp.org/cheatsheets/Cross_Site_Scripting_Prevention_Cheat_Sheet.html
6 | *)
7 |
8 | let escape_html txt =
9 | let escaped = Buffer.create 10 in
10 | String.iter
11 | (function
12 | | '&' -> Buffer.add_string escaped "&"
13 | | '<' -> Buffer.add_string escaped "<"
14 | | '>' -> Buffer.add_string escaped ">"
15 | | c -> Buffer.add_char escaped c)
16 | txt;
17 | Buffer.contents escaped
18 |
19 | let escape_attr attr_val =
20 | let escaped = Buffer.create 10 in
21 | String.iter
22 | (function
23 | | '"' -> Buffer.add_string escaped """
24 | | '\'' -> Buffer.add_string escaped "'"
25 | | c -> Buffer.add_char escaped c)
26 | attr_val;
27 | Buffer.contents escaped
28 |
29 | type attribute =
30 | | Name_val of
31 | { name : string
32 | ; value : string
33 | }
34 | | Bool of string
35 | | Null
36 |
37 | let attribute ~name ~value = Name_val { name; value }
38 |
39 | let bool name = Bool name
40 |
41 | let null = Null
42 |
43 | let write_attribute attr : t =
44 | fun b ->
45 | match attr with
46 | | Name_val { name; value } ->
47 | Buffer.add_string b (escape_attr name);
48 | Buffer.add_string b {|="|};
49 | Buffer.add_string b (escape_attr value);
50 | Buffer.add_string b {|"|}
51 | | Bool name -> Buffer.add_string b (escape_attr name)
52 | | Null -> ()
53 |
--------------------------------------------------------------------------------
/lib_spring/ohtml.mli:
--------------------------------------------------------------------------------
1 | (** [Ohtml] is a module that can be used together with [.ohtml] view template
2 | files. *)
3 |
4 | type t = Buffer.t -> unit
5 | (** [t] represents an Ohtml view. This is usually a generated by [ohtml.exe]
6 | tool. *)
7 |
8 | val escape_html : string -> string
9 | (** [escape_html s] is a XSS attack safe version of HTML text value [s]. *)
10 |
11 | val escape_attr : string -> string
12 | (** [escape_attr s] is a XSS attack safe version of HTML attribute value [s]. *)
13 |
14 | (** {1 Attribute} *)
15 |
16 | type attribute
17 |
18 | val attribute : name:string -> value:string -> attribute
19 | (** [attribute ~name ~value] is a html attribute with [name] and [value]. *)
20 |
21 | val bool : string -> attribute
22 | (** [bool name] is a [name] only attribute, eg. disabled. *)
23 |
24 | val null : attribute
25 | (** [null_attribute] is a no-op attribute. It outpus nothing. This is
26 | particularly useful in use-cases where one wants to control the generation
27 | of HTML node attribute based on some condition. For eg.
28 | [(if cond then Ohtml.attribute ~name ~value else Ohtml.null)] *)
29 |
30 | val write_attribute : attribute -> t
31 |
--------------------------------------------------------------------------------
/lib_spring/option.ml:
--------------------------------------------------------------------------------
1 | include Stdlib.Option
2 |
3 | module Syntax = struct
4 | let ( let* ) o f = bind o f
5 |
6 | let ( let+ ) o f = map f o
7 | end
8 |
--------------------------------------------------------------------------------
/lib_spring/request.mli:
--------------------------------------------------------------------------------
1 | (** HTTP Request. *)
2 |
3 | type 'a t
4 | (** [t] is a HTTP request that represents both client and server request. *)
5 |
6 | (** {1 Common Request Details} *)
7 |
8 | type resource = string
9 | (** [resource] is the request uri with path and query components. *)
10 |
11 | val meth : _ t -> Method.t
12 |
13 | val resource : _ t -> resource
14 |
15 | val version : _ t -> Version.t
16 |
17 | val headers : _ t -> Headers.t
18 |
19 | val supports_chunked_trailers : _ t -> bool
20 | (** [supports_chunked_trailers t] is [true] if request [t] has header "TE:
21 | trailers". It is [false] otherwise. *)
22 |
23 | val keep_alive : _ t -> bool
24 | (** [keep_alive t] is [true] if [t] has header "Connection: keep-alive" or if
25 | "Connection" header is missing and the HTTP version is 1.1. It is [false] if
26 | header "Connection: close" exists. *)
27 |
28 | val find_cookie : string -> _ t -> string option
29 | (** [find_cookie cookie_name t] is [Some cookie_value] if a Cookie with name
30 | [cookie_name] exists in [t]. Otherwise is [None]. *)
31 |
32 | val pp : Format.formatter -> _ t -> unit
33 | (** [pp fmt t] pretty prints [t] onto [fmt]. *)
34 |
35 | (** {1 Client Request}
36 |
37 | A HTTP client request. This is primarily constructed and used by
38 | {!module:Client}. *)
39 |
40 | type client
41 | (** [client] a HTTP client request. *)
42 |
43 | val make_client_request :
44 | ?scheme:Uri.scheme
45 | -> ?version:Version.t
46 | -> ?headers:Headers.t
47 | -> resource:resource
48 | -> Host.t
49 | -> Method.t
50 | -> Body.writable
51 | -> client t
52 | (** [make ~host ~resource meth body] is [t] representing a client request with
53 | request url [resource]. [host] represents a HTTP server that will process
54 | [t]. [meth] is the HTTP request method. [body] is the request body.
55 |
56 | @param scheme is the HTTP request [t] connection scheme. Default is [`Http].
57 | @param version HTTP version of [t]. Default is [1.1].
58 | @param headers HTTP request headers of [t]. Default is [Headers.empty] . *)
59 |
60 | val scheme : client t -> Uri.scheme
61 | (** [scheme req] is the HTTP request [req] connection scheme. *)
62 |
63 | val host : client t -> Uri.host
64 | (** [host t] is the server host name which handles the request [t]. *)
65 |
66 | val port : client t -> Uri.port option
67 | (** [port t] is [Some p] if a port component exists in [Host] header in [t]. It
68 | is [None] otherwise. *)
69 |
70 | val add_cookie : name:string -> value:string -> client t -> client t
71 | (** [add_cookie ~name ~value t] is [t] with cookie pair [name,value] added to
72 | [t]. *)
73 |
74 | val remove_cookie : string -> client t -> client t
75 | (** [remove_cookie name t] is [t] with cookie pair with name [name] removed from
76 | [t]. *)
77 |
78 | val write_client_request : client t -> Eio.Buf_write.t -> unit
79 | (** [write t buf_write] writes [t] to [buf_write]. *)
80 |
81 | (** {1 Server Request}
82 |
83 | [Server.t] is a HTTP request that is primarily constructed and used in
84 | {!module:Server}. *)
85 |
86 | type server
87 | (** [server] a HTTP server request. *)
88 |
89 | val make_server_request :
90 | ?version:Version.t
91 | -> ?headers:Headers.t
92 | -> ?session_data:Session.session_data
93 | -> resource:resource
94 | -> Method.t
95 | -> Eio.Net.Sockaddr.stream
96 | -> Eio.Buf_read.t
97 | -> server t
98 | (** [make_server_request meth client_addr buf_read] is HTTP request [t].
99 |
100 | @param version HTTP version of [t]. Default is [1.1].
101 | @param headers HTTP request headers of [t]. Default is [Headers.empty] .
102 | @param session_data is the Session data for the request. Default is [None].
103 |
104 | @raise Invalid_argument if [resource] is an empty string. *)
105 |
106 | val client_addr : server t -> Eio.Net.Sockaddr.stream
107 | (** [client_addr t] is the client socket *)
108 |
109 | val session_data : server t -> Session.session_data option
110 | (** [session_data t] is [Some v] if [t] is initialized with session data. *)
111 |
112 | val add_session_data : name:string -> value:string -> server t -> unit
113 | (** [add_session_data ~name ~value t] adds session value [value] with name
114 | [name] to [t]. If session data with [name] already exists in [t], then the
115 | old value is replaced with [value].
116 |
117 | {b Note} This function is not thread-safe as it mutates [t], so ensure this
118 | function is called in a thread-safe manner if the same request instance [t]
119 | is being shared across OCaml domains or sys-threads. *)
120 |
121 | val replace_session_data : Session.session_data -> server t -> unit
122 | (** [replace_context_session_data session_data t] is [t] with session data in
123 | [t] replaced by [session_data]. After this operation
124 | [session_data t = Some session_data]. *)
125 |
126 | val find_session_data : string -> server t -> string option
127 | (** [find_session_data name t] is [Some v] is session data with name [name]
128 | exists in [t]. Otherwise it is [None]. *)
129 |
130 | (** {2 Reading Body} *)
131 |
132 | val readable : server t -> Body.readable
133 | (** [readable t] converts [t] to {!type:Body.readable}.
134 |
135 | See {{!section:Body.readers} Readers}. *)
136 |
137 | val buf_read : server t -> Eio.Buf_read.t
138 | (** [buf_read t] is an eio bufferred reader associated with server request [t]. *)
139 |
140 | val parse_server_request :
141 | ?session:Session.codec
142 | -> Eio.Net.Sockaddr.stream
143 | -> Eio.Buf_read.t
144 | -> server t
145 | (** [parse client_addr buf_read] parses a server request [r] given a buffered
146 | reader [buf_read]. *)
147 |
--------------------------------------------------------------------------------
/lib_spring/response.ml:
--------------------------------------------------------------------------------
1 | type 'a t =
2 | { version : Version.t
3 | ; status : Status.t
4 | ; headers : Headers.t
5 | ; x : 'a
6 | }
7 |
8 | let version t = t.version
9 |
10 | let status t = t.status
11 |
12 | let headers t = t.headers
13 |
14 | let find_set_cookie_ name headers =
15 | Headers.(find_all set_cookie headers)
16 | |> List.find_opt (fun sc -> String.equal name @@ Set_cookie.name sc)
17 |
18 | let find_set_cookie name t = find_set_cookie_ name t.headers
19 |
20 | let pp fmt t =
21 | let fields =
22 | Fmt.(
23 | record ~sep:semi
24 | [ Fmt.field "Version" (fun t -> t.version) Version.pp
25 | ; Fmt.field "Status" (fun t -> t.status) Status.pp
26 | ; Fmt.field "Headers" (fun t -> t.headers) Headers.pp
27 | ])
28 | in
29 | let open_bracket =
30 | Fmt.(vbox ~indent:2 @@ (const char '{' ++ cut ++ fields))
31 | in
32 | Fmt.(vbox @@ (open_bracket ++ cut ++ const char '}')) fmt t
33 |
34 | type client =
35 | { buf_read : Eio.Buf_read.t
36 | ; mutable closed : bool
37 | }
38 |
39 | let make_client_response
40 | ?(version = Version.http1_1)
41 | ?(status = Status.ok)
42 | ?(headers = Headers.empty)
43 | buf_read =
44 | let client = { buf_read; closed = false } in
45 | { version; status; headers; x = client }
46 |
47 | open Buf_read.Syntax
48 |
49 | (* https://datatracker.ietf.org/doc/html/rfc7230#section-3.1.2 *)
50 | let is_digit = function
51 | | '0' .. '9' -> true
52 | | _ -> false
53 |
54 | let reason_phrase =
55 | Buf_read.take_while (function
56 | | '\x21' .. '\x7E' | '\t' | ' ' -> true
57 | | _ -> false)
58 |
59 | let p_status =
60 | let* status = Buf_read.take_while1 is_digit in
61 | let+ phrase = Buf_read.space *> reason_phrase in
62 | Status.make (int_of_string status) phrase
63 |
64 | let parse_client_response buf_read =
65 | let version = (Version.parse <* Buf_read.space) buf_read in
66 | let status = Buf_read.(p_status <* crlf) buf_read in
67 | let headers = Headers.parse buf_read in
68 | let client = { buf_read; closed = false } in
69 | { version; headers; status; x = client }
70 |
71 | exception Closed
72 |
73 | let closed t = t.x.closed
74 |
75 | let close t = t.x.closed <- true
76 |
77 | let readable t = Body.make_readable t.headers t.x.buf_read
78 |
79 | let buf_read t = if t.x.closed then raise Closed else t.x.buf_read
80 |
81 | (* Server Response *)
82 |
83 | type server = Body.writable
84 |
85 | let make_server_response
86 | ?(version = Version.http1_1)
87 | ?(status = Status.ok)
88 | ?(headers = Headers.empty)
89 | body =
90 | { version; status; headers; x = body }
91 |
92 | let body t = t.x
93 |
94 | let add_set_cookie v t =
95 | let headers = Headers.(add set_cookie v t.headers) in
96 | { t with headers }
97 |
98 | let remove_set_cookie name t =
99 | let[@tail_mod_cons] rec aux = function
100 | | [] -> []
101 | | ((hdr_name, v) as x) :: tl ->
102 | let nm =
103 | Headers.(Definition.name set_cookie |> Definition.lname_of_name)
104 | in
105 | if
106 | Headers.Definition.lname_equal hdr_name nm
107 | && (String.equal name @@ Set_cookie.(decode v |> name))
108 | then tl
109 | else x :: aux tl
110 | in
111 | let headers = aux (Headers.to_list t.headers) in
112 | let headers = Headers.of_list (headers :> (string * string) list) in
113 | { t with headers }
114 |
115 | let text content =
116 | let content_type =
117 | Content_type.make ~params:[ ("charset", "uf-8") ] ("text", "plain")
118 | in
119 | let body = Body.writable_content content_type content in
120 | make_server_response body
121 |
122 | let html content =
123 | let content_type =
124 | Content_type.make ~params:[ ("charset", "uf-8") ] ("text", "html")
125 | in
126 | let body = Body.writable_content content_type content in
127 | make_server_response body
128 |
129 | let ohtml o =
130 | let buf = Buffer.create 10 in
131 | o buf;
132 | let content = Buffer.contents buf in
133 | html content
134 |
135 | let chunked_response ~ua_supports_trailer write_chunk write_trailer =
136 | Chunked.writable ~ua_supports_trailer write_chunk write_trailer
137 | |> make_server_response
138 |
139 | let none_body_response status =
140 | let headers = Headers.singleton ~name:"Content-Length" ~value:"0" in
141 | make_server_response ~headers ~status Body.none
142 |
143 | let not_found = none_body_response Status.not_found
144 |
145 | let internal_server_error = none_body_response Status.internal_server_error
146 |
147 | let bad_request = none_body_response Status.bad_request
148 |
149 | let write_server_response w (t : server t) =
150 | let version = Version.to_string t.version in
151 | let status = Status.to_string t.status in
152 | Eio.Buf_write.string w version;
153 | Eio.Buf_write.char w ' ';
154 | Eio.Buf_write.string w status;
155 | Eio.Buf_write.string w "\r\n";
156 | Body.write_headers w t.x;
157 | Headers.write w t.headers;
158 | Eio.Buf_write.string w "\r\n";
159 | Body.write_body w t.x
160 |
--------------------------------------------------------------------------------
/lib_spring/response.mli:
--------------------------------------------------------------------------------
1 | (** [Request] provides types and function to manipulate HTTP Responses. *)
2 |
3 | type 'a t
4 | (** [t] is a HTTP response. *)
5 |
6 | (** {1 Common Response Details} *)
7 |
8 | val version : _ t -> Version.t
9 |
10 | val status : _ t -> Status.t
11 |
12 | val headers : _ t -> Headers.t
13 |
14 | val find_set_cookie : string -> _ t -> Set_cookie.t option
15 | (** [find_set_cookie name t] is [Some v] if HTTP [Set-Cookie] header with name
16 | [name] exists in [t]. It is [None] otherwise. *)
17 |
18 | val pp : Format.formatter -> _ t -> unit
19 | (** [pp fmt t] pretty prints [t] onto [fmt]. *)
20 |
21 | (** {1 Client Response} *)
22 |
23 | type client
24 | (** [client] a HTTP client response. *)
25 |
26 | val make_client_response :
27 | ?version:Version.t
28 | -> ?status:Status.t
29 | -> ?headers:Headers.t
30 | -> Eio.Buf_read.t
31 | -> client t
32 |
33 | val parse_client_response : Eio.Buf_read.t -> client t
34 | (** [parse_client_response buf_read] parses [buf_read] and create HTTP reponse
35 | [t]. *)
36 |
37 | exception Closed
38 |
39 | val closed : client t -> bool
40 | (** [closed response] is [true] if [response] is closed. [false] otherwise. *)
41 |
42 | val close : client t -> unit
43 | (** [close response] closes the response body of [response]. Once the [response]
44 | body is closed subsequent calls to read the [response] body will result in
45 | raising {!exception:Closed}. *)
46 |
47 | (** {2 Reading Body} *)
48 |
49 | val readable : client t -> Body.readable
50 | (** [readable t] converts [t] to {!type:Body.readable}.
51 |
52 | See {{!section:Body.readers} Readers}. *)
53 |
54 | val buf_read : client t -> Eio.Buf_read.t
55 | (** [buf_read t] is buffered reader associated with [t].
56 |
57 | @raise Closed if [t] is already closed. *)
58 |
59 | (** {1 Server Response} *)
60 |
61 | type server
62 | (** [server] a HTTP server response. *)
63 |
64 | val make_server_response :
65 | ?version:Version.t
66 | -> ?status:Status.t
67 | -> ?headers:Headers.t
68 | -> Body.writable
69 | -> server t
70 |
71 | val body : server t -> Body.writable
72 | (** [body t] is a response body associated with [t]. *)
73 |
74 | val add_set_cookie : Set_cookie.t -> server t -> server t
75 | (** [add_set_cookie set_cookie t] is [t] with HTTP [Set-Cookie] header
76 | [set_cookie] added to it. *)
77 |
78 | val remove_set_cookie : string -> server t -> server t
79 | (** [remove_set_cookie name t] is [t] after removing HTTP [Set-Cookie] header
80 | with name [name] from [t]. *)
81 |
82 | val text : string -> server t
83 | (** [text s] returns a HTTP/1.1, 200 status response with "Content-Type" header
84 | set to "text/plain" and "Content-Length" header set to a suitable value. *)
85 |
86 | val html : string -> server t
87 | (** [html t s] returns a HTTP/1.1, 200 status response with header set to
88 | "Content-Type: text/html" and "Content-Length" header set to a suitable
89 | value. *)
90 |
91 | val ohtml : Ohtml.t -> server t
92 | (** [ohtml view] is an Ohtml [view] based HTTP 200 server response. Its
93 | [Content-Type] header is set to [text/html]. *)
94 |
95 | val chunked_response :
96 | ua_supports_trailer:bool
97 | -> Chunked.write_chunk
98 | -> Chunked.write_trailer
99 | -> server t
100 | (** [chunked_response ~ua_supports_trailer write_chunk write_trailer] is a HTTP
101 | chunked response.
102 |
103 | See {!module:Chunked_body}. *)
104 |
105 | val not_found : server t
106 | (** [not_found] returns a HTTP/1.1, 404 status response. *)
107 |
108 | val internal_server_error : server t
109 | (** [internal_server_error] returns a HTTP/1.1, 500 status response. *)
110 |
111 | val bad_request : server t
112 | (* [bad_request] returns a HTTP/1.1, 400 status response. *)
113 |
114 | val write_server_response : Eio.Buf_write.t -> server t -> unit
115 | (** [write_server_response t buf_write] writes server response [t] using
116 | [buf_write]. *)
117 |
--------------------------------------------------------------------------------
/lib_spring/route_ppx.mli:
--------------------------------------------------------------------------------
1 | (** Routes ppx provides a ppx mehcanism to specify request routes for
2 | {!val:Router.t}.
3 |
4 | Routes can be specified as follows:
5 |
6 | + [[%r "route-syntax" ]] or
7 | + [{%r| route-syntax |}] - {i since OCaml 4.11.0}
8 |
9 | where [route-syntax] is a string which follows the grammar specified in
10 | {{!section:syntax} %r Syntax}.
11 |
12 | {2 Demo}
13 |
14 | {[
15 | let ppx_routers =
16 | [ {%r| /home/about/ |} about_page
17 | ; {%r| /home/:int/ |} prod_page
18 | ; {%r| /home/:float/ |} float_page
19 | ; {%r| /contact/*/:int |} contact_page
20 | ; {%r| /product/:string?section=:int&q=:bool |} product1
21 | ; {%r| /product/:string?section=:int&q1=yes |} product2
22 | ; {%r| /fruit/:Fruit |} fruit_page
23 | ; {%r| / |} root_page
24 | ; {%r| /faq/:int/** |} faq
25 | ]
26 | ]}
27 |
28 | {1:syntax %r Syntax}
29 |
30 | In general, the [%r] syntax closely mirrors that of a HTTP {i path}{^ 1} and
31 | {i query}{^ 2} syntax. The two notable points of divergence are as follows:
32 |
33 | + [%r] allows to specify HTTP methods applicable to a {i request target}
34 | + [%r] only allows [key=value] form of query specification.
35 |
36 | We use {i ABNF notation}{^ 3} to specify the [%r] syntax.
37 |
38 | {%html:
39 |
40 | routes-syntax = http-path ["?" http-query]
41 | http-path = "/" wtr-segment
42 | wtr-segment = wtr-arg / rest / wildcard / [segment-nz *( "/" segment)]
43 | wtr-arg = ":int" / ":int32" / ":int64" / ":float" / ":bool" / ":string" / custom-arg
44 | custom-arg = ":" ocaml-module-path
45 |
46 | ocaml-module-path = module-name *("." module-name) ; OCaml module path
47 | ocaml-module-name = (A-Z) *( ALPHA / DIGIT / "_" / "'" ) ; OCaml module name
48 |
49 | rest = "**"
50 | wildcard = "*"
51 | segment = *pchar
52 | segment-nz = 1*pchar
53 | pchar = unreserved / pct-encoded / sub-delims / ":" / "@"
54 | unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"
55 | pct-encoded = "%" HEXDIG HEXDIG
56 | sub-delims = "!" / "$" / "&" / "'" / "(" / ")" / "*" / "+" / "," / ";" / "="
57 |
58 | http-query = query-key-value *("&" query-key-value)
59 | query-key-value = query-name "=" query-value
60 | query-value = 1*pchar / wtr-arg
61 | query-name = 1( pchar / "/" / "?" )
62 | qchar = unreserved / pct-encoded / qsub-delims / ":" / "@"
63 | qsub-delims = "!" / "$" / "'" / "(" / ")" / "*" / "+" / "," / ";"
64 |
65 | ALPHA = %x41-5A / %x61-7A ; A-Z / a-z
66 | DIGIT = %x30-39 ; 0-9
67 | HEXDIG = DIGIT / "A" / "B" / "C" / "D" / "E" / "F"
68 |
69 | %}
70 |
71 | {2 wtr-segment}
72 |
73 | - rest[(**)] is {!val:Wtr.rest}
74 | - wildcard[(\*\)] is {!val:Wtr.string}
75 |
76 | {2 wtr-arg}
77 |
78 | - [:int] - is {!val:Wtr.int} when used in path and {!val:Wtr.qint} when used
79 | in query
80 | - [:int32] - is {!val:Wtr.int32} when used in path and {!val:Wtr.qint32}
81 | when used in query
82 | - [:int64] - is {!val:Wtr.int64} when used in path and {!val:Wtr.qint64}
83 | when used in query
84 | - [:float] - is {!val:Wtr.float} when used in path and {!val:Wtr.qfloat}
85 | when used in query
86 | - [:bool] - is {!val:Wtr.bool} when used in path and {!val:Wtr.qbool} when
87 | used in query
88 | - [:string] - is {!val:Wtr.string} when used in path and {!val:Wtr.qstring}
89 | when used in query
90 | - [:custom-arg] - is the OCaml module name which implements the user defined
91 | {!type:Wtr.arg} value, e.g. [:Fruit] or [:LibA.Fruit]
92 |
93 | {1:references References}
94 |
95 | + {{:https://datatracker.ietf.org/doc/html/rfc3986#section-3.3} HTTP path}
96 | + {{:https://datatracker.ietf.org/doc/html/rfc3986#section-3.4} HtTP query}
97 | + {{:https://datatracker.ietf.org/doc/html/rfc5234#section-3.6} ABNF} *)
98 |
--------------------------------------------------------------------------------
/lib_spring/secret.ml:
--------------------------------------------------------------------------------
1 | let nonce_size = 12
2 |
3 | let encrypt_base64 nonce key contents =
4 | assert (String.length contents > 0);
5 | let key = Cstruct.of_string key in
6 | let key = Mirage_crypto.Chacha20.of_secret key in
7 | let encrypted =
8 | Mirage_crypto.Chacha20.authenticate_encrypt ~key ~nonce
9 | (Cstruct.of_string contents)
10 | in
11 | Cstruct.concat [ nonce; encrypted ]
12 | |> Cstruct.to_string
13 | |> Base64.(encode_string ~pad:false ~alphabet:uri_safe_alphabet)
14 |
15 | let decrypt_base64 key contents =
16 | assert (String.length contents > 0);
17 | let key = Cstruct.of_string key in
18 | let key = Mirage_crypto.Chacha20.of_secret key in
19 | let contents =
20 | Base64.(decode_exn ~pad:false ~alphabet:uri_safe_alphabet contents)
21 | |> Cstruct.of_string
22 | in
23 | let nonce = Cstruct.sub contents 0 nonce_size in
24 | Cstruct.sub contents nonce_size (Cstruct.length contents - nonce_size)
25 | |> Mirage_crypto.Chacha20.authenticate_decrypt ~key ~nonce
26 | |> function
27 | | Some s -> Cstruct.to_string s
28 | | None -> failwith "Unable to decrypt contents"
29 |
--------------------------------------------------------------------------------
/lib_spring/session.ml:
--------------------------------------------------------------------------------
1 | module Data = Map.Make (String)
2 |
3 | type nonce = Cstruct.t
4 |
5 | type data = string
6 |
7 | type key = string
8 |
9 | type session_data = string Data.t
10 |
11 | type codec =
12 | { cookie_name : string
13 | ; encode : nonce -> session_data -> data
14 | ; decode : data -> session_data
15 | }
16 |
17 | let[@inline] err () = failwith "Invalid session data"
18 |
19 | let cookie_codec ?(cookie_name = "___SPRING_SESSION___") key =
20 | { cookie_name
21 | ; encode =
22 | (fun nonce session_data ->
23 | Data.to_seq session_data
24 | |> Seq.map (fun (key, v) -> Csexp.(List [ Atom key; Atom v ]))
25 | |> List.of_seq
26 | |> fun l ->
27 | Csexp.List l |> Csexp.to_string |> Secret.encrypt_base64 nonce key)
28 | ; decode =
29 | (fun data ->
30 | let csexp =
31 | match Secret.decrypt_base64 key data |> Csexp.parse_string with
32 | | Ok v -> v
33 | | Error _ -> err ()
34 | in
35 | match csexp with
36 | | Csexp.List key_values ->
37 | List.fold_left
38 | (fun acc -> function
39 | | Csexp.(List [ Atom key; Atom value ]) -> Data.add key value acc
40 | | _ -> err ())
41 | Data.empty key_values
42 | | _ -> err ())
43 | }
44 |
45 | let cookie_name (t : codec) = t.cookie_name
46 |
47 | let decode data (t : codec) = t.decode data
48 |
49 | let encode ~nonce session_data (t : codec) = t.encode nonce session_data
50 |
--------------------------------------------------------------------------------
/lib_spring/session.mli:
--------------------------------------------------------------------------------
1 | (** [Session] implements session functionality in Spring.
2 |
3 | Session can be used to store/retrieve values in a request processing
4 | pipeline. *)
5 |
6 | type nonce = Cstruct.t
7 | (** [nonce] is a 12 byte long randomly generated value. Ensure that this value
8 | is generated from a secure random generation source such as
9 | [Mirage_crypto_rng.generate]. *)
10 |
11 | type data = string
12 | (** [data] is the encrypted data encoded in a session cookie. *)
13 |
14 | type key = string
15 |
16 | module Data : module type of Map.Make (String)
17 |
18 | type session_data = string Data.t
19 |
20 | type codec
21 | (** [codec] encapsulates {!type:session_data} encoding/decoding functionality. *)
22 |
23 | val cookie_codec : ?cookie_name:string -> key -> codec
24 | (** [cookie_codec key] is a cookie based session [t]. A cookie based session
25 | encodes all session data into a session cookie. The session [data] is
26 | encrypted/decrypted with [key].
27 |
28 | @param cookie_name
29 | is the cookie name used by [t] to encode/decode session data to/from
30 | respectively. The default value is [___SPRING_SESSION___]. *)
31 |
32 | val cookie_name : codec -> string
33 | (** [cookie_name t] is the name of the session cookie in [t]. *)
34 |
35 | val decode : data -> codec -> session_data
36 | (** [decode data t] decodes [data] to [session_data] using [t]. *)
37 |
38 | val encode : nonce:Cstruct.t -> session_data -> codec -> data
39 | (** [encode ~nonce t] encrypts session [t] with a nonce value [nonce]. *)
40 |
--------------------------------------------------------------------------------
/lib_spring/spring.ml:
--------------------------------------------------------------------------------
1 | module Version = Version
2 | module Method = Method
3 | module Status = Status
4 | module Uri = Uri
5 |
6 | (* Header *)
7 | module Te = Te
8 | module Transfer_encoding = Transfer_encoding
9 | module Date = Date
10 | module Content_type = Content_type
11 | module Content_disposition = Content_disposition
12 | module Cookie_name_prefix = Cookie_name_prefix
13 | module Cookie = Cookie
14 | module Set_cookie = Set_cookie
15 | module Expires = Expires
16 | module Etag = Etag
17 | module If_none_match = If_none_match
18 | module Cache_control = Cache_control
19 | module Host = Host
20 | module Headers = Headers
21 |
22 | (* Body *)
23 | module Body = Body
24 | module Chunked = Chunked
25 | module Multipart = Multipart
26 |
27 | (* Others *)
28 | module Request = Request
29 | module Response = Response
30 | module Client = Client
31 | module Server = Server
32 | module Router = Router
33 | module Session = Session
34 | module Csrf = Csrf
35 |
36 | (* Ohtml *)
37 | module Ohtml = Ohtml
38 |
--------------------------------------------------------------------------------
/lib_spring/spring.mli:
--------------------------------------------------------------------------------
1 | module Version = Version
2 | module Method = Method
3 | module Status = Status
4 | module Uri = Uri
5 |
6 | (** {1 Header} *)
7 |
8 | module Te = Te
9 | module Transfer_encoding = Transfer_encoding
10 | module Date = Date
11 | module Content_type = Content_type
12 | module Content_disposition = Content_disposition
13 | module Set_cookie = Set_cookie
14 | module Cookie_name_prefix = Cookie_name_prefix
15 | module Cookie = Cookie
16 | module Expires = Expires
17 | module Etag = Etag
18 | module If_none_match = If_none_match
19 | module Cache_control = Cache_control
20 | module Host = Host
21 | module Headers = Headers
22 |
23 | (** {1 Body} *)
24 |
25 | module Body = Body
26 | module Chunked = Chunked
27 | module Multipart = Multipart
28 |
29 | (* {1 Request} *)
30 |
31 | module Request = Request
32 |
33 | (** {1 Response} *)
34 |
35 | module Response = Response
36 |
37 | (** {1 Client} *)
38 |
39 | module Client = Client
40 |
41 | (** {1 Server} *)
42 |
43 | module Server = Server
44 | module Router = Router
45 | module Csrf = Csrf
46 |
47 | (** {1 Ohtml} *)
48 |
49 | module Session = Session
50 | module Ohtml = Ohtml
51 |
--------------------------------------------------------------------------------
/lib_spring/status.ml:
--------------------------------------------------------------------------------
1 | type t = int * string
2 |
3 | let make code phrase =
4 | if code < 0 then failwith (Printf.sprintf "code: %d is negative" code)
5 | else if code < 100 || code > 999 then
6 | failwith (Printf.sprintf "code: %d is not a three-digit number" code)
7 | else (code, phrase)
8 |
9 | (* Informational *)
10 | let continue = (100, "Continue")
11 |
12 | let switching_protocols = (101, "Switching Protocols")
13 |
14 | let processing = (102, "Processing")
15 |
16 | let early_hints = (103, "Early Hints")
17 |
18 | (* Successful *)
19 |
20 | let ok = (200, "OK")
21 |
22 | let created = (201, "Created")
23 |
24 | let accepted = (202, "Accepted")
25 |
26 | let non_authoritative_information = (203, "Non-Authoritative Information")
27 |
28 | let no_content = (204, "No Content")
29 |
30 | let reset_content = (205, "Reset Content")
31 |
32 | let partial_content = (206, "Partial Content")
33 | (* Redirection *)
34 |
35 | let multiple_choices = (300, "Multiple Choices")
36 |
37 | let moved_permanently = (301, "Moved Permanently")
38 |
39 | let found = (302, "Found")
40 |
41 | let see_other = (303, "See Other")
42 |
43 | let not_modified = (304, "Not Modified")
44 |
45 | let use_proxy = (305, "Use Proxy")
46 |
47 | let temporary_redirect = (306, "Temporary Redirect")
48 |
49 | (* Client error *)
50 | let bad_request = (400, "Bad Request")
51 |
52 | let unauthorized = (401, "Unauthorized")
53 |
54 | let payment_required = (402, "Payment Required")
55 |
56 | let forbidden = (403, "Forbidden")
57 |
58 | let not_found = (404, "Not Found")
59 |
60 | let method_not_allowed = (405, "Method Not Allowed")
61 |
62 | let not_acceptable = (406, "Not Acceptable")
63 |
64 | let proxy_authentication_required = (407, "Proxy Authentication Required")
65 |
66 | let request_timeout = (408, "Request Timeout")
67 |
68 | let conflict = (409, "Conflict")
69 |
70 | let gone = (410, "Gone")
71 |
72 | let length_required = (411, "Length Required")
73 |
74 | let precondition_failed = (412, "Precondition Failed")
75 |
76 | let content_too_large = (413, "Payload Too Large")
77 |
78 | let uri_too_long = (414, "URI Too Long")
79 |
80 | let unsupported_media_type = (415, "Unsupported Media Type")
81 |
82 | let range_not_satisfiable = (416, "Range Not Satisfiable")
83 |
84 | let expectation_failed = (417, "Expectation Failed")
85 |
86 | let misdirected_request = (421, "Misdirected Request")
87 |
88 | let unprocessable_content = (422, "Unprocessable Content")
89 |
90 | let locked = (423, "Locked")
91 |
92 | let failed_dependency = (424, "Failed Dependency")
93 |
94 | let too_early = (425, "Too Early")
95 |
96 | let upgrade_required = (426, "Upgrade Required")
97 |
98 | let unassigned = (427, "Unassigned")
99 |
100 | let precondition_required = (428, "Precondition Required")
101 |
102 | let too_many_requests = (429, "Too Many Requests")
103 |
104 | let request_header_fields_too_large = (431, "Request Header Fields Too Large")
105 |
106 | let unavailable_for_legal_reasons = (451, "Unavailable For Legal Reasons")
107 |
108 | (* Server error *)
109 | let internal_server_error = (500, "Internal Server Error")
110 |
111 | let not_implemented = (501, "Not Implemented")
112 |
113 | let bad_gateway = (502, "Bad Gateway")
114 |
115 | let service_unavilable = (503, "Service Unavailable")
116 |
117 | let gateway_timeout = (504, "Gateway Timeout")
118 |
119 | let http_version_not_supported = (505, "HTTP Version Not Supported")
120 |
121 | let variant_also_negotiates = (506, "Variant Also Negotiates")
122 |
123 | let insufficient_storage = (507, "Insufficient Storage")
124 |
125 | let loop_detected = (508, "Loop Detected")
126 |
127 | let network_authentication_required = (511, "Network Authentication Required")
128 |
129 | let informational (code, _) = code >= 100 && code <= 103
130 |
131 | let server_error (code, _) = code >= 500 && code <= 511
132 |
133 | let equal (code_a, _) (code_b, _) = code_a = code_b
134 |
135 | let to_string (code, phrase) = string_of_int code ^ " " ^ phrase
136 |
137 | let pp fmt t = Format.fprintf fmt "%s" (to_string t)
138 |
--------------------------------------------------------------------------------
/lib_spring/status.mli:
--------------------------------------------------------------------------------
1 | type t = private int * string
2 |
3 | val make : int -> string -> t
4 | (** [make code phrase] is [t] with status code [code] and status phrase
5 | [phrase]. *)
6 |
7 | (** Informational *)
8 |
9 | val continue : t
10 |
11 | val switching_protocols : t
12 |
13 | val processing : t
14 |
15 | val early_hints : t
16 |
17 | (** Successful *)
18 |
19 | val ok : t
20 |
21 | val created : t
22 |
23 | val accepted : t
24 |
25 | val non_authoritative_information : t
26 |
27 | val no_content : t
28 |
29 | val reset_content : t
30 |
31 | val partial_content : t
32 |
33 | (** Redirection *)
34 |
35 | val multiple_choices : t
36 |
37 | val moved_permanently : t
38 |
39 | val found : t
40 |
41 | val see_other : t
42 |
43 | val not_modified : t
44 |
45 | val use_proxy : t
46 |
47 | val temporary_redirect : t
48 |
49 | (** Client error *)
50 |
51 | val bad_request : t
52 |
53 | val unauthorized : t
54 |
55 | val payment_required : t
56 |
57 | val forbidden : t
58 |
59 | val not_found : t
60 |
61 | val method_not_allowed : t
62 |
63 | val not_acceptable : t
64 |
65 | val proxy_authentication_required : t
66 |
67 | val request_timeout : t
68 |
69 | val conflict : t
70 |
71 | val gone : t
72 |
73 | val length_required : t
74 |
75 | val precondition_failed : t
76 |
77 | val content_too_large : t
78 |
79 | val uri_too_long : t
80 |
81 | val unsupported_media_type : t
82 |
83 | val range_not_satisfiable : t
84 |
85 | val expectation_failed : t
86 |
87 | val misdirected_request : t
88 |
89 | val unprocessable_content : t
90 |
91 | val locked : t
92 |
93 | val failed_dependency : t
94 |
95 | val too_early : t
96 |
97 | val upgrade_required : t
98 |
99 | val unassigned : t
100 |
101 | val precondition_required : t
102 |
103 | val too_many_requests : t
104 |
105 | val request_header_fields_too_large : t
106 |
107 | val unavailable_for_legal_reasons : t
108 |
109 | (** Server error *)
110 |
111 | val internal_server_error : t
112 |
113 | val not_implemented : t
114 |
115 | val bad_gateway : t
116 |
117 | val service_unavilable : t
118 |
119 | val gateway_timeout : t
120 |
121 | val http_version_not_supported : t
122 |
123 | val variant_also_negotiates : t
124 |
125 | val insufficient_storage : t
126 |
127 | val loop_detected : t
128 |
129 | val network_authentication_required : t
130 |
131 | (** {1 Status} *)
132 |
133 | val informational : t -> bool
134 |
135 | val server_error : t -> bool
136 |
137 | val equal : t -> t -> bool
138 |
139 | val to_string : t -> string
140 |
141 | val pp : Format.formatter -> t -> unit
142 |
--------------------------------------------------------------------------------
/lib_spring/string.ml:
--------------------------------------------------------------------------------
1 | include Astring.String
2 |
--------------------------------------------------------------------------------
/lib_spring/te.ml:
--------------------------------------------------------------------------------
1 | type directive = string
2 |
3 | type q = string
4 |
5 | module M = Set.Make (struct
6 | type t = directive * q option
7 |
8 | let compare ((d1, _) : t) ((d2, _) : t) =
9 | match (d1, d2) with
10 | | "trailers", "trailers" -> 0
11 | | "trailers", _ -> -1
12 | | _, "trailers" -> 1
13 | | _, _ -> Stdlib.compare d1 d2
14 | end)
15 |
16 | let directive = Fun.id
17 |
18 | let trailers = "trailers"
19 |
20 | let compress = "compress"
21 |
22 | let deflate = "deflate"
23 |
24 | let gzip = "gzip"
25 |
26 | type t = M.t
27 |
28 | let singleton ?q d = M.singleton (d, q)
29 |
30 | let exists t d = M.mem (d, None) t
31 |
32 | let add ?q t d = M.add (d, q) t
33 |
34 | let get_q t d : q option =
35 | match M.find_opt (d, None) t with
36 | | Some (_, q) -> q
37 | | None -> None
38 |
39 | let remove t d = M.remove (d, None) t
40 |
41 | let iter f t = M.iter (fun (d, q) -> f d q) t
42 |
43 | let encode t =
44 | let q_to_str = function
45 | | Some q -> ";q=" ^ q
46 | | None -> ""
47 | in
48 | M.to_seq t
49 | |> List.of_seq
50 | |> List.map (fun (d, q) -> d ^ q_to_str q)
51 | |> String.concat ~sep:", "
52 |
53 | open Buf_read.Syntax
54 | open Buf_read
55 |
56 | let is_q_value = function
57 | | '0' .. '9' -> true
58 | | '.' -> true
59 | | _ -> false
60 |
61 | let p_directive =
62 | let parse_qval () =
63 | let* ch = peek_char in
64 | match ch with
65 | | Some ';' ->
66 | let+ v = char ';' *> ows *> string "q=" *> take_while1 is_q_value in
67 | Some v
68 | | _ -> return None
69 | in
70 | let* directive = token <* ows in
71 | let+ q =
72 | match directive with
73 | | "trailers" -> return None
74 | | _ -> parse_qval ()
75 | in
76 | (directive, q)
77 |
78 | let decode v =
79 | let r = Buf_read.of_string v in
80 | let d = p_directive r in
81 | let rec aux () =
82 | match peek_char r with
83 | | Some ',' ->
84 | let d = (char ',' *> ows *> p_directive) r in
85 | d :: aux ()
86 | | _ -> []
87 | in
88 | M.of_list (d :: aux ())
89 |
--------------------------------------------------------------------------------
/lib_spring/te.mli:
--------------------------------------------------------------------------------
1 | (** [Te] implements TE header specification at
2 | https://httpwg.org/specs/rfc9110.html#rfc.section.10.1.4 *)
3 |
4 | type directive
5 |
6 | type q = string
7 | (** [q] is the q value as specified at
8 | https://httpwg.org/specs/rfc9110.html#rfc.section.12.4.2 *)
9 |
10 | type t
11 | (** [t] holds TE header values. *)
12 |
13 | (** {1 Directives} *)
14 |
15 | val directive : string -> directive
16 | (** [directive name] is [directive]. *)
17 |
18 | val trailers : directive
19 |
20 | val compress : directive
21 |
22 | val deflate : directive
23 |
24 | val gzip : directive
25 |
26 | (** {1 Exists, Add/Remove} *)
27 |
28 | val singleton : ?q:q -> directive -> t
29 |
30 | val exists : t -> directive -> bool
31 |
32 | val add : ?q:q -> t -> directive -> t
33 |
34 | val get_q : t -> directive -> q option
35 |
36 | val remove : t -> directive -> t
37 |
38 | (** {1 Iter} *)
39 |
40 | val iter : (directive -> q option -> unit) -> t -> unit
41 |
42 | (** {1 Codec} *)
43 |
44 | val encode : t -> string
45 |
46 | val decode : string -> t
47 |
--------------------------------------------------------------------------------
/lib_spring/transfer_encoding.ml:
--------------------------------------------------------------------------------
1 | type encoding = string
2 |
3 | module M = Set.Make (struct
4 | type t = encoding
5 |
6 | (** `chunked at the last *)
7 | let compare (a : encoding) (b : encoding) =
8 | match (a, b) with
9 | | "chunked", "chunked" -> 0
10 | | "chunked", _ -> 1
11 | | _, "chunked" -> -1
12 | | _ -> String.compare a b
13 | end)
14 |
15 | type t = M.t
16 |
17 | let encoding s = s
18 |
19 | let compress = "compress"
20 |
21 | let deflate = "deflate"
22 |
23 | let gzip = "gzip"
24 |
25 | let chunked = "chunked"
26 |
27 | let singleton enc = M.singleton enc
28 |
29 | let is_empty = M.is_empty
30 |
31 | let exists t d = M.mem d t
32 |
33 | let add t d = M.add d t
34 |
35 | let remove t d = M.remove d t
36 |
37 | let iter = M.iter
38 |
39 | let encode t = M.to_seq t |> List.of_seq |> String.concat ~sep:", "
40 |
41 | let decode v =
42 | String.cuts ~sep:"," v
43 | |> List.map String.trim
44 | |> List.filter (fun s -> s <> "")
45 | |> List.fold_left (fun t te -> M.add te t) M.empty
46 |
--------------------------------------------------------------------------------
/lib_spring/transfer_encoding.mli:
--------------------------------------------------------------------------------
1 | (** HTTP [Transfer-Encoding] header.
2 |
3 | See {{!https://www.rfc-editor.org/rfc/rfc9112#name-transfer-encoding}
4 | Transfer-Encoding}. *)
5 |
6 | type t
7 |
8 | (** {1 Encoding} *)
9 |
10 | type encoding
11 | (** [encoding] is HTTP encoding. *)
12 |
13 | val encoding : string -> encoding
14 |
15 | val compress : encoding
16 |
17 | val deflate : encoding
18 |
19 | val gzip : encoding
20 |
21 | val chunked : encoding
22 |
23 | (** {1 Add, Remove, Find} *)
24 |
25 | val singleton : encoding -> t
26 |
27 | val is_empty : t -> bool
28 |
29 | val exists : t -> encoding -> bool
30 |
31 | val add : t -> encoding -> t
32 |
33 | val remove : t -> encoding -> t
34 |
35 | val iter : (encoding -> unit) -> t -> unit
36 |
37 | (** {1 Codec} *)
38 |
39 | val encode : t -> string
40 |
41 | val decode : string -> t
42 |
--------------------------------------------------------------------------------
/lib_spring/version.ml:
--------------------------------------------------------------------------------
1 | type t = int * int (* major, minor *)
2 |
3 | let make ~major ~minor = (major, minor)
4 |
5 | let http1_1 = (1, 1)
6 |
7 | let http1_0 = (1, 0)
8 |
9 | let equal (a : t) (b : t) = a = b
10 |
11 | let to_string (major, minor) =
12 | "HTTP/" ^ string_of_int major ^ "." ^ string_of_int minor
13 |
14 | let pp fmt t = Format.fprintf fmt "%s" @@ to_string t
15 |
16 | let parse =
17 | let open Buf_read.Syntax in
18 | let* major =
19 | Buf_read.string "HTTP/" *> Buf_read.any_char <* Buf_read.char '.'
20 | in
21 | let* minor = Buf_read.any_char in
22 | match (major, minor) with
23 | | '1', '1' -> Buf_read.return http1_1
24 | | '1', '0' -> Buf_read.return http1_0
25 | | _ -> (
26 | try
27 | let major = Char.escaped major |> int_of_string in
28 | let minor = Char.escaped minor |> int_of_string in
29 | Buf_read.return (make ~major ~minor)
30 | with Failure _ ->
31 | failwith (Format.sprintf "Invalid HTTP version: (%c,%c)" major minor))
32 |
--------------------------------------------------------------------------------
/lib_spring/version.mli:
--------------------------------------------------------------------------------
1 | (** HTTP request/response version. *)
2 |
3 | type t = private int * int
4 | (** [t] is HTTP version [(major, minor)] *)
5 |
6 | val make : major:int -> minor:int -> t
7 | (** [make ~major ~minor] is HTTP version [t]. [major], [minor] is the
8 | major/minor HTTP version respectively. *)
9 |
10 | val http1_1 : t
11 | (** [http1_1] is HTTP/1.1 version. *)
12 |
13 | val http1_0 : t
14 | (** [http1_0] is HTTP/1.0 version. *)
15 |
16 | val equal : t -> t -> bool
17 | (** [equal a b] is [true] iff [a] and [b] represents the same HTTP version.
18 | Otherwise it is [false]. *)
19 |
20 | val to_string : t -> string
21 | (** [to_string t] is the string representation of [t]. *)
22 |
23 | val pp : Format.formatter -> t -> unit
24 | (** [pp fmt t] pretty prints [t] onto [fmt]. *)
25 |
26 | val parse : t Buf_read.parser
27 | (** [parse buf_read] parses HTTP version [t] from [buf_read]. *)
28 |
--------------------------------------------------------------------------------
/spring.opam:
--------------------------------------------------------------------------------
1 | # This file is generated by dune, edit dune-project instead
2 | opam-version: "2.0"
3 | synopsis: "Web programming library"
4 | description: "A delightful web programming library"
5 | maintainer: ["gbikal@gmail.com"]
6 | authors: ["Bikal Gurung"]
7 | license: "MPL-2.0"
8 | homepage: "https://github.com/gbikal/spring"
9 | bug-reports: "https://github.com/gbikal/spring/issues"
10 | depends: [
11 | "ocaml" {>= "5.1.1"}
12 | "eio" {>= "0.11"}
13 | "eio_main" {>= "0.11"}
14 | "dune" {>= "3.10" & >= "3.9.0"}
15 | "ptime" {>= "1.1.0"}
16 | "astring" {>= "0.8.5"}
17 | "fmt" {>= "0.9.0"}
18 | "domain-name" {>= "0.4.0"}
19 | "menhir" {>= "20230608"}
20 | "cmdliner" {>= "1.1.1"}
21 | "ppxlib" {>= "0.29.1"}
22 | "cstruct" {>= "6.2.0"}
23 | "base64" {>= "3.5.1"}
24 | "csexp" {>= "1.5.2"}
25 | "ipaddr" {>= "5.5.0"}
26 | "mirage-crypto" {>= "0.11.1"}
27 | "mirage-crypto-rng" {>= "0.11.1"}
28 | "mirage-crypto-rng-eio" {>= "0.11.1"}
29 | "fpath" {>= "0.7.3"}
30 | "magic-mime" {>= "1.3.0"}
31 | "tls" {>= "0.17.1"}
32 | "tls-eio" {>= "0.17.1"}
33 | "ca-certs" {>= "0.2.3"}
34 | "x509" {>= "0.16.5"}
35 | "cstruct" {>= "6.1.1" & with-test}
36 | "mdx" {>= "2.3.0" & with-test}
37 | "odoc" {with-doc}
38 | "ocamlformat" {>= "0.26.1" & with-dev-setup}
39 | "utop" {>= "2.13.1" & with-dev-setup}
40 | ]
41 | build: [
42 | ["dune" "subst"] {dev}
43 | [
44 | "dune"
45 | "build"
46 | "-p"
47 | name
48 | "-j"
49 | jobs
50 | "@install"
51 | "@runtest" {with-test}
52 | "@doc" {with-doc}
53 | ]
54 | ]
55 | dev-repo: "git+https://github.com/gbikal/spring.git"
56 |
--------------------------------------------------------------------------------
/test/body.md:
--------------------------------------------------------------------------------
1 | # Body
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | A `Buffer.t` sink to test `Body.writer`.
8 |
9 | ```ocaml
10 | let test_writer (body: Body.writable) =
11 | Eio_main.run @@ fun env ->
12 | let b = Buffer.create 10 in
13 | let s = Eio.Flow.buffer_sink b in
14 | Eio.Buf_write.with_flow s (fun bw ->
15 | Body.write_headers bw body;
16 | Body.write_body bw body;
17 | );
18 | Eio.traceln "%s" (Buffer.contents b);;
19 | ```
20 |
21 | ## writable_content
22 |
23 | ```ocaml
24 | # let content_type = Content_type.make ("text", "plain");;
25 | val content_type : Content_type.t =
26 |
27 | # test_writer @@ Body.writable_content content_type "hello world";;
28 | +Content-Length: 11
29 | +Content-Type: text/plain
30 | +hello world
31 | - : unit = ()
32 | ```
33 |
34 | ## writable_form_values
35 |
36 | ```ocaml
37 | # test_writer @@ Body.writable_form_values ["name1", "val a"; "name1", "val b"; "name1", "val c"; "name2", "val c"; "name2", "val d"; "name2", "val e"] ;;
38 | +Content-Length: 83
39 | +Content-Type: application/x-www-form-urlencoded
40 | +name1=val%20a&name1=val%20b&name1=val%20c&name2=val%20c&name2=val%20d&name2=val%20e
41 | - : unit = ()
42 | ```
43 |
44 | ## read_content
45 |
46 | ```ocaml
47 | let test_reader body headers f =
48 | Eio_main.run @@ fun env ->
49 | let buf_read = Eio.Buf_read.of_string body in
50 | let headers = Headers.of_list headers in
51 | let r = Body.make_readable headers buf_read in
52 | f r;;
53 | ```
54 |
55 | `read_content` reads the contents of a reader if `headers` contains valid `Content-Length` header.
56 |
57 | ```ocaml
58 | # test_reader "hello world" ["Content-Length","11"] Body.read_content ;;
59 | - : string option = Some "hello world"
60 | ```
61 |
62 | None if 'Content-Length' is not valid.
63 |
64 | ```ocaml
65 | # test_reader "hello world" ["Content-Length","12a"] Body.read_content ;;
66 | - : string option = None
67 | ```
68 |
69 | Or if it is missing.
70 |
71 | ```ocaml
72 | # test_reader "hello world" [] Body.read_content ;;
73 | - : string option = None
74 | ```
75 |
76 | ## read_form_values
77 |
78 | The reader below has both "Content-Length" and "Content-Type" header set correctly, so we are able
79 | to parse the body correctly.
80 |
81 | ```ocaml
82 | # let body = "name1=val%20a&name1=val%20b&name1=val%20c&name2=val%20c&name2=val%20d&name2=val%20e" in
83 | test_reader
84 | body
85 | [("Content-Length", (string_of_int (String.length body))); ("Content-Type", "application/x-www-form-urlencoded")]
86 | Body.read_form_values ;;
87 | - : (string * string) list =
88 | [("name1", "val a"); ("name1", "val b"); ("name1", "val c");
89 | ("name2", "val c"); ("name2", "val d"); ("name2", "val e")]
90 | ```
91 |
92 | Note that the reader below doesn't have "Content-Type" header. Thus `read_form_values` returns am empty list.
93 |
94 | ```ocaml
95 | # let body = "name1=val%20a&name1=val%20b&name1=val%20c&name2=val%20c&name2=val%20d&name2=val%20e" in
96 | test_reader
97 | body
98 | [("Content-Length", (string_of_int (String.length body)))]
99 | Body.read_form_values ;;
100 | - : (string * string) list = []
101 | ```
102 |
103 | Note that the reader below doesn't have "Content-Length" header. Thus `read_form_values` returns am empty list.
104 |
105 | ```ocaml
106 | # let body = "name1=val%20a,val%20b,val%20c&name2=val%20c,val%20d,val%20e" in
107 | test_reader
108 | body
109 | [("Content-Type", "application/x-www-form-urlencoded")]
110 | Body.read_form_values ;;
111 | - : (string * string) list = []
112 | ```
113 |
--------------------------------------------------------------------------------
/test/buf_read.md:
--------------------------------------------------------------------------------
1 | # Spring.Buf_read
2 |
3 | ```ocaml
4 | open Spring
5 |
6 | module Buf_read = Spring__Buf_read
7 |
8 | let b s = Buf_read.of_string s
9 | ```
10 |
11 | ## Buf_read.take_while1
12 |
13 | `take_while1` calls given `on_error` function.
14 |
15 | ```ocaml
16 | # Buf_read.take_while1 ~on_error:(fun () -> failwith "invalid name")
17 | (function 'a'..'z' -> true | _ -> false) @@ b "";;
18 | Exception: Failure "invalid name".
19 | ```
20 |
21 | ## Buf_read.quoted_pair
22 |
23 | ```ocaml
24 | # Buf_read.quoted_pair @@ b {|\"|} ;;
25 | - : char = '"'
26 |
27 | # Buf_read.quoted_pair @@ b {|\\|} ;;
28 | - : char = '\\'
29 |
30 | # Buf_read.quoted_pair @@ b {|\v|} ;;
31 | - : char = 'v'
32 | ```
33 |
34 | ## Buf_read.quoted_text
35 |
36 | ```ocaml
37 | # Buf_read.quoted_text @@ b "\t";;
38 | - : char = '\t'
39 |
40 | # Buf_read.quoted_text @@ b "a";;
41 | - : char = 'a'
42 | ```
43 |
44 | ## Buf_read.quoted_string
45 |
46 | ```ocaml
47 | # Buf_read.quoted_string @@ b {|"hello world"|} ;;
48 | - : string = "hello world"
49 |
50 | # Buf_read.quoted_string @@ b {|"hello \" \\world"|} ;;
51 | - : string = "hello \" \\world"
52 | ```
53 |
54 | ## cookie_pair
55 |
56 | Parse cookie name, value to `SID` and `"hello"`. Note the double quotes on the value.
57 |
58 | ```ocaml
59 | # Buf_read.cookie_pair @@ b {|SID="hello"|};;
60 | - : string * string = ("SID", "\"hello\"")
61 |
62 | # Buf_read.cookie_pair @@ b {|SID=1234|};;
63 | - : string * string = ("SID", "1234")
64 | ```
65 |
66 | ## list1
67 |
68 | `list1` should parse at least one or more elements.
69 |
70 | Valid cases.
71 |
72 | ```ocaml
73 | # let p = Buf_read.take_while1 (function 'a' .. 'z' -> true | _ -> false);;
74 | val p : string Buf_read.parser =
75 |
76 | # Buf_read.list1 p (Buf_read.of_string "foo, bar");;
77 | - : string list = ["foo"; "bar"]
78 |
79 | # Buf_read.list1 p (Buf_read.of_string "foo ,bar,");;
80 | - : string list = ["foo"; "bar"]
81 |
82 | # Buf_read.list1 p (Buf_read.of_string "foo , ,bar,charlie");;
83 | - : string list = ["foo"; "bar"; "charlie"]
84 | ```
85 |
86 | Invalid cases - `take_while1` requires at least one character.
87 |
88 | ```ocaml
89 | # Buf_read.list1 p (Buf_read.of_string "");;
90 | Exception: Failure "take_while1".
91 |
92 | # Buf_read.list1 p (Buf_read.of_string ",");;
93 | Exception: Failure "take_while1".
94 |
95 | # Buf_read.list1 p (Buf_read.of_string ", ,");;
96 | Exception: Failure "take_while1".
97 | ```
98 |
99 | Valid cases - `take_while` allows empty string.
100 |
101 | ```ocaml
102 | # let p = Buf_read.take_while (function 'a' .. 'z' -> true | _ -> false);;
103 | val p : string Buf_read.parser =
104 |
105 | # Buf_read.list1 p (Buf_read.of_string "");;
106 | - : string list = [""]
107 |
108 | # Buf_read.list1 p (Buf_read.of_string ",");;
109 | - : string list = [""]
110 |
111 | # Buf_read.list1 p (Buf_read.of_string ", ,");;
112 | - : string list = [""]
113 | ```
114 |
115 | ## delta_seconds
116 |
117 | ```ocaml
118 | # Buf_read.(delta_seconds (of_string "234"));;
119 | - : int = 234
120 |
121 | # Buf_read.(delta_seconds (of_string "5"));;
122 | - : int = 5
123 |
124 | # Buf_read.(delta_seconds (of_string ""));;
125 | Exception: Failure "take_while1".
126 | ```
127 |
--------------------------------------------------------------------------------
/test/certificates/server.key:
--------------------------------------------------------------------------------
1 | -----BEGIN RSA PRIVATE KEY-----
2 | MIICXQIBAAKBgQC2QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJv
3 | K+aOANKIsOOr9v4RiEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTRE
4 | BE/t1soVT3a/vVJWCLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQAB
5 | AoGAd/CShG8g/JBMh9Nz/8KAuKHRHc2BvysIM1C62cSosgaFmdRrazJfBrEv3Nlc
6 | 2/0uc2dVYIxuvm8bIFqi2TWOdX9jWJf6oXwEPXCD0SaDbJTaoh0b+wjyHuaGlttY
7 | Ztvmf8mK1BOhyl3vNMxh/8Re0dGvGgPZHpn8zanaqfGVz+ECQQDngieUpwzxA0QZ
8 | GZKRYhHoLEaPiQzBaXphqWcCLLN7oAKxZlUCUckxRRe0tKINf0cB3Kr9gGQjPpm0
9 | YoqXo8mNAkEAyYgdd+JDi9FH3Cz6ijvPU0hYkriwTii0V09+Ar5DvYQNzNEIEJu8
10 | Q3Yte/TPRuK8zhnp97Bsy9v/Ji/LSWbtZQJBAJe9y8u3otfmWCBLjrIUIcCYJLe4
11 | ENBFHp4ctxPJ0Ora+mjkthuLF+BfdSZQr1dBcX1a8giuuvQO+Bgv7r9t75ECQC7F
12 | omEyaA7JEW5uGe9/Fgz0G2ph5rkdBU3GKy6jzcDsJu/EC6UfH8Bgawn7tSd0c/E5
13 | Xm2Xyog9lKfeK8XrV2kCQQCTico5lQPjfIwjhvn45ALc/0OrkaK0hQNpXgUNFJFQ
14 | tuX2WMD5flMyA5PCx5XBU8gEMHYa8Kr5d6uoixnbS0cZ
15 | -----END RSA PRIVATE KEY-----
16 |
--------------------------------------------------------------------------------
/test/certificates/server.pem:
--------------------------------------------------------------------------------
1 | -----BEGIN CERTIFICATE-----
2 | MIICYzCCAcwCCQDLbE6ES1ih1DANBgkqhkiG9w0BAQUFADB2MQswCQYDVQQGEwJB
3 | VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0
4 | cyBQdHkgTHRkMRUwEwYDVQQDDAxZT1VSIE5BTUUhISExGDAWBgkqhkiG9w0BCQEW
5 | CW1lQGJhci5kZTAeFw0xNDAyMTcyMjA4NDVaFw0xNTAyMTcyMjA4NDVaMHYxCzAJ
6 | BgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5l
7 | dCBXaWRnaXRzIFB0eSBMdGQxFTATBgNVBAMMDFlPVVIgTkFNRSEhITEYMBYGCSqG
8 | SIb3DQEJARYJbWVAYmFyLmRlMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC2
9 | QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJvK+aOANKIsOOr9v4R
10 | iEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTREBE/t1soVT3a/vVJW
11 | CLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQABMA0GCSqGSIb3DQEB
12 | BQUAA4GBAIo4ZppIlp3JRyltRC1/AyCC0tsh5TdM3W7258wdoP3lEe08UlLwpnPc
13 | aJ/cX8rMG4Xf4it77yrbVrU3MumBEGN5TW4jn4+iZyFbp6TT3OUF55nsXDjNHBbu
14 | deDVpGuPTI6CZQVhU5qEMF3xmlokG+VV+HCDTglNQc+fdLM0LoNF
15 | -----END CERTIFICATE-----
16 |
--------------------------------------------------------------------------------
/test/chunked.md:
--------------------------------------------------------------------------------
1 | # Chunked
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | A `Buffer.t` sink to test `Body.writer`.
8 |
9 | ```ocaml
10 | let test_writer (body : Body.writable) =
11 | Eio_main.run @@ fun env ->
12 | let b = Buffer.create 10 in
13 | let s = Eio.Flow.buffer_sink b in
14 | Eio.Buf_write.with_flow s (fun bw ->
15 | Body.write_headers bw body;
16 | Body.write_body bw body;
17 | );
18 | Eio.traceln "%s" (Buffer.contents b);;
19 | ```
20 |
21 | ## Chunked.writable
22 |
23 | Writes both chunked body and trailer since `ua_supports_trailer:true`.
24 |
25 | ```ocaml
26 | # let write_chunk f =
27 | f @@ Chunked.make ~extensions:["ext1",Some "ext1_v"] "Hello, ";
28 | Eio.Fiber.yield ();
29 | Eio.traceln "Resuming ...";
30 | f @@ Chunked.make ~extensions:["ext2",None] "world!";
31 | Eio.Fiber.yield ();
32 | Eio.traceln "Resuming ...";
33 | f @@ Chunked.make "Again!";
34 | f @@ Chunked.make "";;
35 | val write_chunk : (Chunked.t -> 'a) -> 'a =
36 | # let write_trailer f =
37 | let trailer_headers =
38 | Headers.of_list
39 | [
40 | ("Expires", "Wed, 21 Oct 2015 07:28:00 GMT");
41 | ("Header1", "Header1 value text");
42 | ("Header2", "Header2 value text");
43 | ]
44 | in
45 | f trailer_headers;;
46 | val write_trailer : (Headers.t -> 'a) -> 'a =
47 |
48 | # test_writer (Chunked.writable ~ua_supports_trailer:true write_chunk write_trailer) ;;
49 | +Resuming ...
50 | +Resuming ...
51 | +Transfer-Encoding: chunked
52 | +7;ext1=ext1_v
53 | +Hello,
54 | +6;ext2
55 | +world!
56 | +6
57 | +Again!
58 | +0
59 | +Expires: Wed, 21 Oct 2015 07:28:00 GMT
60 | +Header1: Header1 value text
61 | +Header2: Header2 value text
62 | +
63 | +
64 | - : unit = ()
65 | ```
66 |
67 | Writes only chunked body and not the trailers since `ua_supports_trailer:false`.
68 |
69 | ```ocaml
70 | # test_writer (Chunked.writable ~ua_supports_trailer:false write_chunk write_trailer) ;;
71 | +Resuming ...
72 | +Resuming ...
73 | +Transfer-Encoding: chunked
74 | +7;ext1=ext1_v
75 | +Hello,
76 | +6;ext2
77 | +world!
78 | +6
79 | +Again!
80 | +0
81 | +
82 | +
83 | - : unit = ()
84 | ```
85 |
86 | ## Chunked.reader
87 |
88 | ```ocaml
89 | let test_reader body headers f =
90 | Eio_main.run @@ fun env ->
91 | let buf_read = Eio.Buf_read.of_string body in
92 | let headers = Headers.of_list headers in
93 | let r = Body.make_readable headers buf_read in
94 | f r
95 |
96 | let f chunk = Eio.traceln "%a" Chunked.pp chunk
97 |
98 | let body = "7;ext1=ext1_v;ext2=ext2_v;ext3\r\nMozilla\r\n9\r\nDeveloper\r\n7\r\nNetwork\r\n0\r\nHeader2: Header2 value text\r\nHeader1: Header1 value text\r\nExpires: Wed, 21 Oct 2015 07:28:00 GMT\r\n\r\n"
99 | ```
100 |
101 | The test below prints chunks to a standard output and returns trailer headers. Note, we don't return `Header2`
102 | because the `Trailer` header in request doesn't specify Header2 as being included in the chunked encoding trailer
103 | header list.
104 |
105 | ```ocaml
106 | # let headers =
107 | test_reader
108 | body
109 | ["Trailer", "Expires, Header1"; "Transfer-Encoding", "chunked"]
110 | (Chunked.read_chunked f);;
111 | +
112 | +[size = 7; ext1="ext1_v" ext2="ext2_v" ext3
113 | +Mozilla
114 | +]
115 | +
116 | +[size = 9
117 | +Developer
118 | +]
119 | +
120 | +[size = 7
121 | +Network
122 | +]
123 | +
124 | +[size = 0 ]
125 | val headers : Headers.t option = Some
126 |
127 | # Eio.traceln "%a" Headers.pp (Option.get headers) ;;
128 | +[
129 | + Content-Length: 23;
130 | + Header1: Header1 value text
131 | +]
132 | - : unit = ()
133 | ```
134 |
135 | Returns `Header2` since it is specified in the request `Trailer` header.
136 |
137 | ```ocaml
138 | # let headers =
139 | test_reader
140 | body
141 | ["Trailer", "Expires, Header1, Header2"; "Transfer-Encoding", "chunked"]
142 | (Chunked.read_chunked f);;
143 | +
144 | +[size = 7; ext1="ext1_v" ext2="ext2_v" ext3
145 | +Mozilla
146 | +]
147 | +
148 | +[size = 9
149 | +Developer
150 | +]
151 | +
152 | +[size = 7
153 | +Network
154 | +]
155 | +
156 | +[size = 0 ]
157 | val headers : Headers.t option = Some
158 |
159 | # Eio.traceln "%a" Headers.pp (Option.get headers) ;;
160 | +[
161 | + Content-Length: 23;
162 | + Header2: Header2 value text;
163 | + Header1: Header1 value text
164 | +]
165 | - : unit = ()
166 | ```
167 |
168 | Nothing is read if `Transfer-Encoding: chunked` header is missing.
169 |
170 | ```ocaml
171 | # let headers =
172 | test_reader
173 | body
174 | ["Trailer", "Expires, Header1, Header2"; "Transfer-Encoding", "gzip"]
175 | (Chunked.read_chunked f);;
176 | val headers : Headers.t option = None
177 |
178 | # headers = None;;
179 | - : bool = true
180 | ```
181 |
182 | reader works okay even if there are no trailers.
183 |
184 | ```ocaml
185 | let body = "7;ext1=ext1_v;ext2=ext2_v;ext3\r\nMozilla\r\n9\r\nDeveloper\r\n7\r\nNetwork\r\n0\r\n\r\n"
186 | ```
187 |
188 | ```ocaml
189 | # let headers =
190 | test_reader
191 | body
192 | ["Trailer", "Expires, Header1, Header2"; "Transfer-Encoding", "chunked"]
193 | (Chunked.read_chunked f);;
194 | +
195 | +[size = 7; ext1="ext1_v" ext2="ext2_v" ext3
196 | +Mozilla
197 | +]
198 | +
199 | +[size = 9
200 | +Developer
201 | +]
202 | +
203 | +[size = 7
204 | +Network
205 | +]
206 | +
207 | +[size = 0 ]
208 | val headers : Headers.t option = Some
209 |
210 | # headers = None;;
211 | - : bool = false
212 | ```
213 |
214 |
--------------------------------------------------------------------------------
/test/content_disposition.md:
--------------------------------------------------------------------------------
1 | # Content_disposition tests
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | ## Content_disposition.decode
8 |
9 | ```ocaml
10 | # let t = Content_disposition.decode "form-data; name=\"name\"; filename=\"New document 1.2020_08_01_13_16_42.0.svg\"" ;;
11 | val t : Content_disposition.t =
12 |
13 | # Content_disposition.disposition t ;;
14 | - : string = "form-data"
15 |
16 | # Content_disposition.find_param t "filename" ;;
17 | - : string option = Some "New document 1.2020_08_01_13_16_42.0.svg"
18 |
19 | # Content_disposition.find_param t "FILENAME" ;;
20 | - : string option = Some "New document 1.2020_08_01_13_16_42.0.svg"
21 |
22 | # Content_disposition.find_param t "name" ;;
23 | - : string option = Some "name"
24 |
25 | # Content_disposition.find_param t "param1" ;;
26 | - : string option = None
27 | ```
28 |
29 | ## Content_disposition.make/encode
30 |
31 | ```ocaml
32 | # let t = Content_disposition.make ~params:[("filename", "\"hello world.png\""); ("name", "\"field1\"")] "form-data";;
33 | val t : Content_disposition.t =
34 |
35 | # Content_disposition.encode t ;;
36 | - : string =
37 | "form-data; filename=\"\"hello world.png\"\"; name=\"\"field1\"\""
38 | ```
39 |
--------------------------------------------------------------------------------
/test/content_type.md:
--------------------------------------------------------------------------------
1 | # Content_type tests
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | ## Content_type.decode
8 |
9 | ```ocaml
10 | # let t = Content_type.decode "multipart/form-data; boundary=---------------------------735323031399963166993862150; charset=\"utf-8\"" ;;
11 | val t : Content_type.t =
12 |
13 | # Content_type.find_param t "boundary" ;;
14 | - : string option =
15 | Some "---------------------------735323031399963166993862150"
16 |
17 | # Content_type.find_param t "charset" ;;
18 | - : string option = Some "utf-8"
19 |
20 | # let t = Content_type.decode "multipart/form-data; boundary=---------------------------735323031399963166993862150; charset=utf-8" ;;
21 | val t : Content_type.t =
22 |
23 | # Content_type.find_param t "charset" ;;
24 | - : string option = Some "utf-8"
25 | ```
26 |
27 | ## Content_type.media_type
28 |
29 | ```ocaml
30 | # Content_type.media_type t ;;
31 | - : Content_type.media_type = ("multipart", "form-data")
32 | ```
33 |
34 | ## Content_type.charset
35 |
36 | ```ocaml
37 | # Content_type.charset t ;;
38 | - : string option = Some "utf-8"
39 | ```
40 |
41 | ## Content_type.make/Content_type.find_param
42 |
43 | ```ocaml
44 | # let t = Content_type.make ~params:["charset","\"utf-8\""; "boundary", "------as28383ddd"] ("text", "plain");;
45 | val t : Content_type.t =
46 |
47 | # Content_type.charset t ;;
48 | - : string option = Some "\"utf-8\""
49 |
50 | # Content_type.media_type t;;
51 | - : Content_type.media_type = ("text", "plain")
52 |
53 | # Content_type.find_param t "charset";;
54 | - : string option = Some "\"utf-8\""
55 |
56 | # Content_type.find_param t "boundary";;
57 | - : string option = Some "------as28383ddd"
58 | ```
59 |
60 | ## Content_type.encode
61 |
62 | ```ocaml
63 | # Content_type.encode t;;
64 | - : string = "text/plain; boundary=------as28383ddd; charset=\"utf-8\""
65 | ```
66 |
--------------------------------------------------------------------------------
/test/cookie.md:
--------------------------------------------------------------------------------
1 | # Cookie tests
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | ```ocaml
8 | let display_cookie name t =
9 | let pp_name_prefix = Fmt.(option ~none:(any "None") Cookie_name_prefix.pp) in
10 | Eio.traceln "Name: '%s'" name;
11 | Eio.traceln "NamePrefix: '%a'" pp_name_prefix @@ Cookie.name_prefix name t;
12 | Eio.traceln "Value : '%a'" Fmt.(option string) @@ Cookie.find_opt name t
13 | ```
14 |
15 | ## decode
16 |
17 | ```ocaml
18 | # let t0 = Cookie.decode "SID=31d4d96e407aad42; lang=en";;
19 | val t0 : Cookie.t =
20 |
21 | # display_cookie "SID" t0;;
22 | +Name: 'SID'
23 | +NamePrefix: 'None'
24 | +Value : '31d4d96e407aad42'
25 | - : unit = ()
26 |
27 | # display_cookie "lang" t0;;
28 | +Name: 'lang'
29 | +NamePrefix: 'None'
30 | +Value : 'en'
31 | - : unit = ()
32 | ```
33 |
34 | Decode should preserve double quotes in cookie value.
35 |
36 | ```ocaml
37 | # let t1 = Cookie.decode {|SID="31d4d96e407aad42"; lang="en"|};;
38 | val t1 : Cookie.t =
39 |
40 | # display_cookie "SID" t1;;
41 | +Name: 'SID'
42 | +NamePrefix: 'None'
43 | +Value : '"31d4d96e407aad42"'
44 | - : unit = ()
45 |
46 | # display_cookie "lang" t1;;
47 | +Name: 'lang'
48 | +NamePrefix: 'None'
49 | +Value : '"en"'
50 | - : unit = ()
51 | ```
52 |
53 | Decode cookies with cookie name prefix.
54 |
55 | ```ocaml
56 | # display_cookie "SID" @@ Cookie.decode {|__Host-SID=1234|};;
57 | +Name: 'SID'
58 | +NamePrefix: '__Host-'
59 | +Value : '1234'
60 | - : unit = ()
61 |
62 | # display_cookie "SID" @@ Cookie.decode {|__Secure-SID=1234|};;
63 | +Name: 'SID'
64 | +NamePrefix: '__Secure-'
65 | +Value : '1234'
66 | - : unit = ()
67 | ```
68 |
69 | 1. Cookie name prefixes are case-sensitive in Cookie header. (Set-Cookie decoding is case-insensitive.)
70 |
71 | ```ocaml
72 | # let t3 = Cookie.decode {|__SeCUre-SID=1234|};;
73 | val t3 : Cookie.t =
74 |
75 | # display_cookie "__SeCUre-SID" t3;;
76 | +Name: '__SeCUre-SID'
77 | +NamePrefix: 'None'
78 | +Value : '1234'
79 | - : unit = ()
80 |
81 | # Cookie.find_opt "__SeCUre-SID" t3;;
82 | - : string option = Some "1234"
83 | ```
84 |
85 | ```ocaml
86 | # Cookie.decode "";;
87 | Exception: Failure "take_while1".
88 |
89 | # Cookie.decode "a";;
90 | Exception: End_of_file.
91 | ```
92 |
93 | ## is_empty
94 |
95 | ```ocaml
96 | # Cookie.(is_empty empty);;
97 | - : bool = true
98 |
99 | # Cookie.is_empty t0;;
100 | - : bool = false
101 | ```
102 |
103 | ## Cookie.find_opt
104 |
105 | ```ocaml
106 | # Cookie.find_opt "SID" t0 ;;
107 | - : string option = Some "31d4d96e407aad42"
108 |
109 | # Cookie.find_opt "lang" t0 ;;
110 | - : string option = Some "en"
111 |
112 | # Cookie.find_opt "asdfsa" t0;;
113 | - : string option = None
114 | ```
115 |
116 | ## Cookie.encode
117 |
118 | ```ocaml
119 | # Cookie.encode t0;;
120 | - : string = "SID=31d4d96e407aad42;lang=en"
121 | ```
122 |
123 | Encode should preserve the double quotes in cookie value.
124 |
125 | ```ocaml
126 | # Cookie.encode t1;;
127 | - : string = "SID=\"31d4d96e407aad42\";lang=\"en\""
128 | ```
129 |
130 | Encode should add cookie name prefix if it exists.
131 |
132 | ```ocaml
133 | # Cookie.(add ~name_prefix:Cookie_name_prefix.host
134 | ~name:"SID"
135 | ~value:{|"1234"|}
136 | empty)
137 | |> Cookie.add ~name:"nm1" ~value:"3333"
138 | |> Cookie.encode;;
139 | - : string = "__Host-SID=\"1234\";nm1=3333"
140 | ```
141 |
142 | ## Cookie.add
143 |
144 | ```ocaml
145 | # let t = Cookie.add ~name:"id" ~value:"value1" t0;;
146 | val t : Cookie.t =
147 |
148 | # Cookie.find_opt "id" t;;
149 | - : string option = Some "value1"
150 |
151 | # Cookie.encode t;;
152 | - : string = "SID=31d4d96e407aad42;id=value1;lang=en"
153 | ```
154 |
155 | `name` parameter is validated.
156 |
157 | ```ocaml
158 | # Cookie.add ~name:"id 1" ~value:"123" t0;;
159 | Exception:
160 | Invalid_argument
161 | "[name] is invalid. Unexpected data after parsing (at offset 2)".
162 | ```
163 |
164 | `value` parameter is validated.
165 |
166 | ```ocaml
167 | # Cookie.add ~name:"id" ~value:"23,ab" t0;;
168 | Exception:
169 | Invalid_argument
170 | "[value] is invalid. Unexpected data after parsing (at offset 2)".
171 | ```
172 |
173 | ## Cookie.remove
174 |
175 | ```ocaml
176 | # let t = Cookie.remove ~name:"id" t;;
177 | val t : Cookie.t =
178 |
179 | # Cookie.find_opt "id" t;;
180 | - : string option = None
181 | ```
182 |
--------------------------------------------------------------------------------
/test/cookie_name_prefix.md:
--------------------------------------------------------------------------------
1 | # Cookie_name_prefix
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | ## host/secure/to_string/pp
8 |
9 | Display cookie name prefix values.
10 |
11 | ```ocaml
12 | # Cookie_name_prefix.(host |> to_string) ;;
13 | - : string = "__Host-"
14 |
15 | # Eio.traceln "%a" Cookie_name_prefix.pp Cookie_name_prefix.secure;;
16 | +__Secure-
17 | - : unit = ()
18 | ```
19 |
20 | ## equal/compare
21 |
22 | ```ocaml
23 | # Cookie_name_prefix.(equal host secure, compare host secure);;
24 | - : bool * int = (false, -1)
25 |
26 | # Cookie_name_prefix.(equal host host, compare host host);;
27 | - : bool * int = (true, 0)
28 |
29 | # Cookie_name_prefix.(equal secure secure, compare secure secure);;
30 | - : bool * int = (true, 0)
31 | ```
32 |
33 | ## cut_prefix
34 |
35 | ```ocaml
36 | let display_cut_result ((name1,t1), (name2, t2)) =
37 | let pp = Fmt.(option ~none:(any "None") Cookie_name_prefix.pp) in
38 | Eio.traceln "(%s, %a) (%s, %a)" name1 pp t1 name2 pp t2
39 | ```
40 |
41 | Case sensitive match is the default.
42 |
43 | ```ocaml
44 | # Cookie_name_prefix.(
45 | cut_prefix "__Host-SID",
46 | cut_prefix ~case_sensitive:true "__HoST-SID")
47 | |> display_cut_result ;;
48 | +(SID, __Host-) (__HoST-SID, None)
49 | - : unit = ()
50 |
51 | # Cookie_name_prefix.(
52 | cut_prefix "__Secure-SID",
53 | cut_prefix ~case_sensitive:true "__SeCUre-SID")
54 | |> display_cut_result ;;
55 | +(SID, __Secure-) (__SeCUre-SID, None)
56 | - : unit = ()
57 | ```
58 |
59 | Case in-sensitive cut.
60 |
61 | ```ocaml
62 | # Cookie_name_prefix.(
63 | cut_prefix ~case_sensitive:false "__Host-SID",
64 | cut_prefix ~case_sensitive:false "__HOst-SID")
65 | |> display_cut_result ;;
66 | +(SID, __Host-) (SID, __Host-)
67 | - : unit = ()
68 |
69 | # Cookie_name_prefix.(
70 | cut_prefix ~case_sensitive:false "__Secure-SID",
71 | cut_prefix ~case_sensitive:false "__SECuRe-SID")
72 | |> display_cut_result ;;
73 | +(SID, __Secure-) (SID, __Secure-)
74 | - : unit = ()
75 | ```
76 |
77 | Prefix not matched
78 |
79 | ```ocaml
80 | # Cookie_name_prefix.cut_prefix "__HelloSID";;
81 | - : string * Cookie_name_prefix.t option = ("__HelloSID", None)
82 | ```
83 |
--------------------------------------------------------------------------------
/test/csrf.md:
--------------------------------------------------------------------------------
1 | # Csrf tests
2 |
3 | ```ocaml
4 | open Spring
5 |
6 | let client_addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8081)
7 | let key = Base64.(decode_exn ~pad:false "knFR+ybPVw/DJoOn+e6vpNNU2Ip2Z3fj1sXMgEyWYhA")
8 | let nonce = Cstruct.of_string "aaaaaaaaaaaa"
9 |
10 | let form_codec = Csrf.form_codec key
11 | let csrf_tok = Base64.(decode_exn ~pad:false "zaQgjF+KK0vSXlYUPhHTlLx/EY+LgpSgy7BxyAdW9n0")
12 |
13 | let session = Session.cookie_codec key
14 | let make_form_submission_request (client_req : Request.client Request.t) =
15 | let client_req =
16 | let token_name = Csrf.token_name form_codec in
17 | let data = Session.Data.(add token_name csrf_tok empty) in
18 | let data = Session.encode ~nonce data session in
19 | let cookie_name = Session.cookie_name session in
20 | Request.add_cookie ~name:cookie_name ~value:data client_req
21 | in
22 | let b = Buffer.create 10 in
23 | let s = Eio.Flow.buffer_sink b in
24 | Eio.Buf_write.with_flow s (fun bw -> Request.write_client_request client_req bw);
25 | let buf_read = Eio.Buf_read.of_string (Buffer.contents b) in
26 | Request.parse_server_request ~session client_addr buf_read
27 |
28 | let run_with_random_generator f =
29 | Eio_main.run @@ fun env ->
30 | Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () ->
31 | f ()
32 |
33 | let pp_response r =
34 | Eio_main.run @@ fun env ->
35 | let b = Buffer.create 10 in
36 | let s = Eio.Flow.buffer_sink b in
37 | Eio.Buf_write.with_flow s (fun bw ->
38 | Response.write_server_response bw r;
39 | );
40 | Eio.traceln "%s" (Buffer.contents b);;
41 | ```
42 |
43 | ## Csrf.enable_protection/token
44 |
45 | ```ocaml
46 | # let req = Request.make_server_request ~resource:"/" Method.get client_addr (Eio.Buf_read.of_string "");;
47 | val req : Request.server Request.t =
48 |
49 | # run_with_random_generator @@ fun () -> Csrf.enable_protection req form_codec;;
50 | - : unit = ()
51 |
52 | # Csrf.token req form_codec |> Option.is_some;;
53 | - : bool = true
54 | ```
55 |
56 | ## Csrf.protect_request
57 |
58 | Return OK response if the CSRF token in form matches the one in session.
59 |
60 | ```ocaml
61 | let host = Host.decode "www.example.com"
62 | ```
63 |
64 | ```ocaml
65 | # let csrf_form_req =
66 | Eio_main.run @@ fun _env ->
67 | let tok : string = Spring__Secret.encrypt_base64 nonce key csrf_tok in
68 | let token_name = Csrf.token_name form_codec in
69 | let body =
70 | Body.writable_form_values [token_name, tok; "name2", "val c"; "name2", "val d"; "name2", "val e"]
71 | in
72 | Request.make_client_request
73 | ~resource:"/post_form"
74 | host
75 | Method.post
76 | body
77 | |> make_form_submission_request ;;
78 | val csrf_form_req : Request.server Request.t =
79 |
80 | # let res = Csrf.protect_request form_codec csrf_form_req (fun _ -> Response.text "hello") ;;
81 | val res : Csrf.response =
82 |
83 | # pp_response res;;
84 | +HTTP/1.1 200 OK
85 | +Content-Length: 5
86 | +Content-Type: text/plain; charset=uf-8
87 | +
88 | +hello
89 | - : unit = ()
90 | ```
91 |
92 | Return `Bad Request` response if the CSRF tokens dont' match.
93 |
94 | ```ocaml
95 | # let csrf_form_req =
96 | Eio_main.run @@ fun _env ->
97 | let tok : string = Spring__Secret.encrypt_base64 nonce key "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" in
98 | let token_name = Csrf.token_name form_codec in
99 | let body =
100 | Body.writable_form_values [token_name, tok;"name2","val c"; "name2","val d"; "name2","val e"]
101 | in
102 | Request.make_client_request
103 | ~resource:"/post_form"
104 | host
105 | Method.post
106 | body
107 | |> make_form_submission_request ;;
108 | val csrf_form_req : Request.server Request.t =
109 |
110 | # let res = Csrf.protect_request form_codec csrf_form_req (fun _ -> Response.text "hello") ;;
111 | val res : Csrf.response =
112 |
113 | # pp_response res;;
114 | +HTTP/1.1 400 Bad Request
115 | +Content-Length: 0
116 | +
117 | +
118 | - : unit = ()
119 | ```
120 |
121 | Mulitpart/formdata form.
122 |
123 | ```ocaml
124 | # let p1 =
125 | let tok = Spring__Secret.encrypt_base64 nonce key csrf_tok in
126 | let token_name = Csrf.token_name form_codec in
127 | Multipart.writable_value_part ~form_name:token_name ~value:tok ;;
128 | val p1 : Multipart.writable Multipart.part =
129 |
130 | # let p2 = Multipart.writable_value_part ~form_name:"file1" ~value:"file is a text file." ;;
131 | val p2 : Multipart.writable Multipart.part =
132 |
133 | # let csrf_form_req =
134 | Eio_main.run @@ fun _env ->
135 | let form_body = Multipart.writable ~boundary:"--A1B2C3" [p1;p2] in
136 | Request.make_client_request
137 | ~resource:"/post_form"
138 | host
139 | Method.post
140 | form_body
141 | |> make_form_submission_request ;;
142 | val csrf_form_req : Request.server Request.t =
143 |
144 | # let res = Csrf.protect_request form_codec csrf_form_req (fun _ -> Response.text "hello") ;;
145 | val res : Csrf.response =
146 |
147 | # pp_response res;;
148 | +HTTP/1.1 200 OK
149 | +Content-Length: 5
150 | +Content-Type: text/plain; charset=uf-8
151 | +
152 | +hello
153 | - : unit = ()
154 | ```
155 |
--------------------------------------------------------------------------------
/test/date.md:
--------------------------------------------------------------------------------
1 | # Date tests
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | ## Date.decode
8 |
9 | ```ocaml
10 | # let date1 = Date.decode "Sun, 06 Nov 1994 08:49:37 GMT";;
11 | val date1 : Date.t =
12 |
13 | # Eio.traceln "%a" Date.pp date1 ;;
14 | +Sun, 06 Nov 1994 08:49:37 GMT
15 | - : unit = ()
16 |
17 | # let date2 = Date.decode "Sunday, 06-Nov-94 08:49:37 GMT";;
18 | val date2 : Date.t =
19 |
20 | # Eio.traceln "%a" Date.pp date2 ;;
21 | +Sun, 06 Nov 1994 08:49:37 GMT
22 | - : unit = ()
23 |
24 | # let date3 = Date.decode "Sun Nov 6 08:49:37 1994";;
25 | val date3 : Date.t =
26 |
27 | # Eio.traceln "%a" Date.pp date3 ;;
28 | +Sun, 06 Nov 1994 08:49:37 GMT
29 | - : unit = ()
30 | ```
31 |
32 | ## Date.encode
33 |
34 | ```ocaml
35 | # Date.encode date1;;
36 | - : string = "Sun, 06 Nov 1994 08:49:37 GMT"
37 |
38 | # Date.encode date2;;
39 | - : string = "Sun, 06 Nov 1994 08:49:37 GMT"
40 |
41 | # Date.encode date3;;
42 | - : string = "Sun, 06 Nov 1994 08:49:37 GMT"
43 | ```
44 |
45 | ## Date.now
46 |
47 | ```ocaml
48 | let now = 1666627935.85052109
49 | let mock_clock = Eio_mock.Clock.make ()
50 | let () = Eio_mock.Clock.set_time mock_clock now
51 | ```
52 |
53 | ```ocaml
54 | # let d1 = Date.now mock_clock;;
55 | val d1 : Date.t =
56 |
57 | # let d2 = Date.of_float_s now |> Option.get;;
58 | val d2 : Date.t =
59 |
60 | # Date.equal d1 d2;;
61 | - : bool = true
62 | ```
63 |
64 | ## Date.of_ptime/of_float_s/equal/compare/is_later/is_earlier
65 |
66 | ```ocaml
67 | let now = 1623940778.27033591
68 | ```
69 |
70 | `Date.t` created using same value `now` are equal.
71 |
72 | ```ocaml
73 |
74 | # let p = Ptime.of_float_s now |> Option.get;;
75 | val p : Ptime.t =
76 |
77 | # let d1 = Date.of_ptime p ;;
78 | val d1 : Date.t =
79 |
80 | # let d2 = Date.of_float_s now |> Option.get;;
81 | val d2 : Date.t =
82 |
83 | # Date.equal d1 d2;;
84 | - : bool = true
85 |
86 | # Date.compare d1 d2;;
87 | - : int = 0
88 |
89 | # Date.is_later d1 ~than:d2, Date.is_later d2 ~than:d1;;
90 | - : bool * bool = (false, false)
91 |
92 | # Date.is_earlier d1 ~than:d2, Date.is_earlier d2 ~than:d1;;
93 | - : bool * bool = (false, false)
94 | ```
95 |
96 | `Date.t` created later returns `true` when comparing `is_later/is_earlier` with `d3`.
97 |
98 | ```ocaml
99 | # let d3 = Date.of_ptime @@ Ptime_clock.now ();;
100 | val d3 : Date.t =
101 |
102 | # Date.is_later d3 ~than:d1, Date.is_later d3 ~than:d2;;
103 | - : bool * bool = (true, true)
104 |
105 | # Date.is_earlier d1 ~than:d3, Date.is_earlier d1 ~than:d3;;
106 | - : bool * bool = (true, true)
107 | ```
108 |
109 | ## equal
110 |
111 | Decoding a value, encoding and decoding it back. `Date.t` should be equal.
112 |
113 | ```ocaml
114 | # let v1 = "Thu, 17 Jun 2021 14:39:38 GMT";;
115 | val v1 : string = "Thu, 17 Jun 2021 14:39:38 GMT"
116 |
117 | # let dd1 = Date.decode v1;;
118 | val dd1 : Date.t =
119 |
120 | # let v2 = Date.encode dd1;;
121 | val v2 : string = "Thu, 17 Jun 2021 14:39:38 GMT"
122 |
123 | # String.equal v1 v2;;
124 | - : bool = true
125 |
126 | # let dd2 = Date.decode v2;;
127 | val dd2 : Date.t =
128 |
129 | # Date.equal dd1 dd2
130 | - : bool = true
131 |
132 | # Date.compare dd1 dd2;;
133 | - : int = 0
134 | ```
135 |
--------------------------------------------------------------------------------
/test/dune:
--------------------------------------------------------------------------------
1 | (copy_files certificates/*.pem)
2 |
3 | (copy_files certificates/*.key)
4 |
5 | (copy_files ../examples/hello/master.key)
6 |
7 | (mdx
8 | (package spring)
9 | (deps server.pem server.key)
10 | (libraries
11 | eio
12 | eio.core
13 | eio.unix
14 | eio.mock
15 | eio_main
16 | fmt
17 | cstruct
18 | ptime
19 | ptime.clock.os
20 | domain-name
21 | spring
22 | base64
23 | ohtml
24 | ipaddr
25 | tls
26 | tls-eio
27 | unix
28 | mirage-crypto
29 | mirage-crypto-rng
30 | mirage-crypto-rng-eio
31 | router_test))
32 |
33 | (library
34 | (name router_test)
35 | (libraries spring)
36 | (modules router_test)
37 | (preprocess
38 | (pps spring)))
39 |
--------------------------------------------------------------------------------
/test/etag.md:
--------------------------------------------------------------------------------
1 | # Etag tests
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | Strong ETag value.
8 |
9 | ```ocaml
10 | # let etag1 = Etag.decode {|"xyzzy"|};;
11 | val etag1 : Etag.t =
12 |
13 | # Etag.is_weak etag1;;
14 | - : bool = false
15 |
16 | # Etag.is_strong etag1;;
17 | - : bool = true
18 |
19 | # Etag.chars etag1;;
20 | - : string = "xyzzy"
21 |
22 | # Etag.encode etag1;;
23 | - : string = "\"xyzzy\""
24 | ```
25 |
26 | Weak ETag value.
27 |
28 | ```ocaml
29 | # let etag2 = Etag.decode {|W/"xyzzy"|};;
30 | val etag2 : Etag.t =
31 |
32 | # Etag.is_weak etag2;;
33 | - : bool = true
34 |
35 | # Etag.is_strong etag2;;
36 | - : bool = false
37 |
38 | # Etag.chars etag2;;
39 | - : string = "xyzzy"
40 |
41 | # Etag.encode etag2;;
42 | - : string = "W/\"xyzzy\""
43 | ```
44 |
45 | Decode empty string.
46 |
47 | ```ocaml
48 | # Etag.decode {|""|};;
49 | - : Etag.t =
50 | ```
51 |
52 | Etag.equal.
53 |
54 | ```ocaml
55 | # Etag.strong_equal etag1 etag2;;
56 | - : bool = false
57 |
58 | # Etag.strong_equal etag2 etag1;;
59 | - : bool = false
60 |
61 | # Etag.strong_equal etag1 (Etag.make "xyzzy" );;
62 | - : bool = true
63 |
64 | # Etag.weak_equal etag1 etag2;;
65 | - : bool = true
66 |
67 | # Etag.weak_equal etag2 etag1;;
68 | - : bool = true
69 | ```
70 |
71 | Invalid ETag value.
72 |
73 | ```ocaml
74 | # Etag.decode {|"adasdf"aa|};;
75 | Exception: Invalid_argument "[v] contains invalid ETag value".
76 |
77 | # Etag.decode {|"asdfasd "|} ;;
78 | Exception: Failure "Expected '\"' but got ' '".
79 | ```
80 |
--------------------------------------------------------------------------------
/test/expires.md:
--------------------------------------------------------------------------------
1 | # Expires tests
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | ## expired/is_expired/expired_value
8 |
9 | 1. An expired value returns `true` for `is_expired`.
10 | 2. Expires.expired value is encoded as `0`.
11 | 2. An expired value `ed` is any invalid HTTP Date.t value.
12 | 3. Two expired values with two different invalid HTTP Date.t values are equal.
13 |
14 | ```ocaml
15 | # Expires.(is_expired expired);;
16 | - : bool = true
17 |
18 | # Expires.(expired_value expired);;
19 | - : string option = Some "0"
20 |
21 | # let ed = Expires.decode "-1";;
22 | val ed : Expires.t =
23 |
24 | # Expires.is_expired ed;;
25 | - : bool = true
26 |
27 | # Expires.(equal ed expired);;
28 | - : bool = true
29 | ```
30 |
31 | ## pp
32 |
33 | ```ocaml
34 | # Eio.traceln "%a" Expires.pp Expires.expired;;
35 | +0
36 | - : unit = ()
37 | ```
38 |
39 | ## of_date
40 |
41 | ```ocaml
42 | let now = 1623940778.27033591
43 | let clock = Eio_mock.Clock.make ()
44 | let () = Eio_mock.Clock.set_time clock now
45 | ```
46 |
47 | 1. Create a `now` Date.t value.
48 | 2. Create `e` as Expires.t from `now`.
49 | 3. Display `e` properties.
50 | 4. Encode `e` to `s1`.
51 | 5. Decode `s1` to `e2`.
52 | 6. `e` and `e2` is equal.
53 | 7. Expires.date `e` and `now` is equal since they are both the same Date.t value.
54 |
55 | ```ocaml
56 | # let now = Date.now clock ;;
57 | val now : Date.t =
58 |
59 | # let e = Expires.of_date now;;
60 | val e : Expires.t =
61 |
62 | # Expires.is_expired e;;
63 | - : bool = false
64 |
65 | # let s1 = Expires.encode e;;
66 | val s1 : string = "Thu, 17 Jun 2021 14:39:38 GMT"
67 |
68 | # let e2 = Expires.decode s1;;
69 | val e2 : Expires.t =
70 |
71 | # Expires.equal e e2;;
72 | - : bool = true
73 |
74 | # Expires.date e |> Option.get = now;;
75 | - : bool = true
76 | ```
77 |
78 | ## decode/encode
79 |
80 | 1. Decode from `s1` to `e1`.
81 | 2. Encode `e1` to `s2`.
82 | 3. `s1` is equal to `s2`.
83 | 4. Decode `s2` to `e2`.
84 | 5. `e1` is equal to `e2`.
85 |
86 | ```ocaml
87 | # let s1 = "Thu, 17 Jun 2021 14:39:38 GMT";;
88 | val s1 : string = "Thu, 17 Jun 2021 14:39:38 GMT"
89 |
90 | # let e1 = Expires.decode s1;;
91 | val e1 : Expires.t =
92 |
93 | # let s2 = Expires.encode e1;;
94 | val s2 : string = "Thu, 17 Jun 2021 14:39:38 GMT"
95 |
96 | # String.equal s1 s2;;
97 | - : bool = true
98 |
99 | # let e2 = Expires.decode s2;;
100 | val e2 : Expires.t =
101 |
102 | # Expires.equal e1 e2;;
103 | - : bool = true
104 | ```
105 |
106 | ## equal
107 |
108 | ```ocaml
109 | # Expires.equal e1 e2;;
110 | - : bool = true
111 |
112 | # Expires.equal e e;;
113 | - : bool = true
114 |
115 | # Expires.(equal expired expired);;
116 | - : bool = true
117 |
118 | # Expires.equal e e1;;
119 | - : bool = true
120 | ```
121 |
--------------------------------------------------------------------------------
/test/host.md:
--------------------------------------------------------------------------------
1 | # Host
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | ```ocaml
8 | # #install_printer Host.pp;;
9 | ```
10 |
11 | ## decode
12 |
13 | Decode IPv6 host and port.
14 |
15 | ```ocaml
16 | # let t0 = Host.decode "192.168.0.1:8080";;
17 | val t0 : Host.t = IPv4 192.168.0.1:8080
18 | ```
19 |
20 | Decode IPv4 host only.
21 |
22 | ```ocaml
23 | # let t1 = Host.decode "192.168.0.1";;
24 | val t1 : Host.t = IPv4 192.168.0.1:
25 | ```
26 |
27 | Decode domain name.
28 |
29 | ```ocaml
30 | # let t2 = Host.decode "www.example.com:8080";;
31 | val t2 : Host.t = Domain www.example.com:8080
32 | ```
33 |
34 | Decode IPv6 host and port.
35 |
36 | ```ocaml
37 | # let t3 = Host.decode "[2001:db8:aaaa:bbbb:cccc:dddd:eeee:1]:8080";;
38 | val t3 : Host.t = IPv6 2001:db8:aaaa:bbbb:cccc:dddd:eeee:1:8080
39 | ```
40 |
41 | ## encode
42 |
43 | ```ocaml
44 | # Host.encode t0;;
45 | - : string = "192.168.0.1:8080"
46 |
47 | # Host.encode t1;;
48 | - : string = "192.168.0.1"
49 |
50 | # Host.encode t2;;
51 | - : string = "www.example.com:8080"
52 |
53 | # Host.encode t3;;
54 | - : string = "2001:db8:aaaa:bbbb:cccc:dddd:eeee:1:8080"
55 | ```
56 |
57 | ## equal
58 |
59 | ```ocaml
60 | # Host.equal t0 t1;;
61 | - : bool = false
62 |
63 | # Host.equal t0 t0;;
64 | - : bool = true
65 |
66 | # Host.equal t1 t1;;
67 | - : bool = true
68 |
69 | # Host.equal t2 t2;;
70 | - : bool = true
71 |
72 | # Host.equal t3 t3;;
73 | - : bool = true
74 | ```
75 |
76 | ## compare
77 |
78 | ```ocaml
79 | # Host.compare t0 t0;;
80 | - : int = 0
81 |
82 | # Host.compare t0 t1;;
83 | - : int = 1
84 |
85 | # Host.compare t0 t2;;
86 | - : int = 1
87 |
88 | # Host.compare t1 t1;;
89 | - : int = 0
90 |
91 | # Host.compare t1 t0;;
92 | - : int = -1
93 |
94 | # Host.compare t1 t2;;
95 | - : int = 1
96 |
97 | # Host.compare t2 t2;;
98 | - : int = 0
99 |
100 | # Host.compare t2 t0;;
101 | - : int = -1
102 |
103 | # Host.compare t2 t1;;
104 | - : int = -1
105 |
106 | # Host.compare t3 t3;;
107 | - : int = 0
108 |
109 | # Host.compare t3 t0;;
110 | - : int = 1
111 |
112 | # Host.compare t3 t1;;
113 | - : int = 1
114 |
115 | # Host.compare t3 t2;;
116 | - : int = 1
117 | ```
118 |
119 | ## pp
120 |
121 | ```ocaml
122 | # Eio.traceln "%a" Host.pp t0;;
123 | +IPv4 192.168.0.1:8080
124 | - : unit = ()
125 |
126 | # Eio.traceln "%a" Host.pp t1;;
127 | +IPv4 192.168.0.1:
128 | - : unit = ()
129 |
130 | # Eio.traceln "%a" Host.pp t2;;
131 | +Domain www.example.com:8080
132 | - : unit = ()
133 |
134 | # Eio.traceln "%a" Host.pp t3;;
135 | +IPv6 2001:db8:aaaa:bbbb:cccc:dddd:eeee:1:8080
136 | - : unit = ()
137 | ```
138 |
--------------------------------------------------------------------------------
/test/if_none_match.md:
--------------------------------------------------------------------------------
1 | # If_none_match tests
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | Any value.
8 |
9 | ```ocaml
10 | # let any = If_none_match.any;;
11 | val any : If_none_match.t =
12 |
13 | # If_none_match.is_any any;;
14 | - : bool = true
15 | ```
16 |
17 | ## make/contains_entity_tag.
18 |
19 | ```ocaml
20 | # let etag1 =Etag.make "xyzzy" and etag2 = Etag.make ~weak:true "xyzzy" ;;
21 | val etag1 : Etag.t =
22 | val etag2 : Etag.t =
23 |
24 | # let etags = [etag1; etag2] ;;
25 | val etags : Etag.t list = [; ]
26 |
27 | # let t = If_none_match.make etags;;
28 | val t : If_none_match.t =
29 |
30 | # If_none_match.contains_entity_tag (fun etag -> Etag.weak_equal etag etag2) t ;;
31 | - : bool = true
32 |
33 | # If_none_match.contains_entity_tag (fun etag -> Etag.strong_equal etag etag2) t ;;
34 | - : bool = false
35 |
36 | # If_none_match.contains_entity_tag (fun etag -> Etag.strong_equal etag etag1) t ;;
37 | - : bool = true
38 | ```
39 |
40 | Searching for entity tag in [any t = true] is always true.
41 |
42 | ```ocaml
43 | # If_none_match.contains_entity_tag (fun _ -> false) any;;
44 | - : bool = true
45 | ```
46 |
47 | Empty entity_tags is invalild.
48 |
49 | ```ocaml
50 | # If_none_match.make [];;
51 | Exception: Invalid_argument "[entity_tags] is empty".
52 | ```
53 |
54 | ## entity_tags
55 |
56 | Retrieve entity tags.
57 |
58 | ```ocaml
59 | # If_none_match.entity_tags t = Some etags;;
60 | - : bool = true
61 | ```
62 |
63 | ## decode
64 |
65 | Decode a strong etag value.
66 |
67 | ```ocaml
68 | # let t1 = If_none_match.decode {|"c3piozzzz"|};;
69 | val t1 : If_none_match.t =
70 |
71 | # If_none_match.entity_tags t1
72 | |> Option.get
73 | |> List.iter (fun etag -> Eio.traceln "%s" (Etag.encode etag)) ;;
74 | +"c3piozzzz"
75 | - : unit = ()
76 | ```
77 |
78 | Decode a weak etag value.
79 |
80 | ```ocaml
81 | # let t2 = If_none_match.decode {|W/"xyzzy"|};;
82 | val t2 : If_none_match.t =
83 |
84 | # If_none_match.entity_tags t2
85 | |> Option.get
86 | |> List.iter (fun etag -> Eio.traceln "%s" (Etag.encode etag)) ;;
87 | +W/"xyzzy"
88 | - : unit = ()
89 | ```
90 |
91 | Decode a list of strong etag values.
92 |
93 | ```ocaml
94 | # let t3 = If_none_match.decode {|"xyzzy", "r2d2xxxx", "c3piozzzz"|};;
95 | val t3 : If_none_match.t =
96 |
97 | # If_none_match.entity_tags t3
98 | |> Option.get
99 | |> List.iter (fun etag -> Eio.traceln "%s" (Etag.encode etag)) ;;
100 | +"xyzzy"
101 | +"r2d2xxxx"
102 | +"c3piozzzz"
103 | - : unit = ()
104 | ```
105 |
106 | Decode a list of weak etag values.
107 |
108 | ```ocaml
109 | # let t4 = If_none_match.decode {|W/"xyzzy", W/"r2d2xxxx", W/"c3piozzzz"|};;
110 | val t4 : If_none_match.t =
111 |
112 | # If_none_match.entity_tags t4
113 | |> Option.get
114 | |> List.iter (fun etag -> Eio.traceln "%s" (Etag.encode etag)) ;;
115 | +W/"xyzzy"
116 | +W/"r2d2xxxx"
117 | +W/"c3piozzzz"
118 | - : unit = ()
119 | ```
120 |
121 | Decode a list of weak and strong etag values.
122 |
123 | ```ocaml
124 | # let t5 = If_none_match.decode {|"xyzzy", W/"r2d2xxxx", "c3piozzz", W/"c3piozzzz"|};;
125 | val t5 : If_none_match.t =
126 |
127 | # If_none_match.entity_tags t5
128 | |> Option.get
129 | |> List.iter (fun etag -> Eio.traceln "%s" (Etag.encode etag)) ;;
130 | +"xyzzy"
131 | +W/"r2d2xxxx"
132 | +"c3piozzz"
133 | +W/"c3piozzzz"
134 | - : unit = ()
135 | ```
136 |
137 | Decode '*'.
138 |
139 | ```ocaml
140 | # let any1 = If_none_match.decode "*";;
141 | val any1 : If_none_match.t =
142 |
143 | # If_none_match.is_any any1;;
144 | - : bool = true
145 | ```
146 |
147 | Invalid values.
148 |
149 | ```ocaml
150 | # If_none_match.decode "**";;
151 | Exception: Invalid_argument "[s] contains invalid [If-None-Match] value".
152 |
153 | # If_none_match.decode {| "xyzzy",|};;
154 | Exception: Invalid_argument "[v] contains invalid ETag value".
155 | ```
156 |
157 | ## encode
158 |
159 | ```ocaml
160 | # If_none_match.encode any;;
161 | - : string = "*"
162 |
163 | # If_none_match.encode any1;;
164 | - : string = "*"
165 |
166 | # If_none_match.encode t1;;
167 | - : string = "\"c3piozzzz\""
168 |
169 | # If_none_match.encode t2;;
170 | - : string = "W/\"xyzzy\""
171 |
172 | # If_none_match.encode t3;;
173 | - : string = "\"xyzzy\", \"r2d2xxxx\", \"c3piozzzz\""
174 |
175 | # If_none_match.encode t4;;
176 | - : string = "W/\"xyzzy\", W/\"r2d2xxxx\", W/\"c3piozzzz\""
177 |
178 | # If_none_match.encode t5;;
179 | - : string = "\"xyzzy\", W/\"r2d2xxxx\", \"c3piozzz\", W/\"c3piozzzz\""
180 | ```
181 |
--------------------------------------------------------------------------------
/test/method.md:
--------------------------------------------------------------------------------
1 | ## Method tests
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | ### Method.equal
8 |
9 | ```ocaml
10 | # Method.(equal get get) ;;
11 | - : bool = true
12 |
13 | # Method.(equal get post) ;;
14 | - : bool = false
15 | ```
16 |
17 | ### Method.make
18 |
19 | ```ocaml
20 | # let lock = Method.make "lock" ;;
21 | val lock : Method.t = "lock"
22 |
23 | # let a = Method.make "get" ;;
24 | val a : Method.t = "get"
25 |
26 | # Method.(equal a get);;
27 | - : bool = true
28 | ```
29 |
30 | ## Method.to_string
31 |
32 | ```ocaml
33 | # let m = Method.(to_string get) ;;
34 | val m : Method.t = "get"
35 |
36 | # String.equal "get" (m :> string) ;;
37 | - : bool = true
38 | ```
39 |
--------------------------------------------------------------------------------
/test/multipart.md:
--------------------------------------------------------------------------------
1 | # Multipart tests
2 |
3 | ```ocaml
4 | open Spring
5 |
6 | let body content_type_hdr txt =
7 | let headers = Headers.of_list ["content-type", content_type_hdr] in
8 | let buf_read = Eio.Buf_read.of_string txt in
9 | Body.make_readable headers buf_read
10 | ;;
11 |
12 | let body_txt1 ="--AaB03x\r\nContent-Disposition: form-data; name=\"submit-name\"\r\n\r\nLarry\r\n--AaB03x\r\nContent-Disposition: form-data; name=\"files\"; filename=\"file1.txt\"\r\nContent-Type: text/plain\r\n\r\n... contents of file1.txt ...\r\n--AaB03x--"
13 | ```
14 |
15 | ## Multipart.stream
16 |
17 | ```ocaml
18 | # let rdr = Multipart.stream (body "multipart/form-data" body_txt1);;
19 | Exception: Invalid_argument "body: boundary value not found".
20 |
21 | # let rdr = Multipart.stream (body "multipart/form-data; boundary=AaB03x" body_txt1);;
22 | val rdr : Multipart.stream =
23 | ```
24 |
25 | ## Multipart.boundary
26 |
27 | ```ocaml
28 | # Multipart.boundary rdr;;
29 | - : string = "AaB03x"
30 | ```
31 |
32 | ## Multipart.next_part/read_all
33 |
34 | ```ocaml
35 | # let p = Multipart.next_part rdr;;
36 | val p : Multipart.stream Multipart.part =
37 |
38 | # Multipart.file_name p ;;
39 | - : string option = None
40 |
41 | # Multipart.form_name p ;;
42 | - : string = "submit-name"
43 |
44 | # Multipart.headers p |> (Eio.traceln "%a" Headers.pp) ;;
45 | +[
46 | + Content-Disposition: form-data; name="submit-name"
47 | +]
48 | - : unit = ()
49 |
50 | # Multipart.read_all p;;
51 | - : string = "Larry"
52 |
53 | # Eio.Flow.single_read (Multipart.as_flow p) (Cstruct.create 10) ;;
54 | Exception: End_of_file.
55 |
56 | # let p2 = Multipart.next_part rdr;;
57 | val p2 : Multipart.stream Multipart.part =
58 |
59 | # Multipart.file_name p2;;
60 | - : string option = Some "file1.txt"
61 |
62 | # Multipart.form_name p2;;
63 | - : string = "files"
64 |
65 | # Multipart.read_all p2;;
66 | - : string = "... contents of file1.txt ..."
67 |
68 | # Multipart.read_all p2;;
69 | - : string = ""
70 |
71 | # Eio.Flow.single_read (Multipart.as_flow p2) (Cstruct.create 10) ;;
72 | Exception: End_of_file.
73 |
74 | # Multipart.next_part rdr;;
75 | Exception: End_of_file.
76 | ```
77 |
78 | ## Multipart.form
79 |
80 | ```ocaml
81 | # let form = Multipart.form (body "multipart/form-data; boundary=AaB03x" body_txt1);;
82 | val form : Multipart.form =
83 |
84 | # Multipart.find_value_field "submit-name" form ;;
85 | - : string option = Some "Larry"
86 |
87 | # let form_field1 = Multipart.find_file_field "files" form |> Option.get ;;
88 | val form_field1 : Multipart.file_field =
89 |
90 | # Multipart.file_name form_field1 ;;
91 | - : string option = Some "file1.txt"
92 |
93 | # Multipart.file_content form_field1;;
94 | - : string = "... contents of file1.txt ..."
95 |
96 | # Eio.traceln "%a" Headers.pp @@ Multipart.headers form_field1;;
97 | +[
98 | + Content-Disposition: form-data; name="files"; filename="file1.txt";
99 | + Content-Type: text/plain
100 | +]
101 | - : unit = ()
102 | ```
103 |
104 | ## Multipart.writable
105 |
106 | A `Buffer.t` sink to test `Body.writer`.
107 |
108 | ```ocaml
109 | let test_writable f =
110 | Eio_main.run @@ fun env ->
111 | let b = Buffer.create 10 in
112 | let s = Eio.Flow.buffer_sink b in
113 | let body = f () in
114 | Eio.Buf_write.with_flow s (fun bw ->
115 | Body.write_headers bw body;
116 | Eio.Buf_write.string bw "\r\n";
117 | Body.write_body bw body;
118 | );
119 | Eio.traceln "%s" (Buffer.contents b);;
120 | ```
121 |
122 | Writable with 2 parts.
123 |
124 | ```ocaml
125 | # let p1 = Multipart.writable_file_part ~filename:"a.txt" ~form_name:"file" (Eio.Flow.string_source "content of a.txt");;
126 | val p1 : Multipart.writable Multipart.part =
127 |
128 | # let p2 = Multipart.writable_value_part ~form_name:"detail" ~value:"file is a text file.";;
129 | val p2 : Multipart.writable Multipart.part =
130 |
131 | # test_writable @@ fun () -> Multipart.writable ~boundary:"--A1B2C3" [p1;p2];;
132 | +Content-Length: 190
133 | +Content-Type: multipart/formdata; boundary=--A1B2C3
134 | +
135 | +----A1B2C3
136 | +Content-Disposition: form-data; filename="a.txt"; name="file"
137 | +
138 | +content of a.txt
139 | +----A1B2C3
140 | +Content-Disposition: form-data; name="detail"
141 | +
142 | +file is a text file.
143 | +----A1B2C3--
144 | - : unit = ()
145 | ```
146 |
147 | Writable with only one part.
148 |
149 | ```ocaml
150 | # let p1 = Multipart.writable_file_part ~filename:"a.txt" ~form_name:"file" (Eio.Flow.string_source "content of a.txt");;
151 | val p1 : Multipart.writable Multipart.part =
152 |
153 | # test_writable @@ fun () -> Multipart.writable ~boundary:"--A1B2C3" [p1];;
154 | +Content-Length: 107
155 | +Content-Type: multipart/formdata; boundary=--A1B2C3
156 | +
157 | +----A1B2C3
158 | +Content-Disposition: form-data; filename="a.txt"; name="file"
159 | +
160 | +content of a.txt
161 | +----A1B2C3--
162 | - : unit = ()
163 | ```
164 |
--------------------------------------------------------------------------------
/test/response.md:
--------------------------------------------------------------------------------
1 | # Response
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | ## Response.parse_client_response
8 |
9 | ```ocaml
10 | let make_buf_read () =
11 | Eio.Buf_read.of_string @@
12 | "HTTP/1.1 200 OK\r\n" ^
13 | "content-length: 13\r\n" ^
14 | "date: Wed, 08 Feb 2023 16:18:17 GMT\r\n" ^
15 | "content-type: text/html; charset=utf-8\r\n" ^
16 | "x-powered-by: Express\r\n" ^
17 | "cache-control: public, max-age=86400\r\n" ^
18 | "cf-cache-status: DYNAMIC\r\n" ^
19 | "server: cloudflare\r\n" ^
20 | "cf-ray: 7965ae27fa7c75bf-LHR\r\n" ^
21 | "content-encoding: br\r\n" ^
22 | "X-Firefox-Spdy: h2\r\n" ^
23 | "\r\n" ^
24 | "hello, world!"
25 | ;;
26 | ```
27 |
28 | ```ocaml
29 | # let res = Response.parse_client_response @@ make_buf_read () ;;
30 | val res : Response.client Response.t =
31 |
32 | # Eio.traceln "%a" Headers.pp @@ Response.headers res ;;
33 | +[
34 | + Content-Length: 13;
35 | + Date: Wed, 08 Feb 2023 16:18:17 GMT;
36 | + Content-Type: text/html; charset=utf-8;
37 | + X-Powered-By: Express;
38 | + Cache-Control: public, max-age=86400;
39 | + Cf-Cache-Status: DYNAMIC;
40 | + Server: cloudflare;
41 | + Cf-Ray: 7965ae27fa7c75bf-LHR;
42 | + Content-Encoding: br;
43 | + X-Firefox-Spdy: h2
44 | +]
45 | - : unit = ()
46 | ```
47 |
48 | ## server_response
49 |
50 | A `Buffer.t` sink to test `Body.writer`.
51 |
52 | ```ocaml
53 | let test_server_response r =
54 | Eio_main.run @@ fun env ->
55 | let b = Buffer.create 10 in
56 | let s = Eio.Flow.buffer_sink b in
57 | Eio.Buf_write.with_flow s (fun bw ->
58 | Response.write_server_response bw r;
59 | );
60 | Eio.traceln "%s" (Buffer.contents b);;
61 | ```
62 |
63 | ## Response.text
64 |
65 | ```ocaml
66 | # test_server_response @@ Response.text "hello, world";;
67 | +HTTP/1.1 200 OK
68 | +Content-Length: 12
69 | +Content-Type: text/plain; charset=uf-8
70 | +
71 | +hello, world
72 | - : unit = ()
73 | ```
74 |
75 | ## Response.html
76 |
77 | ```ocaml
78 | # test_server_response @@ Response.html "hello, world";;
79 | +HTTP/1.1 200 OK
80 | +Content-Length: 12
81 | +Content-Type: text/html; charset=uf-8
82 | +
83 | +hello, world
84 | - : unit = ()
85 | ```
86 |
87 | ## Response.not_found
88 |
89 | ```ocaml
90 | # test_server_response @@ Response.not_found ;;
91 | +HTTP/1.1 404 Not Found
92 | +Content-Length: 0
93 | +
94 | +
95 | - : unit = ()
96 | ```
97 |
98 | ## Response.internal_server_error
99 |
100 | ```ocaml
101 | # test_server_response @@ Response.internal_server_error ;;
102 | +HTTP/1.1 500 Internal Server Error
103 | +Content-Length: 0
104 | +
105 | +
106 | - : unit = ()
107 | ```
108 |
109 | ## Response.bad_request
110 |
111 | ```ocaml
112 | # test_server_response @@ Response.bad_request ;;
113 | +HTTP/1.1 400 Bad Request
114 | +Content-Length: 0
115 | +
116 | +
117 | - : unit = ()
118 | ```
119 |
120 | ## Response.chunked_response
121 |
122 | ```ocaml
123 | # let write_chunk f =
124 | f @@ Chunked.make ~extensions:["ext1",Some "ext1_v"] "Hello, ";
125 | f @@ Chunked.make ~extensions:["ext2",None] "world!";
126 | f @@ Chunked.make "Again!";
127 | f @@ Chunked.make "";;
128 | val write_chunk : (Chunked.t -> 'a) -> 'a =
129 |
130 | # let write_trailer f =
131 | let trailer_headers =
132 | Headers.of_list
133 | [
134 | ("Expires", "Wed, 21 Oct 2015 07:28:00 GMT");
135 | ("Header1", "Header1 value text");
136 | ("Header2", "Header2 value text");
137 | ]
138 | in
139 | f trailer_headers;;
140 | val write_trailer : (Headers.t -> 'a) -> 'a =
141 | ```
142 |
143 | Writes chunked response trailer headers.
144 |
145 | ```ocaml
146 | # test_server_response @@ Response.chunked_response ~ua_supports_trailer:true write_chunk write_trailer ;;
147 | +HTTP/1.1 200 OK
148 | +Transfer-Encoding: chunked
149 | +
150 | +7;ext1=ext1_v
151 | +Hello,
152 | +6;ext2
153 | +world!
154 | +6
155 | +Again!
156 | +0
157 | +Expires: Wed, 21 Oct 2015 07:28:00 GMT
158 | +Header1: Header1 value text
159 | +Header2: Header2 value text
160 | +
161 | +
162 | - : unit = ()
163 | ```
164 |
165 | No chunked trailer headers.
166 |
167 | ```ocaml
168 | # test_server_response @@ Response.chunked_response ~ua_supports_trailer:false write_chunk write_trailer ;;
169 | +HTTP/1.1 200 OK
170 | +Transfer-Encoding: chunked
171 | +
172 | +7;ext1=ext1_v
173 | +Hello,
174 | +6;ext2
175 | +world!
176 | +6
177 | +Again!
178 | +0
179 | +
180 | +
181 | - : unit = ()
182 | ```
183 |
184 | ## Response.add_set_cookie
185 |
186 | ```ocaml
187 | # let txt_response = Response.html "hello, world" ;;
188 | val txt_response : Response.server Response.t =
189 | ```
190 |
191 | ```ocaml
192 | # let id_cookie =
193 | Set_cookie.make ~name:"ID" "1234"
194 | |> Set_cookie.(add secure)
195 | |> Set_cookie.(add http_only);;
196 | val id_cookie : Set_cookie.t =
197 |
198 | # let res = Response.add_set_cookie id_cookie txt_response ;;
199 | val res : Response.server Response.t =
200 |
201 | # test_server_response res;;
202 | +HTTP/1.1 200 OK
203 | +Content-Length: 12
204 | +Content-Type: text/html; charset=uf-8
205 | +Set-Cookie: ID=1234; Httponly; Secure
206 | +
207 | +hello, world
208 | - : unit = ()
209 | ```
210 |
211 | ## Response.find_set_cookie
212 |
213 | ```ocaml
214 | # Response.find_set_cookie "ID" res |> Option.iter (Eio.traceln "%a" Set_cookie.pp) ;;
215 | +{
216 | + Name : 'ID' ;
217 | + Value : '1234' ;
218 | + Httponly ;
219 | + Secure ;
220 | +}
221 | - : unit = ()
222 | ```
223 |
224 | ## Response.remove_set_cookie
225 |
226 | ```ocaml
227 | # let res = Response.remove_set_cookie "ID" res;;
228 | val res : Response.server Response.t =
229 |
230 | # Response.find_set_cookie "ID" res ;;
231 | - : Set_cookie.t option = None
232 | ```
233 |
--------------------------------------------------------------------------------
/test/router.md:
--------------------------------------------------------------------------------
1 | # Router tests
2 |
3 | ```ocaml
4 | open Router_test
5 | open Spring
6 |
7 | let () = Printexc.record_backtrace true
8 | let test_get uri = Router.match' (make_request Method.get uri) router
9 | let test_head uri = Router.match' (make_request Method.head uri) router
10 | let test_post uri = Router.match' (make_request Method.post uri) router
11 | let test_delete uri = Router.match' (make_request Method.delete uri) router
12 |
13 | let fmt = Format.std_formatter
14 | ```
15 |
16 | ```ocaml
17 | # test_get "/public/css/style.css";;
18 | - : string option = Some "file path: css/style.css"
19 |
20 | # test_get "/public/js/prog.js";;
21 | - : string option = Some "file path: js/prog.js"
22 |
23 | # test_get "/public/images/image1.jpg";;
24 | - : string option = Some "file path: images/image1.jpg"
25 |
26 | # test_get "/public/";;
27 | - : string option = Some "file path: "
28 |
29 | # test_get "/home/100001.1/";
30 | - : string option = Some "Float page. number : 100001.100000"
31 |
32 | # test_post "/home/100001.1";;
33 | - : string option = None
34 |
35 | # test_head "/home/100001/";;
36 | - : string option = Some "Product Page. Product Id : 100001"
37 |
38 | # test_post "/home/about";;
39 | - : string option = None
40 |
41 | # test_get "/home/about/1";;
42 | - : string option = Some "about_page - 1"
43 |
44 | # test_post "/home/about/3";;
45 | - : string option = Some "about_page - 3"
46 |
47 | # test_head "/home/about/3";;
48 | - : string option = None
49 |
50 | # test_delete "/home/about/3";;
51 | - : string option = None
52 |
53 | # test_get "/contact/bikal/123456";;
54 | - : string option = Some "Contact page. Hi, bikal. Number 123456"
55 |
56 | # test_post "/home/products/asdfasdf?a=1&b=2";;
57 | - : string option = Some "full rest page: asdfasdf?a=1&b=2"
58 |
59 | # test_post "/home/products/product1/locate";;
60 | - : string option = Some "full rest page: product1/locate"
61 |
62 | # test_get "/home/product1/";;
63 | - : string option = Some "Wildcard page. product1. Remaining url: "
64 |
65 | # test_get "/contact/bikal/true";;
66 | - : string option = Some "Contact Page2. Name - bikal, number - true"
67 |
68 | # test_get "/contact/bob/false";;
69 | - : string option = Some "Contact Page2. Name - bob, number - false"
70 |
71 | # test_post "/product/dyson350?section=233&q=true";;
72 | - : string option =
73 | Some "Product detail - dyson350. Section: 233. Display questions? true"
74 |
75 | # test_post "/product/dyson350?section=2&q=false";;
76 | - : string option =
77 | Some "Product detail - dyson350. Section: 2. Display questions? false"
78 |
79 | # test_get "/product/dyson350?section=2&q1=no";;
80 | - : string option = None
81 |
82 | # test_get "/product/dyson350?section=2&q1=yes";;
83 | - : string option = Some "Product detail 2 - dyson350. Section: 2."
84 |
85 | # test_get "/product/dyson350/section/2/q1/yes";;
86 | - : string option = None
87 |
88 | # test_get "/fruit/apple";;
89 | - : string option = Some "Apples are juicy!"
90 |
91 | # test_get "/fruit/pineapple";;
92 | - : string option = Some "Pineapple has scaly skin"
93 |
94 | # test_get "/fruit/orange";;
95 | - : string option = Some "Orange is a citrus fruit."
96 |
97 | # test_get "/fruit/guava";;
98 | - : string option = None
99 |
100 | # test_get "/";
101 | - : string option = Some "Root page"
102 |
103 | # test_head "/numbers/23/code/6888/";;
104 | - : string option = Some "int32: 23, int64: 6888."
105 |
106 | # test_head "/numbers/23.01/code/6888/";;
107 | - : string option = None
108 |
109 | # test_head "/numbers/23/code/6888.222/";;
110 | - : string option = None
111 | ```
112 |
113 | ## Router.pp_route
114 |
115 | ```ocaml
116 | # Router.pp_route fmt route1;;
117 | GET/home/about/:bool?h=:int&b=:bool&e=hello
118 | - : unit = ()
119 |
120 | # Router.pp_route fmt route2;;
121 | POST/home/about/:int/:string/:Fruit
122 | - : unit = ()
123 |
124 | # Router.pp_route fmt route3;;
125 | HEAD/home/:int/:int32/:int64/:Fruit?q1=hello&f=:Fruit&b=:bool&f=:float
126 | - : unit = ()
127 | ```
128 |
129 | ## Router.pp
130 |
131 | ```ocaml
132 | # Format.fprintf fmt "%a%!" Router.pp router;;
133 | GET
134 | /home
135 | /about
136 | /:int
137 | /:float
138 | /
139 | /:string
140 | /**
141 | /contact
142 | /:string
143 | /:int
144 | /:bool
145 | /product
146 | /:string
147 | ?section=:int
148 | &q1=yes
149 | ?section=:string
150 | &q1=yes
151 | /fruit
152 | /:Fruit
153 | /
154 | /public
155 | /**
156 | POST
157 | /home
158 | /about
159 | /:int
160 | /products
161 | /**
162 | /product
163 | /:string
164 | ?section=:int
165 | &q=:bool
166 | HEAD
167 | /home
168 | /:int
169 | /
170 | /numbers
171 | /:int32
172 | /code
173 | /:int64
174 | /
175 | DELETE
176 | /home
177 | /:int
178 | /
179 | - : unit = ()
180 | ```
181 |
182 | ## Router.match' - match the top 1 first if more than one route is matched
183 |
184 | ```ocaml
185 | # Router_test.top_1_first () ;;
186 | - : string option = Some "Float: 12.000000"
187 |
188 | # Router_test.top_1_first_2 ();;
189 | - : string option = Some "Int : 12"
190 | ```
191 |
192 | ## Router.match' - longest match wins if more than one route is matched
193 |
194 | ```ocaml
195 | # Router_test.longest_match ();;
196 | - : string option = Some "longest: 12"
197 | ```
198 |
--------------------------------------------------------------------------------
/test/router_test.ml:
--------------------------------------------------------------------------------
1 | open Spring
2 |
3 | module Fruit = struct
4 | type t =
5 | | Apple
6 | | Orange
7 | | Pineapple
8 |
9 | let t : t Router.arg =
10 | Router.make_arg "Fruit" (function
11 | | "apple" -> Some Apple
12 | | "orange" -> Some Orange
13 | | "pineapple" -> Some Pineapple
14 | | _ -> None)
15 | end
16 |
17 | type request = Request.server Request.t
18 |
19 | let fruit_page fruit (_req : request) =
20 | match fruit with
21 | | Fruit.Apple -> Printf.sprintf "Apples are juicy!"
22 | | Orange -> Printf.sprintf "Orange is a citrus fruit."
23 | | Pineapple -> Printf.sprintf "Pineapple has scaly skin"
24 |
25 | let about_page i (_req : request) = Format.sprintf "about_page - %d" i
26 |
27 | let full_rest_page url _req = Format.sprintf "full rest page: %s" url
28 |
29 | let home_int_page i (_req : request) =
30 | Printf.sprintf "Product Page. Product Id : %d" i
31 |
32 | let home_float_page f _req = Printf.sprintf "Float page. number : %f" f
33 |
34 | let wildcard_page s url _req =
35 | Printf.sprintf "Wildcard page. %s. Remaining url: %s" s url
36 |
37 | let numbers_page id code _req = Printf.sprintf "int32: %ld, int64: %Ld." id code
38 |
39 | let root_page (_req : request) = "Root page"
40 |
41 | let contact_page name number _req =
42 | Printf.sprintf "Contact page. Hi, %s. Number %i" name number
43 |
44 | let contact_page2 name call_me_later _req =
45 | Printf.sprintf "Contact Page2. Name - %s, number - %b" name call_me_later
46 |
47 | let product_page name section_id q _req =
48 | Printf.sprintf "Product detail - %s. Section: %d. Display questions? %b" name
49 | section_id q
50 |
51 | let product_page2 name section_id _req =
52 | Printf.sprintf "Product detail 2 - %s. Section: %d." name section_id
53 |
54 | let product_page3 name section_id _req =
55 | Printf.sprintf "Product detail 2 - %s. Section: %s." name section_id
56 |
57 | let public url _req = Format.sprintf "file path: %s" url
58 |
59 | let router =
60 | Router.(
61 | make
62 | [ route Method.get [%r "/home/about/:int"] about_page
63 | ; route Method.post [%r "/home/about/:int"] about_page
64 | ; route Method.head [%r "/home/:int/"] home_int_page
65 | ; route Method.delete [%r "/home/:int/"] home_int_page
66 | ; route Method.get [%r "/home/:float/"] home_float_page
67 | ; route Method.get [%r "/contact/*/:int"] contact_page
68 | ; route Method.post [%r "/home/products/**"] full_rest_page
69 | ; route Method.get [%r "/home/*/**"] wildcard_page
70 | ; route Method.get [%r "/contact/:string/:bool"] contact_page2
71 | ; route Method.post [%r "/product/:string?section=:int&q=:bool"]
72 | product_page
73 | ; route Method.get [%r "/product/:string?section=:int&q1=yes"]
74 | product_page2
75 | ; route Method.get [%r "/product/:string?section=:string&q1=yes"]
76 | product_page3
77 | ; route Method.get [%r "/fruit/:Fruit"] fruit_page
78 | ; route Method.get [%r "/"] root_page
79 | ; route Method.get [%r "/public/**"] public
80 | ; route Method.head [%r "/numbers/:int32/code/:int64/"] numbers_page
81 | ])
82 |
83 | let pp_route r = List.hd r |> Router.pp_route Format.std_formatter
84 |
85 | let pp_match req = Router.match' req router
86 |
87 | let route1 =
88 | Router.route Method.get {%r|/home/about/:bool?h=:int&b=:bool&e=hello|}
89 | (fun _ _ _ _ -> ())
90 |
91 | let route2 =
92 | Router.route Method.post {%r|/home/about/:int/:string/:Fruit|} (fun _ _ _ _ ->
93 | ())
94 |
95 | let route3 =
96 | Router.route Method.head
97 | {%r|/home/:int/:int32/:int64/:Fruit?q1=hello&f=:Fruit&b=:bool&f=:float |}
98 | (fun _ _ _ _ _ _ _ _ -> ())
99 |
100 | let make_request meth resource : request =
101 | let client_addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, 8080) in
102 | Request.make_server_request ~resource meth client_addr
103 | (Eio.Buf_read.of_string "")
104 |
105 | let get = Method.get
106 |
107 | let top_1_first () =
108 | Router.add get [%r "/home/:float"]
109 | (fun f _req -> Format.sprintf "Float: %f" f)
110 | Router.empty
111 | |> Router.add get [%r "/home/:int"] (fun i _req ->
112 | Format.sprintf "Int : %d" i)
113 | |> Router.match' @@ make_request Method.get "/home/12"
114 |
115 | let top_1_first_2 () =
116 | Router.add get [%r "/home/:int"]
117 | (fun i _req -> Format.sprintf "Int : %d" i)
118 | Router.empty
119 | |> Router.add get [%r "/home/:float"] (fun f _req ->
120 | Format.sprintf "Float: %f" f)
121 | |> Router.match' @@ make_request Method.get "/home/12"
122 |
123 | let longest_match () =
124 | Router.add get [%r "/home/:int"]
125 | (fun i _req -> Format.sprintf "Int : %d" i)
126 | Router.empty
127 | |> Router.add get [%r "/home/:int/:string"] (fun i _ _req ->
128 | Format.sprintf "longest: %i" i)
129 | |> Router.match' @@ make_request Method.get "/home/12/hello"
130 |
--------------------------------------------------------------------------------
/test/server.md:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/bikallem/spring/6ca384b78b4f647c5cb5caa064cb27d2c997f04b/test/server.md
--------------------------------------------------------------------------------
/test/session.md:
--------------------------------------------------------------------------------
1 | # Session unit tests
2 |
3 | ```ocaml
4 | open Spring
5 |
6 | let key = Base64.(decode_exn ~pad:false "knFR+ybPVw/DJoOn+e6vpNNU2Ip2Z3fj1sXMgEyWYhA")
7 | let nonce = Cstruct.of_string "aaaaaaaaaaaa"
8 | ```
9 |
10 | ## Session.cookie_codec/encode/decode
11 |
12 | ```ocaml
13 | # let t = Session.cookie_codec key ;;
14 | val t : Session.codec =
15 |
16 | # let session_data =
17 | Session.Data.(
18 | add "a" "a_val" empty
19 | |> add "b" "b_val");;
20 | val session_data : string Session.Data.t =
21 |
22 | # Session.Data.find_opt "a" session_data;;
23 | - : string option = Some "a_val"
24 |
25 | # Session.Data.find_opt "b" session_data;;
26 | - : string option = Some "b_val"
27 |
28 | # let data = Session.encode ~nonce session_data t;;
29 | val data : string =
30 | "YWFhYWFhYWFhYWFhYHOdvSHL4fyIGWh0ayUSVBXbIUXq5NdJtENq4iTIX1doh_MkW46wor8-"
31 |
32 | # let t1 = Session.decode data t;;
33 | val t1 : Session.session_data =
34 |
35 | # Session.Data.find_opt "a" t1;;
36 | - : string option = Some "a_val"
37 |
38 | # Session.Data.find_opt "b" t1;;
39 | - : string option = Some "b_val"
40 | ```
41 |
--------------------------------------------------------------------------------
/test/status.md:
--------------------------------------------------------------------------------
1 | ## Status tests
2 |
3 | ```ocaml
4 | # open Spring
5 | ```
6 |
7 | ### Status.make
8 |
9 | ```ocaml
10 | # let s = Status.make (-1) "asdf";;
11 | Exception: Failure "code: -1 is negative".
12 |
13 | # let s = Status.make 0 "asdasdf";;
14 | Exception: Failure "code: 0 is not a three-digit number".
15 |
16 | # let s = Status.make 1000 "dddd";;
17 | Exception: Failure "code: 1000 is not a three-digit number".
18 |
19 | # let s = Status.make 499 "Client Closed Request";;
20 | val s : Status.t = (499, "Client Closed Request")
21 | ```
22 |
23 | ### Status.equal
24 |
25 | ```ocaml
26 | # Status.(equal ok ok);;
27 | - : bool = true
28 |
29 | # Status.(equal ok created) ;;
30 | - : bool = false
31 | ```
32 |
33 | ### Status.pp
34 |
35 | ```ocaml
36 | # Status.(to_string ok);;
37 | - : string = "200 OK"
38 | ```
39 |
--------------------------------------------------------------------------------
/test/te.md:
--------------------------------------------------------------------------------
1 | ## Te tests
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | ### Te.decode, equal
8 |
9 | ```ocaml
10 | # let t = Te.decode "trailers, deflate;q=0.5, gzip";;
11 | val t : Te.t =
12 |
13 | # Te.(exists t trailers);;
14 | - : bool = true
15 |
16 | # Te.(exists t deflate);;
17 | - : bool = true
18 |
19 | # Te.(exists t gzip);;
20 | - : bool = true
21 |
22 | # Te.(get_q t gzip);;
23 | - : string option = None
24 |
25 | # Te.(get_q t deflate);;
26 | - : string option = Some "0.5"
27 | ```
28 |
29 | ### Te.encode
30 |
31 | ```ocaml
32 | # Te.encode t;;
33 | - : string = "trailers, deflate;q=0.5, gzip"
34 | ```
35 |
36 | ### Te.remove
37 |
38 | ```ocaml
39 | # let t = Te.(remove t gzip);;
40 | val t : Te.t =
41 |
42 | # Te.encode t;;
43 | - : string = "trailers, deflate;q=0.5"
44 | ```
45 |
46 | ### Te.singleton
47 |
48 | ```ocaml
49 | # let t = Te.(singleton trailers);;
50 | val t : Te.t =
51 |
52 | # Te.(exists t trailers);;
53 | - : bool = true
54 | ```
55 |
--------------------------------------------------------------------------------
/test/transfer_encoding.md:
--------------------------------------------------------------------------------
1 | # Transfer_encoding tests
2 |
3 | ```ocaml
4 | open Spring
5 | ```
6 |
7 | ## Transfer_encoding.decode
8 |
9 | ```ocaml
10 | # let t = Transfer_encoding.decode "gzip, chunked";;
11 | val t : Transfer_encoding.t =
12 |
13 | # Transfer_encoding.(exists t chunked);;
14 | - : bool = true
15 |
16 | # Transfer_encoding.(exists t gzip);;
17 | - : bool = true
18 |
19 | # let t1 = Transfer_encoding.decode "chunked";;
20 | val t1 : Transfer_encoding.t =
21 |
22 | # Transfer_encoding.(exists t1 chunked);;
23 | - : bool = true
24 |
25 | # Transfer_encoding.(exists t1 gzip);;
26 | - : bool = false
27 | ```
28 |
29 | ## Transfer_encoding.remove
30 |
31 | ```ocaml
32 | # let t2 = Transfer_encoding.(remove t gzip) ;;
33 | val t2 : Transfer_encoding.t =
34 |
35 | # Transfer_encoding.(exists t2 gzip)
36 | - : bool = false
37 |
38 | # Transfer_encoding.(exists t2 chunked);;
39 | - : bool = true
40 | ```
41 |
42 | ## Transfer_encoding.encode
43 |
44 | ```ocaml
45 | # Transfer_encoding.encode t;;
46 | - : string = "gzip, chunked"
47 |
48 | # Transfer_encoding.encode t1;;
49 | - : string = "chunked"
50 |
51 | # Transfer_encoding.encode t2;;
52 | - : string = "chunked"
53 | ```
54 |
55 | ## Transfer_encoding.singleon
56 |
57 | ```ocaml
58 | # let t = Transfer_encoding.(singleton chunked);;
59 | val t : Transfer_encoding.t =
60 |
61 | # Transfer_encoding.(exists t chunked) ;;
62 | - : bool = true
63 | ```
64 |
--------------------------------------------------------------------------------
/test/version.md:
--------------------------------------------------------------------------------
1 | # Version tests
2 |
3 | ```ocaml
4 | open Spring
5 | open Eio
6 | ```
7 |
8 | ## Version.parser
9 |
10 | ```ocaml
11 | # let r = Buf_read.of_string "HTTP/1.1";;
12 | val r : Buf_read.t =
13 |
14 | # Version.parse r;;
15 | - : Version.t = (1, 1)
16 |
17 | # Version.parse (Buf_read.of_string "HTTP/1.0");;
18 | - : Version.t = (1, 0)
19 | ```
20 |
--------------------------------------------------------------------------------