geochan/src/virtual/make_config_lib.ml

module Schema = struct
  type nil = N

  type empty = E

  (*type dir = D*)

  type _ kind =
    | Bool : bool kind
    | Int : int kind
    | Float : float kind
    | String : string kind

  (* todo: one general gadt for params and schema? *)
  type _ params =
    | Nil : nil params
    | Cons : ('a kind * 'b params) -> ('a * 'b) params

  type _ schema =
    | Empty : empty schema
    | Dir : (string * 'a params * 'b schema) -> ('a * 'b) schema

  let v = Dir ("void", Nil, Empty)

  let v1 = Dir ("cc", Cons (String, Nil), v)

  let v2 =
    Dir
      ( "salut"
      , Cons (String, Cons (Bool, Cons (Float, Nil)))
      , Dir ("euj", Cons (Int, Nil), v1) )
end

(* ------ *)

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 =
    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 =
    match exists with
    | Error (`Msg s) -> Fmt.failwith "%s" s
    | Ok false ->
      Fmt.failwith "configuration file `%a` does not exist, please create it"
        Fpath.pp config_path
    | Ok true -> Scfg.Parse.from_file config_path
  in
  config |> Result.get_ok

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
    | -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_exn 0 dir in
        v )
      dirs
  | 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

let print_config_serv () =
  Fmt.pr "%s" (str Fpath "config_path" config_path);
  let data_dir = Dir.data |> Option.get in
  (* create data_dir *)
  let () =
    match Bos.OS.Dir.create data_dir with
    | 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 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
  List.iter (fun (W tag, k) -> mk tag k) l;
  ()

(* config (server & client) *)
let print_config () =
  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 Sys.argv.(1)
    else Fmt.failwith "make config failure, no argument provided"
  in
  let () =
    match arg with
    | "--config-serv" -> print_config_serv ()
    | "--config" -> print_config ()
    | _ -> Fmt.failwith "make config failure, invalid argument `%s`" arg
  in
  ()