JJ: Description from the destination commit:
rename JJ: Description from source commit: + rename
This commit is contained in:
parent
1e30753ba9
commit
adb08524af
160 changed files with 18460 additions and 90 deletions
|
|
@ -1,232 +0,0 @@
|
|||
(* rudimentary configuration file parser (INI-like)
|
||||
https://docs.taler.net/manpages/taler-exchange.conf.5.html
|
||||
|
||||
do not support "$"-path expansion *)
|
||||
|
||||
open Angstrom
|
||||
|
||||
type item = {
|
||||
key: string;
|
||||
value: string;
|
||||
}
|
||||
|
||||
type section = {
|
||||
header: string;
|
||||
items: item list;
|
||||
}
|
||||
|
||||
let fail fmt =
|
||||
let k _ppf = exit 1 in
|
||||
Fmt.kpf k Fmt.stderr ("Configuration failure: " ^^ fmt ^^ ".@.")
|
||||
|
||||
let is_eol = function '\n' | '\r' -> true | _ -> false
|
||||
let is_whitespace = function ' ' | '\t' -> true | _ -> false
|
||||
let blanks = skip_while is_whitespace
|
||||
|
||||
module Config_section = struct
|
||||
type t =
|
||||
| Blank
|
||||
| Comment of string
|
||||
| Header of string
|
||||
| Item of item
|
||||
|
||||
let id =
|
||||
let ident_char = function
|
||||
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' -> true
|
||||
| _ -> false
|
||||
in
|
||||
take_while1 ident_char >>| String.lowercase_ascii
|
||||
|
||||
let line = take_till is_eol <* end_of_line
|
||||
let blank_line = blanks <* end_of_line >>| fun () -> Blank
|
||||
let comment = blanks *> (char '#' <|> char '%') *> line >>| fun s -> Comment s
|
||||
|
||||
let header =
|
||||
blanks *> char '[' *> id <* char ']' <* blanks <* end_of_line >>| fun s ->
|
||||
Header s
|
||||
|
||||
let item_value =
|
||||
let unquoted_value =
|
||||
take_while1 (fun c -> not (is_whitespace c || is_eol c))
|
||||
<* blanks
|
||||
<* end_of_line
|
||||
in
|
||||
let quoted_value =
|
||||
char '"' *> take_till is_eol <* end_of_line >>= fun s ->
|
||||
match String.ends_with ~suffix:"\"" s && s <> "\"" with
|
||||
| false -> fail "invalid quoted value"
|
||||
| true ->
|
||||
let value = String.sub s 0 (String.length s - 1) in
|
||||
return value
|
||||
in
|
||||
quoted_value <|> unquoted_value
|
||||
|
||||
let item =
|
||||
lift2
|
||||
(fun key value -> Item { key; value })
|
||||
id
|
||||
(blanks *> char '=' *> blanks *> item_value)
|
||||
|
||||
let config =
|
||||
many (choice [ blank_line; comment; header; item ]) <* end_of_input
|
||||
|
||||
let fold_sections l =
|
||||
let rec loop section_l item_l l =
|
||||
match l with
|
||||
| [] ->
|
||||
if List.is_empty item_l then section_l
|
||||
else fail "invalid configuration structure"
|
||||
| Blank :: tl | Comment _ :: tl -> loop section_l item_l tl
|
||||
| Item item :: tl -> loop section_l (item :: item_l) tl
|
||||
| Header header :: tl ->
|
||||
let section = { header; items= item_l } in
|
||||
loop (section :: section_l) [] tl
|
||||
in
|
||||
loop [] [] (List.rev l)
|
||||
|
||||
let parse s =
|
||||
match parse_string ~consume:All config s with
|
||||
| Error msg -> fail "parse error `%s`" msg
|
||||
| Ok v -> fold_sections v
|
||||
end
|
||||
|
||||
module Config_duration = struct
|
||||
type duration_element = {
|
||||
number: int;
|
||||
dunit: [ `Year | `Week | `Day | `Hour | `Minute | `Second ];
|
||||
}
|
||||
|
||||
let integer =
|
||||
take_while1 (function '0' .. '9' -> true | _ -> false) >>= fun s ->
|
||||
match int_of_string_opt s with
|
||||
| None -> fail "expected integer, got `%s`" s
|
||||
| Some i -> return i
|
||||
|
||||
let duration_element =
|
||||
let number = blanks *> integer in
|
||||
let dunit =
|
||||
blanks *> take_while1 (fun c -> not (is_whitespace c || is_eol c))
|
||||
>>= function
|
||||
| "year" | "years" -> return `Year
|
||||
| "week" | "weeks" -> return `Week
|
||||
| "day" | "days" -> return `Day
|
||||
| "hour" | "hours" -> return `Hour
|
||||
| "minute" | "minutes" -> return `Minute
|
||||
| "second" | "seconds" | "s" -> return `Second
|
||||
| s -> fail "expected a duration unit, got `%s`" s
|
||||
in
|
||||
lift2 (fun number dunit -> { number; dunit }) number dunit
|
||||
|
||||
let duration = many1 duration_element <* end_of_input
|
||||
|
||||
(* TODO put this in Time.Relative *)
|
||||
let dunit_to_seconds u =
|
||||
let rec f = function
|
||||
| `Year -> 365 * f `Day
|
||||
| `Week -> 7 * f `Day
|
||||
| `Day -> 24 * f `Hour
|
||||
| `Hour -> 60 * f `Minute
|
||||
| `Minute -> 60 * f `Second
|
||||
| `Second -> 1
|
||||
in
|
||||
f u
|
||||
|
||||
let to_time_span t =
|
||||
List.fold_left
|
||||
(fun acc { number; dunit } -> acc + (number * dunit_to_seconds dunit))
|
||||
0 t
|
||||
|> Int64.of_int
|
||||
|> Time.Relative.of_s
|
||||
|
||||
let parse s : duration_element list =
|
||||
match parse_string ~consume:All duration s with
|
||||
| Error msg -> fail "duration parse error `%s`" msg
|
||||
| Ok v -> v
|
||||
end
|
||||
|
||||
let unwrap = function Error e -> fail "`%s`." e | Ok v -> v
|
||||
|
||||
let get_opt t ~section ~field =
|
||||
match List.find_opt (fun v -> v.header = section) t with
|
||||
| None -> None
|
||||
| Some v -> (
|
||||
match List.find_opt (fun item -> item.key = field) v.items with
|
||||
| None -> None
|
||||
| Some item -> Some item.value)
|
||||
|
||||
let get t ~section ~field =
|
||||
match get_opt t ~section ~field with
|
||||
| None -> fail "option `[%s].%s` not found" section field
|
||||
| Some v -> v
|
||||
|
||||
let int s =
|
||||
match int_of_string_opt s with
|
||||
| None -> fail "expected int value, got `%s`" s
|
||||
| Some v -> v
|
||||
|
||||
let float s =
|
||||
match float_of_string_opt s with
|
||||
| None -> fail "expected float value, got `%s`" s
|
||||
| Some v -> v
|
||||
|
||||
let const_value a b =
|
||||
match a = b with false -> fail "unexpected value `%s`" b | true -> a
|
||||
|
||||
let yes_no = function
|
||||
| "NO" -> `NO
|
||||
| "YES" -> `YES
|
||||
| s -> fail "expected `YES`/`NO` value, got `%s`" s
|
||||
|
||||
let uri s = Uri.of_string s
|
||||
let amount s = s |> Amount.of_string |> unwrap
|
||||
let duration s = Config_duration.(s |> parse |> to_time_span)
|
||||
|
||||
let ed25519 s =
|
||||
s
|
||||
|> B32.decode
|
||||
|> unwrap
|
||||
|> Mirage_crypto_ec.Ed25519.pub_of_octets
|
||||
|> Result.map_error (fun e -> Fmt.str "%a" Mirage_crypto_ec.pp_error e)
|
||||
|> unwrap
|
||||
|
||||
let etag s =
|
||||
match Headers_lib.Etag.parse s with
|
||||
| Ok etag -> etag
|
||||
| Error e -> (
|
||||
(* retry with quotes if needed *)
|
||||
match Headers_lib.Etag.parse (Fmt.str "\"%s\"" s) with
|
||||
| Ok etag -> etag
|
||||
| Error _ -> fail "could not parse etag `%s`: %s" s e)
|
||||
|
||||
(* TODO
|
||||
move to another module
|
||||
can we type the json as a Int_map directly? *)
|
||||
module Alt_unit_names = struct
|
||||
open Syntax
|
||||
module String_map = Map.Make (String)
|
||||
|
||||
let string_map_jsont = Jsont.Object.as_string_map Jsont.string
|
||||
|
||||
let decode s =
|
||||
let* string_map = Jsont_bytesrw.decode_string string_map_jsont s in
|
||||
let l = String_map.to_list string_map in
|
||||
let* l =
|
||||
list_map
|
||||
(fun (k, v) ->
|
||||
match int_of_string_opt k with
|
||||
| None -> Error "alt_unit_names has a non-integer key"
|
||||
| Some k -> Ok (k, v))
|
||||
l
|
||||
in
|
||||
match List.find_opt (fun (i, _) -> i = 0) l with
|
||||
| None -> Error "alt_unit_names with no entry for base value \"0\""
|
||||
| Some _ -> Ok l
|
||||
|
||||
let encode l =
|
||||
let l = List.map (fun (k, v) -> (string_of_int k, v)) l in
|
||||
let string_map = String_map.of_list l in
|
||||
let+ s = Jsont_bytesrw.encode_string string_map_jsont string_map in
|
||||
s
|
||||
|
||||
let encode_exn l = encode l |> Result.get_ok
|
||||
end
|
||||
Loading…
Add table
Add a link
Reference in a new issue