Source file app.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
open Lwt.Syntax
module Sig = App_sig

module Make (Kernel : Sig.KERNEL) = struct
  type t = {
    config : Configuration.t;
    endpoints : Web.Server.endpoint list;
    services : (module Core.Container.SERVICE) list;
    schedules : Schedule.t list;
    commands : Cmd.t list;
    seeds : Seed.t list;
    on_start : Core.Ctx.t -> unit Lwt.t;
    on_stop : Core.Ctx.t -> unit Lwt.t;
  }

  let empty =
    {
      config = Configuration.create ~development:[] ~test:[] ~production:[];
      endpoints = [];
      services = [];
      schedules = [];
      commands = [];
      seeds = [];
      on_start = (fun _ -> Lwt.return ());
      on_stop = (fun _ -> Lwt.return ());
    }

  let with_config config app = { app with config }

  let with_endpoints endpoints app = { app with endpoints }

  let with_services services app = { app with services }

  let with_schedules schedules app = { app with schedules }

  let with_commands commands app = { app with commands }

  let with_seeds seeds app = { app with seeds }

  let on_start on_start app = { app with on_start }

  let on_stop on_stop app = { app with on_stop }

  let start_cmd =
    Cmd.make ~name:"start" ~help:"<with_migration>"
      ~description:
        "Start the Sihl app, use <with_migration> to optionally run the \
         migrations before starting the web server"
      ~fn:(fun args ->
        match args with
        | [ "with_migration" ] ->
            let ctx = Core.Ctx.empty |> Kernel.Db.add_pool in
            let* () = Kernel.Migration.run_all ctx in
            Kernel.WebServer.start_server ctx
        | [] ->
            let ctx = Core.Ctx.empty in
            Kernel.WebServer.start_server ctx
        | _ -> raise (Cmd.Invalid_usage "Example usage: start with_migration"))
      ()

  let run app =
    Lwt_main.run
      (let ctx = Core.Ctx.empty in
       Kernel.Log.debug (fun m -> m "APP: Register config");
       Kernel.Config.register_config app.config;
       Kernel.Log.debug (fun m -> m "APP: Register routes");
       Kernel.WebServer.register_endpoints app.endpoints;
       Kernel.Log.debug (fun m -> m "APP: Register commands");
       let commands = List.cons start_cmd app.commands in
       Kernel.Cmd.register_commands commands;
       Kernel.Log.debug (fun m -> m "APP: Register seeds");
       Kernel.Seed.register_seeds app.seeds;
       Kernel.Log.debug (fun m -> m "APP: Register schedules");
       let _ = app.schedules |> List.map (Kernel.Schedule.schedule ctx) in
       Kernel.Log.debug (fun m -> m "APP: Start services");
       let* _, ctx = Core.Container.start_services app.services in
       Kernel.Log.debug (fun m -> m "APP: Start app");
       let* () = app.on_start ctx in
       Kernel.Cmd.run ())
end