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
open Lwt.Syntax
let log_src = Logs.Src.create "sihl.service.token"
module Logs = (val Logs.src_log log_src : Logs.LOG)
module Make (Repo : Sig.REPOSITORY) : Sig.SERVICE = struct
let find_opt ctx value =
let* token = Repo.find_opt ctx ~value in
Lwt.return @@ Option.bind token (fun tk -> if Model.is_valid tk then token else None)
;;
let find ctx value =
let* token = find_opt ctx value in
match token with
| Some token -> Lwt.return token
| None ->
raise (Model.Exception (Printf.sprintf "Token %s not found or not valid" value))
;;
let find_by_id_opt ctx id =
let* token = Repo.find_by_id_opt ctx ~id in
Lwt.return @@ Option.bind token (fun tk -> if Model.is_valid tk then token else None)
;;
let find_by_id ctx id =
let* token = find_by_id_opt ctx id in
match token with
| Some token -> Lwt.return token
| None ->
raise
(Model.Exception (Printf.sprintf "Token with id %s not found or not valid" id))
;;
let make ~id ~data ~kind ?(expires_in = Utils.Time.OneDay) ?now ?(length = 80) () =
let value = Core.Random.base64 ~nr:length in
let expires_in = Utils.Time.duration_to_span expires_in in
let now = Option.value ~default:(Ptime_clock.now ()) now in
let expires_at = Option.get (Ptime.add_span now expires_in) in
let status = Model.Status.Active in
let created_at = Ptime_clock.now () in
Model.make ~id ~value ~data ~kind ~status ~expires_at ~created_at
;;
let create ctx ~kind ?data ?expires_in ?length () =
let expires_in = Option.value ~default:Utils.Time.OneDay expires_in in
let length = Option.value ~default:80 length in
let id = Database.Id.random () |> Database.Id.to_string in
let token = make ~id ~kind ~data ~expires_in ~length () in
let* () = Repo.insert ctx ~token in
let value = Model.value token in
find ctx value
;;
let invalidate ctx token = Repo.update ctx ~token:(Model.invalidate token)
let start ctx =
let () = Repo.register_migration () in
let () = Repo.register_cleaner () in
Lwt.return ctx
;;
let stop _ = Lwt.return ()
let lifecycle = Core.Container.Lifecycle.create ~dependencies:[] "token" ~start ~stop
let configure configuration =
let configuration = Core.Configuration.make configuration in
Core.Container.Service.create ~configuration lifecycle
;;
end