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
module Utils = Sihl_utils
module Core = Sihl_core
module Database = Sihl_database
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 value =
let* token = Repo.find_opt ~value in
Lwt.return @@ Option.bind token (fun tk -> if Model.is_valid tk then token else None)
;;
let find value =
let* token = find_opt 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 id =
let* token = Repo.find_by_id_opt ~id in
Lwt.return @@ Option.bind token (fun tk -> if Model.is_valid tk then token else None)
;;
let find_by_id id =
let* token = find_by_id_opt 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 =
match Ptime.add_span now expires_in with
| Some expires_at -> expires_at
| None -> failwith ("Could not parse expiry date for token with id " ^ id)
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 ~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 ~token in
let value = Model.value token in
find value
;;
let invalidate token = Repo.update ~token:(Model.invalidate token)
let start () = Lwt.return ()
let stop () = Lwt.return ()
let lifecycle = Core.Container.Lifecycle.create ~dependencies:[] "token" ~start ~stop
let register () =
Repo.register_migration ();
Repo.register_cleaner ();
Core.Container.Service.create lifecycle
;;
end