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