Source file configuration.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
open Lwt.Syntax

let log_src = Logs.Src.create "sihl.configuration"

module Logs = (val Logs.src_log log_src : Logs.LOG)

exception Exception of string

type data = (string * string) list
type t = data -> (string * string) list

let make ?schema () =
  match schema with
  | Some schema ->
    let validator data =
      let data = List.map (fun (k, v) -> k, [ v ]) data in
      Conformist.validate schema data
    in
    validator
  | None -> fun _ -> []
;;

let empty _ = []

let memoize f =
  (* We assume a total number of initial configurations of 100 *)
  let cache = Hashtbl.create 100 in
  fun arg ->
    try Hashtbl.find cache arg with
    | Not_found ->
      let result = f arg in
      (* We don't want to fill up the cache with None *)
      if Option.is_some result then Hashtbl.add cache arg result;
      result
;;

let store data =
  List.iter
    (fun (key, value) ->
      let stored = Sys.getenv_opt key in
      if Option.is_some stored || Option.equal String.equal (Some "") stored
      then ()
      else Unix.putenv key value)
    data
;;

let envs_to_kv envs =
  envs
  |> List.map (String.split_on_char '=')
  |> List.map (function
         | [] -> "", ""
         | [ key ] -> key, ""
         | [ key; value ] -> key, value
         | key :: values -> key, String.concat "" values)
;;

(* TODO [jerben] Consider memoizing this or any consumer functions *)
let environment_variables () = Unix.environment () |> Array.to_list |> envs_to_kv

let read schema =
  let data = environment_variables () in
  let data = List.map (fun (k, v) -> k, [ v ]) data in
  match Conformist.validate schema data with
  | [] ->
    (match Conformist.decode schema data with
    | Ok value -> value
    | Error msg ->
      Logs.err (fun m -> m "%s" msg);
      raise (Exception "Invalid configuration provided"))
  | errors ->
    let errors =
      List.map
        (fun (k, v) -> Format.sprintf "Configuration '%s' has invalid value: %s" k v)
        errors
    in
    print_endline "Invalid configuration provided";
    List.iter print_endline errors;
    List.iter (fun error -> Logs.err (fun m -> m "%s" error)) errors;
    raise (Exception "Invalid configuration provided")
;;

let read_string' key = Sys.getenv_opt key
let read_string = memoize read_string'

let read_int key =
  match read_string key with
  | Some value -> int_of_string_opt value
  | None -> None
;;

let read_bool key =
  match read_string key with
  | Some value -> bool_of_string_opt value
  | None -> None
;;

let is_testing () =
  match read_string "SIHL_ENV" with
  | Some "test" -> true
  | _ -> false
;;

let is_production () =
  match read_string "SIHL_ENV" with
  | Some "production" -> true
  | _ -> false
;;

let project_root_path =
  match read_string "PROJECT_ROOT_DIR" with
  | Some pjr -> pjr
  | _ -> Unix.getcwd ()
;;

let read_env_file () =
  let filename =
    project_root_path ^ "/" ^ if is_testing () then ".env.testing" else ".env"
  in
  let* exists = Lwt_unix.file_exists filename in
  if exists
  then
    let* file = Lwt_io.open_file ~mode:Lwt_io.Input filename in
    let rec read_to_end file ls =
      let* line = Lwt_io.read_line_opt file in
      match line with
      | Some line -> read_to_end file (line :: ls)
      | None -> Lwt.return ls
    in
    let* envs = read_to_end file [] in
    envs |> envs_to_kv |> Lwt.return
  else Lwt.return []
;;

let require validators =
  let vars = environment_variables () in
  let errors = validators |> List.map (fun validator -> validator vars) |> List.concat in
  match errors with
  | (k, v) :: _ ->
    raise
    @@ Exception (Format.sprintf "For configuration key %s there is an issue: %s" k v)
  | _ -> ()
;;

(* TODO [jerben] Implement "print configuration documentation" commands *)
let commands _ = []