Source file service.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
module Core = Sihl_core
module Session = Sihl_session
open Lwt.Syntax
module Entry = Model.Entry

let log_src = Logs.Src.create ~doc:"message" "sihl.service.message"

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

let session_key = "message"

module Make (SessionService : Session.Sig.SERVICE) : Sig.SERVICE = struct
  let fetch_entry ctx session =
    let* entry = SessionService.get ctx session ~key:session_key in
    match entry with
    | None -> Lwt.return None
    | Some entry ->
      (match entry |> Entry.of_string with
      | Ok entry -> Lwt.return (Some entry)
      | Error msg ->
        Logs.warn (fun m -> m "MESSAGE: Invalid flash message in session %s" msg);
        Lwt.return None)
  ;;

  let find_current ctx session =
    let* entry = fetch_entry ctx session in
    match entry with
    | None -> Lwt.return None
    | Some entry -> Lwt.return (Entry.current entry)
  ;;

  let set_next ctx session message =
    let* entry = fetch_entry ctx session in
    match entry with
    | None ->
      (* No entry found, creating new one *)
      let entry = Entry.create message |> Entry.to_string in
      SessionService.set ctx session ~key:session_key ~value:entry
    | Some entry ->
      (* Overriding next message in existing entry *)
      let entry = Entry.set_next message entry |> Entry.to_string in
      SessionService.set ctx session ~key:session_key ~value:entry
  ;;

  let rotate ctx session =
    let* entry = fetch_entry ctx session in
    match entry with
    | None -> Lwt.return None
    | Some entry ->
      let serialized_entry = entry |> Entry.rotate |> Entry.to_string in
      let* () = SessionService.set ctx session ~key:session_key ~value:serialized_entry in
      Lwt.return @@ Model.Entry.next entry
  ;;

  let current ctx session =
    let* entry = find_current ctx session in
    match entry with
    | None -> Lwt.return None
    | Some message -> Lwt.return (Some message)
  ;;

  let set ctx session ?(error = []) ?(warning = []) ?(success = []) ?(info = []) () =
    let message =
      Model.Message.(
        empty
        |> set_error error
        |> set_warning warning
        |> set_success success
        |> set_info info)
    in
    set_next ctx session message
  ;;

  let start ctx = Lwt.return ctx
  let stop _ = Lwt.return ()

  let lifecycle =
    Core.Container.Lifecycle.create
      "message"
      ~dependencies:[ SessionService.lifecycle ]
      ~start
      ~stop
  ;;

  let configure configuration =
    let configuration = Core.Configuration.make configuration in
    Core.Container.Service.create ~configuration lifecycle
  ;;
end