more config horror
This commit is contained in:
parent
a596ea8fd1
commit
7b526e60ed
1 changed files with 156 additions and 176 deletions
|
|
@ -1,217 +1,197 @@
|
|||
let ( let* ) o f =
|
||||
match o with
|
||||
| Ok v -> f v
|
||||
| Error (`Msg e) ->
|
||||
Fmt.epr "config error, %s" e;
|
||||
exit 1
|
||||
module Schema = struct
|
||||
type nil = N
|
||||
|
||||
let unwrap param_name opt =
|
||||
match opt with
|
||||
| None -> Fmt.error_msg "parameter `%s` not found" param_name
|
||||
| Some v -> Ok v
|
||||
type empty = E
|
||||
|
||||
let print k v =
|
||||
Fmt.pr {|let %s = "%s"@.|} k v;
|
||||
()
|
||||
(*type dir = D*)
|
||||
|
||||
let print_b k v =
|
||||
Fmt.pr "let %s = %b@." k v;
|
||||
()
|
||||
type _ kind =
|
||||
| Bool : bool kind
|
||||
| Int : int kind
|
||||
| Float : float kind
|
||||
| String : string kind
|
||||
|
||||
let print_int k v =
|
||||
Fmt.pr "let %s = %#d@." k v;
|
||||
()
|
||||
(* todo: one general gadt for params and schema? *)
|
||||
type _ params =
|
||||
| Nil : nil params
|
||||
| Cons : ('a kind * 'b params) -> ('a * 'b) params
|
||||
|
||||
let print_int_opt k v =
|
||||
let s = match v with None -> "None" | Some v -> Fmt.str "Some %#d" v in
|
||||
Fmt.pr "let %s = %s@." k s;
|
||||
()
|
||||
type _ schema =
|
||||
| Empty : empty schema
|
||||
| Dir : (string * 'a params * 'b schema) -> ('a * 'b) schema
|
||||
|
||||
let print_l k l =
|
||||
let l = List.map (Fmt.str {|"%s"|}) l in
|
||||
Fmt.pr "let %s = [%s]@." k (String.concat "; " l);
|
||||
()
|
||||
let v = Dir ("void", Nil, Empty)
|
||||
|
||||
let print_arr k arr =
|
||||
let l = Array.map (Fmt.str {|"%s"|}) arr |> Array.to_list in
|
||||
Fmt.pr "let %s = [|%s|]@." k (String.concat "; " l);
|
||||
()
|
||||
let v1 = Dir ("cc", Cons (String, Nil), v)
|
||||
|
||||
let print_fpath k v =
|
||||
Fmt.pr {|let %s = Result.get_ok (Fpath.of_string "%s")@.|} k
|
||||
(Fpath.to_string v);
|
||||
()
|
||||
let v2 =
|
||||
Dir
|
||||
( "salut"
|
||||
, Cons (String, Cons (Bool, Cons (Float, Nil)))
|
||||
, Dir ("euj", Cons (Int, Nil), v1) )
|
||||
end
|
||||
|
||||
let print_uri k v =
|
||||
Fmt.pr {|let %s = Uri.of_string "%s"@.|} k (Uri.to_string v);
|
||||
()
|
||||
(* ------ *)
|
||||
|
||||
type _ tag =
|
||||
| String : string tag
|
||||
| Bool : bool tag
|
||||
| Int : int tag
|
||||
| Option : 'a tag -> 'a option tag
|
||||
| List : 'a tag -> 'a list tag
|
||||
| Array : 'a tag -> 'a array tag
|
||||
| Fpath : Fpath.t tag
|
||||
| Uri : Uri.t tag
|
||||
|
||||
type w = W : 'a tag -> w
|
||||
|
||||
let rec str_aux : type a. a tag -> a -> string =
|
||||
fun tag v ->
|
||||
match tag with
|
||||
| String -> Fmt.str {|"%s"|} v
|
||||
| Bool -> Fmt.str {|%b|} v
|
||||
| Int -> Fmt.str {|%d|} v
|
||||
| Option subtag -> (
|
||||
match v with
|
||||
| None -> "None"
|
||||
| Some v -> Fmt.str "Some ( %s )" (str_aux subtag v) )
|
||||
| List subtag -> (
|
||||
match v with
|
||||
| [] -> "[]"
|
||||
| l ->
|
||||
let l = List.map (fun v -> str_aux subtag v) l in
|
||||
Fmt.str "[ %s ]" (String.concat "; " l) )
|
||||
| Array subtag -> (
|
||||
match v with
|
||||
| [||] -> "[||]"
|
||||
| l ->
|
||||
let l = Array.map (fun v -> str_aux subtag v) l |> Array.to_list in
|
||||
Fmt.str "[| %s |]" (String.concat "; " l) )
|
||||
| Fpath ->
|
||||
Fmt.str {|Result.get_ok (Fpath.of_string "%s")|} (Fpath.to_string v)
|
||||
| Uri -> Fmt.str {|Uri.of_string "%s"|} (Uri.to_string v)
|
||||
|
||||
let str : type a. a tag -> string -> a -> string =
|
||||
fun tag k v ->
|
||||
match tag with
|
||||
| List _ -> Fmt.str {|let %s_l = %s@.|} k (str_aux tag v)
|
||||
| _ -> Fmt.str {|let %s = %s@.|} k (str_aux tag v)
|
||||
|
||||
let config_path =
|
||||
let* config_dir =
|
||||
Dir.config
|
||||
|> Option.to_result ~none:(`Msg "can't compute configuration directory")
|
||||
let config_dir =
|
||||
match Dir.config with
|
||||
| None -> Fmt.failwith "can't compute configuration directory"
|
||||
| Some config_dir -> config_dir
|
||||
in
|
||||
let config_path = Fpath.(config_dir / "config.scfg") in
|
||||
config_path
|
||||
|
||||
let config =
|
||||
let* exists = Bos.OS.File.exists config_path in
|
||||
let* config =
|
||||
let exists = Bos.OS.File.exists config_path in
|
||||
let config =
|
||||
match exists with
|
||||
| false ->
|
||||
Fmt.error_msg "configuration file `%a` does not exist, please create it"
|
||||
| Error (`Msg s) -> Fmt.failwith "%s" s
|
||||
| Ok false ->
|
||||
Fmt.failwith "configuration file `%a` does not exist, please create it"
|
||||
Fpath.pp config_path
|
||||
| true -> Scfg.Parse.from_file config_path
|
||||
| Ok true -> Scfg.Parse.from_file config_path
|
||||
in
|
||||
config
|
||||
config |> Result.get_ok
|
||||
|
||||
let get_dir param_name =
|
||||
let* dir = unwrap param_name @@ Scfg.Query.get_dir param_name config in
|
||||
dir
|
||||
|
||||
let mk_str param_name =
|
||||
let* v = Scfg.Query.get_param 0 (get_dir param_name) in
|
||||
print param_name v;
|
||||
()
|
||||
|
||||
let mk_bool param_name =
|
||||
let* v = Scfg.Query.get_param_bool 0 (get_dir param_name) in
|
||||
print_b param_name v;
|
||||
()
|
||||
|
||||
let mk_int ?min param_name =
|
||||
let min = Option.value ~default:0 min in
|
||||
let* n = Scfg.Query.get_param_int 0 (get_dir param_name) in
|
||||
let* () =
|
||||
let get : type a. a tag -> string -> a =
|
||||
fun tag k ->
|
||||
let open Scfg.Query in
|
||||
let dir = get_dir_exn k config in
|
||||
match tag with
|
||||
| String -> get_param_exn 0 dir
|
||||
| Bool -> get_param_bool_exn 0 dir
|
||||
| Int -> get_param_int_exn 0 dir
|
||||
| Option Int -> (
|
||||
let n = Scfg.Query.get_param_int_exn 0 dir in
|
||||
match n with
|
||||
| _ when n < 0 -> Fmt.error_msg "negative `%s` value" param_name
|
||||
| _ when n < min ->
|
||||
Fmt.error_msg "less than minimum (`%d`) `%s` value" min param_name
|
||||
| _ -> Ok ()
|
||||
in
|
||||
print_int param_name n;
|
||||
()
|
||||
|
||||
(* we use -1 in config file for None *)
|
||||
let mk_int_opt param_name =
|
||||
let* opt =
|
||||
match Scfg.Query.get_dir param_name config with
|
||||
| None -> Ok None
|
||||
| Some dir -> (
|
||||
let* n = Scfg.Query.get_param_int 0 dir in
|
||||
match n with
|
||||
| -1 -> Ok None
|
||||
| n when n < 0 -> Fmt.error_msg "negative `%s` value" param_name
|
||||
| n -> Ok (Some n) )
|
||||
in
|
||||
print_int_opt param_name opt;
|
||||
()
|
||||
|
||||
let mk_str_l param_name =
|
||||
let dirs = Scfg.Query.get_dirs param_name config in
|
||||
let l =
|
||||
| -1 -> None
|
||||
| n when n < 0 -> Fmt.failwith "negative `%s` value" k
|
||||
| n -> Some n )
|
||||
| List String ->
|
||||
let dirs = Scfg.Query.get_dirs k config in
|
||||
List.map
|
||||
(fun dir ->
|
||||
let* v = Scfg.Query.get_param 0 dir in
|
||||
let v = Scfg.Query.get_param_exn 0 dir in
|
||||
v )
|
||||
dirs
|
||||
in
|
||||
print_l (Fmt.str "%s_l" param_name) l;
|
||||
()
|
||||
| Option _ | List _ | Array _ | Fpath | Uri -> Fmt.failwith "unimplemented"
|
||||
|
||||
let mk : type a. a tag -> string -> unit =
|
||||
fun tag k ->
|
||||
let v = get tag k in
|
||||
let str = str tag k v in
|
||||
Fmt.pr "%s" str
|
||||
|
||||
(* server config *)
|
||||
let print_config_serv () =
|
||||
let () =
|
||||
print_fpath "config_path" config_path;
|
||||
()
|
||||
in
|
||||
|
||||
let () =
|
||||
let* data_dir =
|
||||
Dir.data |> Option.to_result ~none:(`Msg "can't compute data directory")
|
||||
in
|
||||
Fmt.pr "%s" (str Fpath "config_path" config_path);
|
||||
let data_dir = Dir.data |> Option.get in
|
||||
(* create data_dir *)
|
||||
let* () =
|
||||
let () =
|
||||
match Bos.OS.Dir.create data_dir with
|
||||
| Ok true -> Ok ()
|
||||
| Ok false -> Ok ()
|
||||
| Error (`Msg _) ->
|
||||
Fmt.error_msg "error when creating %a" Fpath.pp data_dir
|
||||
| Ok true -> ()
|
||||
| Ok false -> ()
|
||||
| Error (`Msg _) -> Fmt.failwith "error when creating %a" Fpath.pp data_dir
|
||||
in
|
||||
let db_path = Fpath.(data_dir / "geochan.db") in
|
||||
let s = Uri.of_string @@ Fmt.str "sqlite3://%a" Fpath.pp db_path in
|
||||
print_uri "db_uri" s;
|
||||
()
|
||||
let uri = Uri.of_string @@ Fmt.str "sqlite3://%a" Fpath.pp db_path in
|
||||
Fmt.pr "%s" (str Uri "db_uri" uri);
|
||||
let l =
|
||||
[ (W Bool, "default_logger")
|
||||
; (W Bool, "custom_logger")
|
||||
; (* TODO add temporary password hash + email for first connection? *)
|
||||
(W (List String), "admin")
|
||||
]
|
||||
in
|
||||
|
||||
let () = mk_bool "default_logger" in
|
||||
|
||||
let () = mk_bool "custom_logger" in
|
||||
|
||||
(* TODO add temporary password hash + email for first connection? *)
|
||||
let () = mk_str_l "admin" in
|
||||
|
||||
List.iter (fun (W tag, k) -> mk tag k) l;
|
||||
()
|
||||
|
||||
(* config (server & client) *)
|
||||
let print_config () =
|
||||
let () = mk_str "source_code_url" in
|
||||
|
||||
let () = mk_str "hostname" in
|
||||
|
||||
let () = mk_int "port" in
|
||||
|
||||
let () = mk_int "csrf_lifetime" in
|
||||
|
||||
let () = mk_int "session_lifetime" in
|
||||
|
||||
let () = mk_bool "open_registration" in
|
||||
|
||||
let () = mk_int "thread_max_count" in
|
||||
|
||||
let () = mk_int "thread_alive_max_count" in
|
||||
|
||||
let () = mk_int "thread_replies_max_count" in
|
||||
|
||||
let () = mk_int "subject_max_length" in
|
||||
|
||||
let () = mk_int_opt "subject_min_length" in
|
||||
|
||||
let () = mk_int "comment_max_length" in
|
||||
|
||||
let () = mk_int_opt "comment_min_length" in
|
||||
|
||||
let () = mk_int "report_max_length" in
|
||||
|
||||
let () = mk_int "nick_max_length" in
|
||||
|
||||
let () = mk_int ~min:1 "nick_min_length" in
|
||||
|
||||
let () = mk_int "biography_max_length" in
|
||||
|
||||
let () = mk_int "password_max_length" in
|
||||
|
||||
let () = mk_int ~min:1 "password_min_length" in
|
||||
|
||||
let () = mk_int "image_name_max_length" in
|
||||
|
||||
let () = mk_int "image_description_max_length" in
|
||||
|
||||
let () = mk_int "image_max_size" in
|
||||
print_arr "supported_mime_type"
|
||||
[| "image/jpeg"; "image/png"; "image/webp"; "image/gif" |];
|
||||
|
||||
let l =
|
||||
[ (W String, "source_code_url")
|
||||
; (W String, "hostname")
|
||||
; (W Int, "port")
|
||||
; (W Int, "csrf_lifetime")
|
||||
; (W Int, "session_lifetime")
|
||||
; (W Bool, "open_registration")
|
||||
; (W Int, "thread_max_count")
|
||||
; (W Int, "thread_alive_max_count")
|
||||
; (W Int, "thread_replies_max_count")
|
||||
; (W Int, "subject_max_length")
|
||||
; (W (Option Int), "subject_min_length")
|
||||
; (W Int, "comment_max_length")
|
||||
; (W (Option Int), "comment_min_length")
|
||||
; (W Int, "report_max_length")
|
||||
; (W Int, "nick_max_length")
|
||||
; (W Int, "nick_min_length")
|
||||
; (W Int, "biography_max_length")
|
||||
; (W Int, "password_max_length")
|
||||
; (W Int, "password_min_length")
|
||||
; (W Int, "image_name_max_length")
|
||||
; (W Int, "image_description_max_length")
|
||||
; (W Int, "image_max_size")
|
||||
]
|
||||
in
|
||||
List.iter (fun (W tag, k) -> mk tag k) l;
|
||||
Fmt.pr "%s"
|
||||
(str (Array String) "supported_mime_type"
|
||||
[| "image/jpeg"; "image/png"; "image/webp"; "image/gif" |] );
|
||||
()
|
||||
|
||||
let () =
|
||||
let* arg =
|
||||
if Array.length Sys.argv > 1 then Ok Sys.argv.(1)
|
||||
else Fmt.error_msg "make config failure, no argument provided"
|
||||
let arg =
|
||||
if Array.length Sys.argv > 1 then Sys.argv.(1)
|
||||
else Fmt.failwith "make config failure, no argument provided"
|
||||
in
|
||||
let* () =
|
||||
let () =
|
||||
match arg with
|
||||
| "--config-serv" -> Ok (print_config_serv ())
|
||||
| "--config" -> Ok (print_config ())
|
||||
| _ -> Fmt.error_msg "make config failure, invalid argument `%s`" arg
|
||||
| "--config-serv" -> print_config_serv ()
|
||||
| "--config" -> print_config ()
|
||||
| _ -> Fmt.failwith "make config failure, invalid argument `%s`" arg
|
||||
in
|
||||
()
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue