geochan/src/virtual/make_config_lib.ml

(* TODO
   custom parameter type
   print a scfg
   handle failures *)
module M = struct
  open Scfg

  type nil = NIL

  type dir

  type param

  type ('a, 'b) directive =
    { name : string
    ; params : 'a
    ; children : 'b
    }

  type ('r, _) t =
    | Bool : (param, bool) t
    | Int : (param, int) t
    | Float : (param, float) t
    | String : (param, string) t
    | Directive :
        (string * (param, 'a) t_list * (dir, 'b) t_list)
        -> (dir, ('a, 'b) directive) t
    | Leaf : (string * (param, 'a) t_list) -> (dir, ('a, nil) directive) t

  and ('r, _) t_list =
    | Nil : ('r, nil) t_list
    | One : ('r, 'a) t -> ('r, 'a) t_list
    | Cons : (('r, 'a) t * ('r, 'b) t_list) -> ('r, 'a * 'b) t_list

  let error () = Fmt.failwith "invalid schema"

  let conv_param : type a. (param, a) t -> string -> a =
   fun param_t v ->
    try
      match param_t with
      | Bool -> bool_of_string v
      | Int -> int_of_string v
      | Float -> float_of_string v
      | String -> v
    with Invalid_argument _ -> error ()

  let rec conv_param_list : type a. (param, a) t_list -> string list -> a =
   fun param_l_t l ->
    match param_l_t with
    | Nil -> ( match l with [] -> NIL | _ -> error () )
    | One k -> ( match l with [ hd ] -> conv_param k hd | _ -> error () )
    | Cons (k, k_l) -> (
      match l with
      | [] -> error ()
      | hd :: tl -> (conv_param k hd, conv_param_list k_l tl) )

  let rec conv_dir : type a. (dir, a) t -> Types.directive -> a =
   fun dir_t dir ->
    match dir_t with
    | Directive (name, params, children) -> (
      match String.equal name dir.name with
      | false -> error ()
      | true ->
        { name
        ; params = conv_param_list params dir.params
        ; children = conv children dir.children
        } )
    | Leaf (name, params) -> (
      match String.equal name dir.name with
      | false -> error ()
      | true ->
        { name; params = conv_param_list params dir.params; children = NIL } )

  and conv : type a. (dir, a) t_list -> Types.config -> a =
   fun dir_l_t l ->
    match dir_l_t with
    | Nil -> ( match l with [] -> NIL | _ -> error () )
    | One k -> ( match l with [ hd ] -> conv_dir k hd | _ -> error () )
    | Cons (k, k_l) -> (
      match l with [] -> error () | hd :: tl -> (conv_dir k hd, conv k_l tl) )

  let ( @^ ) = fun a b -> Cons (a, b)

  let ( @+ ) = fun a b -> Cons (a, One b)

  let ( !@ ) = fun a -> One a

  let directive : type a b.
         string
      -> (param, a) t_list
      -> (dir, b) t_list
      -> (dir, (a, b) directive) t =
   fun name params children -> Directive (name, params, children)

  let leaf : type a. string -> (param, a) t_list -> (dir, (a, nil) directive) t
      =
   fun name params -> Leaf (name, params)
end

module M_test = struct
  open M

  module Uuu = struct
    module Pp = struct
      let hide_data : (param, 'a) t * ('a ) -> (param, 'a) t =
        fun (t, _v) ->

      let ( @^ ) = fun a b -> Cons (hide_data a, b)

      let ( @+ ) = fun a b -> Cons (hide_data a, One (hide_data b))

      let ( !@ ) = fun a -> One (hide_data a)
    end

    open Pp

    let sch = !@(leaf "cc" (!@ (String, "uu" )   ) )
  end

  let schema_1 = !@(leaf "cc" !@String)

  let schema_2 =
    !@(directive "salut" (String @^ Bool @+ Float) !@(leaf "euj" !@Int))

  let schema_3 = leaf "cc" !@String @^ leaf "cc" !@String @+ leaf "cc" !@String

  let txt_1 = Scfg.Parse.from_string {|cc param_1
      |} |> Result.get_ok

  let txt_2 =
    Scfg.Parse.from_string
      {|salut param_str true 0.46 {
    euj 3456
    }
      |}
    |> Result.get_ok

  let txt_3 =
    Scfg.Parse.from_string {|cc sava
  cc sava
  cc sava
      |}
    |> Result.get_ok

  let () =
    let v_1 = conv schema_1 txt_1 in
    let { name; params; children } = v_1 in
    assert (name = "cc");
    assert (params = "param_1");
    assert (children = NIL);

    let v_2 = conv schema_2 txt_2 in
    let { name; params; children } = v_2 in
    assert (name = "salut");
    assert (params = ("param_str", (true, 0.46)));
    assert (children.name = "euj");
    assert (children.params = 3456);

    let v_3 = conv schema_3 txt_3 in
    let dir1, (dir2, dir3) = v_3 in
    assert (dir1 = dir2);
    assert (dir2 = dir3);
    ()
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
  ()