rename to lib/
This commit is contained in:
parent
a774ea11ac
commit
7198d3f0f4
9 changed files with 27 additions and 22 deletions
|
|
@ -1,90 +0,0 @@
|
|||
(* TODO
|
||||
have safe amount arithmetic
|
||||
make type private
|
||||
redefine an Amount module with currency enforced to be Config.currency? *)
|
||||
(* Amounts of currency, serialized as `<Currency>:<IntegerPart>.<FractionalPart>`
|
||||
Fixed-precision numbers with 8 decimal places.
|
||||
- <Currency> must be at most 11 characters long
|
||||
only consist of ASCII letters (a-zA-Z).
|
||||
- integer part of <DecimalAmount> may be at most 2^52.
|
||||
- fractional part of <DecimalAmount> may contain at most 8 decimal digits.
|
||||
|
||||
Prefixed with '+' or '-' in certain contexts.
|
||||
When no sign is present, the amount is assumed to be positive. *)
|
||||
type sign =
|
||||
| Sign_plus
|
||||
| Sign_minus
|
||||
|
||||
type t = {
|
||||
sign: sign option;
|
||||
currency: string;
|
||||
value: Int64.t;
|
||||
fraction: Int32.t;
|
||||
}
|
||||
|
||||
let ( let* ) o f = match o with Ok v -> f v | Error _ as e -> e
|
||||
let check_not msg = function false -> Ok () | true -> Error msg
|
||||
let value_upper_bound = Z.(pow (of_int 2) 52) |> Z.to_int64
|
||||
let fraction_upper_bound = Int32.of_int 100_000_000
|
||||
|
||||
let make ~sign ~currency ~value ~fraction =
|
||||
let* () = check_not "value is negative" (value < Int64.zero) in
|
||||
let* () = check_not "fraction is negative" (fraction < Int32.zero) in
|
||||
let* () =
|
||||
check_not "value is greater than 2^52" (value > value_upper_bound)
|
||||
in
|
||||
let* () =
|
||||
check_not "fraction has more than 8 decimal digits"
|
||||
(fraction >= fraction_upper_bound)
|
||||
in
|
||||
Ok { sign; currency; value; fraction }
|
||||
|
||||
let pp =
|
||||
let open Fmt in
|
||||
let pp_sign ppf = function
|
||||
| Sign_plus -> char ppf '+'
|
||||
| Sign_minus -> char ppf '-'
|
||||
in
|
||||
fun ppf { sign; currency; value; fraction } ->
|
||||
pf ppf "%a%s:%Ld.%02ld" (Fmt.option pp_sign) sign currency value fraction
|
||||
|
||||
let to_string = Fmt.str "%a" pp
|
||||
|
||||
let of_string =
|
||||
let open Angstrom in
|
||||
let parse_sign =
|
||||
choice
|
||||
[
|
||||
char '+' *> return (Some Sign_plus);
|
||||
char '-' *> return (Some Sign_minus); return None;
|
||||
]
|
||||
in
|
||||
let parse_currency =
|
||||
(* TODO currency string constraint/format *)
|
||||
take_while1 (function
|
||||
| 'a' .. 'z' | 'A' .. 'Z' -> true
|
||||
| _ -> false)
|
||||
in
|
||||
let parse_int64 =
|
||||
take_while1 (function '0' .. '9' -> true | _ -> false)
|
||||
>>| Int64.of_string_opt
|
||||
>>= function
|
||||
| None -> fail "invalid integer"
|
||||
| Some n -> return n
|
||||
in
|
||||
let parse_int32 =
|
||||
take_while1 (function '0' .. '9' -> true | _ -> false)
|
||||
>>| Int32.of_string_opt
|
||||
>>= function
|
||||
| None -> fail "invalid integer"
|
||||
| Some n -> return n
|
||||
in
|
||||
let parse_t =
|
||||
lift4
|
||||
(fun sign currency value fraction ->
|
||||
make ~sign ~currency ~value ~fraction)
|
||||
parse_sign parse_currency
|
||||
(char ':' *> parse_int64)
|
||||
(char '.' *> parse_int32)
|
||||
in
|
||||
fun s -> parse_string ~consume:Consume.All parse_t s |> Result.join
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
type sign =
|
||||
| Sign_plus
|
||||
| Sign_minus
|
||||
|
||||
type t = private {
|
||||
sign: sign option;
|
||||
currency: string;
|
||||
value: Int64.t;
|
||||
fraction: Int32.t;
|
||||
}
|
||||
|
||||
val make :
|
||||
sign:sign option ->
|
||||
currency:string ->
|
||||
value:Int64.t ->
|
||||
fraction:Int32.t ->
|
||||
(t, string) result
|
||||
|
||||
val pp : Format.formatter -> t -> unit
|
||||
val to_string : t -> string
|
||||
val of_string : string -> (t, string) result
|
||||
28
src/b32.ml
28
src/b32.ml
|
|
@ -1,28 +0,0 @@
|
|||
(* TODO test *)
|
||||
(* Crockford's variant of Base32
|
||||
http://www.crockford.com/wrmg/base32.html
|
||||
except that:
|
||||
- 'U' is not excluded but also decodes to 'V'
|
||||
- '-' is not allowed
|
||||
- checksum is not allowed *)
|
||||
|
||||
(* 'I' 'L' 'O' 'U' excluded *)
|
||||
type t = string
|
||||
|
||||
let alphabet = Base32.make_alphabet "0123456789ABCDEFGHJKMNPQRSTVWXYZ"
|
||||
let encode s = Base32.encode_string ~alphabet s
|
||||
|
||||
let decode s =
|
||||
let s =
|
||||
String.map
|
||||
(fun c ->
|
||||
match Char.uppercase_ascii c with
|
||||
| 'O' -> '0'
|
||||
| 'I' | 'L' -> '1'
|
||||
| 'U' -> 'V'
|
||||
| c -> c)
|
||||
s
|
||||
in
|
||||
match Base32.decode ~alphabet ~off:0 ~len:(String.length s) s with
|
||||
| Error (`Msg e) -> Error e
|
||||
| Ok v -> Ok v
|
||||
14
src/dune
14
src/dune
|
|
@ -7,13 +7,13 @@
|
|||
(library
|
||||
(name mte)
|
||||
(wrapped false)
|
||||
(modules :standard \ mte b32 amount)
|
||||
(modules :standard \ mte)
|
||||
(libraries
|
||||
amount
|
||||
b32
|
||||
;
|
||||
include
|
||||
parse_config
|
||||
headers_lib
|
||||
;
|
||||
caqti
|
||||
caqti-miou
|
||||
|
|
@ -31,16 +31,6 @@
|
|||
cohttp
|
||||
ptime))
|
||||
|
||||
(library ; crockford base32
|
||||
(name b32)
|
||||
(modules b32)
|
||||
(libraries base32))
|
||||
|
||||
(library
|
||||
(name amount)
|
||||
(modules amount)
|
||||
(libraries angstrom fmt zarith))
|
||||
|
||||
(rule
|
||||
(target assets_crunch.ml)
|
||||
(deps
|
||||
|
|
|
|||
|
|
@ -1,86 +0,0 @@
|
|||
(* independent library for headers fields value *)
|
||||
|
||||
(* TODO - test - can still bypass this module and directly set Etag header, but
|
||||
its fine *)
|
||||
module Etag : sig
|
||||
(* module to parse etags header fields used by If-Match and If-None-Match
|
||||
headers
|
||||
|
||||
https://httpwg.org/specs/rfc9110.html#field.etag *)
|
||||
type t
|
||||
type header_value
|
||||
|
||||
val parse : string -> (header_value, string) result
|
||||
val of_crockford32 : string -> (t, string) result
|
||||
val to_raw_string : t -> string
|
||||
val to_field_value : t -> string
|
||||
val evaluate : t -> header_value -> bool
|
||||
end = struct
|
||||
(* raw etag *)
|
||||
type t = string
|
||||
|
||||
(* type for the value of header field *)
|
||||
type header_etag_item = {
|
||||
weak: bool;
|
||||
value: string;
|
||||
}
|
||||
|
||||
type header_value =
|
||||
| Any_etag
|
||||
| Etag_list of header_etag_item list
|
||||
|
||||
let pp_header_etag_item ppf { weak; value } =
|
||||
if weak then Fmt.pf ppf {|W/"%s"|} value else Fmt.pf ppf {|"%s"|} value
|
||||
|
||||
let to_raw_string t = t
|
||||
|
||||
let to_field_value t =
|
||||
(* always weak comparison for If-None-Match header *)
|
||||
let v = { weak= true; value= t } in
|
||||
Fmt.str "%a" pp_header_etag_item v
|
||||
|
||||
let is_valid_char c =
|
||||
let n = Char.code c in
|
||||
(n >= 0x21 && n <= 0x7E && n <> 0x22) || (n >= 0x80 && n <= 0xFF)
|
||||
|
||||
let has_valid_charset s = String.for_all is_valid_char s
|
||||
|
||||
let of_crockford32 s =
|
||||
match has_valid_charset s with
|
||||
| false -> Error "invalid etag"
|
||||
| true -> Ok s
|
||||
|
||||
let parse =
|
||||
let open Angstrom in
|
||||
let ws = skip_while (function ' ' -> true | _ -> false) in
|
||||
let quoted_string =
|
||||
char '"' *> take_till (fun c -> c = '"') <* char '"' >>= fun s ->
|
||||
if String.for_all is_valid_char s then return s
|
||||
else fail "found illegal char"
|
||||
in
|
||||
let item =
|
||||
ws
|
||||
*> lift2
|
||||
(fun weak value -> { weak; value })
|
||||
(option false (string "W/" *> return true))
|
||||
quoted_string
|
||||
<* ws
|
||||
in
|
||||
let comma = ws *> char ',' *> ws in
|
||||
let list_of_items = sep_by1 comma item in
|
||||
let parse_header_value =
|
||||
char '*' *> return Any_etag
|
||||
<|> (list_of_items >>| fun items -> Etag_list items)
|
||||
<* end_of_input
|
||||
in
|
||||
fun s ->
|
||||
match parse_string ~consume:Consume.All parse_header_value s with
|
||||
| Error e -> Fmt.error "invalid etag: %s" e
|
||||
| Ok v -> Ok v
|
||||
|
||||
let evaluate t header_value =
|
||||
match header_value with
|
||||
| Any_etag -> false
|
||||
| Etag_list l ->
|
||||
not @@ List.exists (fun { weak= _; value } -> String.equal t value) l
|
||||
end
|
||||
Loading…
Add table
Add a link
Reference in a new issue