package guardian

  1. Overview
  2. Docs

Source file mariadb_backend.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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
open Lwt.Infix
open Caqti_request.Infix

module Make
  (A : Guardian.RoleSig)
  (T : Guardian.RoleSig)
  (Db : Database_pools.Sig) =
struct
  module Guardian = Guardian.Make (A) (T)
  module ActorSet = Guardian.ActorRoleSet
  module Authorizer = Guardian.Authorizer
  module TargetSet = Guardian.TargetRoleSet
  module Uuid = Guardian.Uuid

  include Guardian.Make_persistence (struct
    type 'a authorizable = 'a Guardian.Authorizable.t
    type 'b authorizable_target = 'b Guardian.AuthorizableTarget.t
    type role = A.t
    type auth_rule = Authorizer.auth_rule
    type actor_role_set = ActorSet.t
    type actor_spec = Authorizer.Actor.spec
    type target_role_set = TargetSet.t
    type target_spec = Authorizer.Target.spec
    type ('rv, 'err) monad = ('rv, 'err) Lwt_result.t

    module Actor = struct
      module Authorizable = struct
        let create ?ctx ?owner roles id =
          let caqti =
            Caqti_type.(tup3 string string (option string) ->. unit)
              {sql|INSERT INTO guardian_actors (id, roles, parent) VALUES (?, ?, ?)|sql}
          in
          let roles' = ActorSet.to_yojson roles |> Yojson.Safe.to_string in
          let owner' = CCOption.map Uuid.Actor.to_string owner in
          Db.exec ?ctx caqti (Uuid.Actor.to_string id, roles', owner')
          |> Lwt_result.ok
        ;;

        let mem ?ctx id =
          let caqti =
            Caqti_type.(string ->? string)
              {sql|SELECT roles FROM guardian_actors WHERE id = ?|sql}
          in
          Db.find_opt ?ctx caqti (Uuid.Actor.to_string id)
          >|= CCOption.is_some
          |> Lwt_result.ok
        ;;
      end

      let find ?ctx typ id =
        let open Lwt_result.Syntax in
        let caqti =
          {sql|SELECT roles, parent FROM guardian_actors WHERE id = ?|sql}
          |> Caqti_type.(string ->! tup2 string (option string))
        in
        let%lwt roles, owner = Db.find ?ctx caqti (Uuid.Actor.to_string id) in
        let* roles =
          roles
          |> Yojson.Safe.from_string
          |> ActorSet.of_yojson
          |> Lwt_result.lift
        in
        let owner = owner |> CCFun.flip CCOption.bind Uuid.Actor.of_string in
        Guardian.Authorizable.make ?owner roles typ id |> Lwt.return_ok
      ;;

      let find_roles ?ctx id =
        let caqti =
          {sql|SELECT roles FROM guardian_actors WHERE id = ?|sql}
          |> Caqti_type.(string ->! string)
        in
        let%lwt roles = Db.find ?ctx caqti (Uuid.Actor.to_string id) in
        roles |> Yojson.Safe.from_string |> ActorSet.of_yojson |> Lwt.return
      ;;

      let find_rules ?ctx target_spec =
        let%lwt res =
          match target_spec with
          | `Target uuid ->
            let caqti =
              {sql|
              SELECT act, actor_id, actor_role FROM guardian_rules
              WHERE target_id = ?
            |sql}
              |> Caqti_type.(
                   string ->* tup3 string (option string) (option string))
            in
            Db.collect ?ctx caqti (Uuid.Target.to_string uuid)
          | `TargetEntity role ->
            let caqti =
              {sql|
              SELECT act, actor_id, actor_role FROM guardian_rules
              WHERE target_role = ?
            |sql}
              |> Caqti_type.(
                   string ->* tup3 string (option string) (option string))
            in
            Db.collect ?ctx caqti (role |> T.show)
        in
        CCList.map
          (fun (act, actor_id, actor_role) ->
            let act = Guardian.Action.of_string act in
            match actor_id, CCOption.map A.of_string actor_role with
            | Some id, None ->
              (match Uuid.Actor.of_string id with
               | Some id' -> `Actor id', act, target_spec
               | None -> raise (Failure (Format.asprintf "Invalid UUID: %s" id)))
            | None, Some role -> `ActorEntity role, act, target_spec
            | Some _, Some _ | None, None ->
              raise
                (Failure
                   "Either both actor fields were occupied, or both were not."))
          res
        |> Lwt.return_ok
      ;;

      let act_on_rule ?ctx query (actor, action, target) =
        let open Guardian in
        let actor' = Authorizer.Actor.value actor in
        let action' = Action.to_string action in
        let target' = Authorizer.Target.value target in
        let caqti = Caqti_type.(tup3 string string string ->. unit) query in
        Db.exec ?ctx caqti (actor', action', target') |> Lwt_result.ok
      ;;

      let save_rule ?ctx auth_rule =
        let query =
          match auth_rule with
          | `Actor _, _, `Target _ ->
            {sql|INSERT INTO guardian_rules (actor_id, act, target_id) VALUES (?, ?, ?)|sql}
          | `Actor _, _, `TargetEntity _ ->
            {sql|INSERT INTO guardian_rules (actor_id, act, target_role) VALUES (?, ?, ?)|sql}
          | `ActorEntity _, _, `Target _ ->
            {sql|INSERT INTO guardian_rules (actor_role, act, target_id) VALUES (?, ?, ?)|sql}
          | `ActorEntity _, _, `TargetEntity _ ->
            {sql|INSERT INTO guardian_rules (actor_role, act, target_role) VALUES (?, ?, ?)|sql}
        in
        act_on_rule ?ctx query auth_rule
      ;;

      let delete_rule ?ctx auth_rule =
        let query =
          match auth_rule with
          | `Actor _, _, `Target _ ->
            {sql|DELETE FROM guardian_rules WHERE actor_id = ? AND act = ? AND target_id = ?|sql}
          | `Actor _, _, `TargetEntity _ ->
            {sql|DELETE FROM guardian_rules WHERE actor_id = ? AND act = ? AND target_role = ?|sql}
          | `ActorEntity _, _, `Target _ ->
            {sql|DELETE FROM guardian_rules WHERE actor_role = ? AND act = ? AND target_id = ?|sql}
          | `ActorEntity _, _, `TargetEntity _ ->
            {sql|DELETE FROM guardian_rules WHERE actor_role = ? AND act = ? AND target_role = ?|sql}
        in
        act_on_rule ?ctx query auth_rule
      ;;

      let grant_roles ?ctx uuid roles =
        let open Lwt_result.Syntax in
        let open Guardian in
        let* pre_roles = find_roles ?ctx uuid in
        let roles' = ActorSet.union roles pre_roles in
        if ActorSet.(cardinal roles' > cardinal pre_roles)
        then (
          let caqti =
            Caqti_type.(tup2 string string ->. unit)
              {sql|UPDATE guardian_actors SET roles = ? WHERE id = ?|sql}
          in
          let roles'' = Yojson.Safe.to_string (ActorSet.to_yojson roles') in
          Db.exec ?ctx caqti (roles'', Uuid.Actor.to_string uuid)
          |> Lwt_result.ok)
        else Lwt.return_ok ()
      ;;

      let revoke_roles ?ctx uuid roles =
        let open Lwt_result.Syntax in
        let open Guardian in
        let* pre_roles = find_roles ?ctx uuid in
        let roles' = ActorSet.diff pre_roles roles in
        let caqti =
          Caqti_type.(tup2 string string ->. unit)
            {sql|UPDATE guardian_actors SET roles = ? WHERE id = ?|sql}
        in
        let roles'' = Yojson.Safe.to_string (ActorSet.to_yojson roles') in
        Db.exec ?ctx caqti (roles'', Uuid.Actor.to_string uuid) |> Lwt_result.ok
      ;;

      let find_owner ?ctx id =
        let caqti =
          Caqti_type.(string ->! option string)
            {sql|SELECT parent FROM guardian_actors WHERE id = ?|sql}
        in
        Db.find ?ctx caqti (Uuid.Actor.to_string id)
        >|= CCFun.flip CCOption.bind Uuid.Actor.of_string
        |> Lwt_result.ok
      ;;

      let save_owner ?ctx ?owner id =
        let caqti =
          Caqti_type.(tup2 (option string) string ->. unit)
            {sql|UPDATE guardian_actors SET parent = ? WHERE id = ?|sql}
        in
        Db.exec
          ?ctx
          caqti
          Uuid.Actor.(owner |> CCOption.map to_string, to_string id)
        |> Lwt_result.ok
      ;;
    end

    module Target = struct
      module Authorizable = struct
        let create ?ctx ?owner roles id =
          let caqti =
            Caqti_type.(tup3 string string (option string) ->. unit)
              {sql|INSERT INTO guardian_targets (id, roles, parent) VALUES (?, ?, ?)|sql}
          in
          let roles' = TargetSet.to_yojson roles |> Yojson.Safe.to_string in
          let owner' = owner |> CCOption.map Uuid.Actor.to_string in
          Db.exec ?ctx caqti (Uuid.Target.to_string id, roles', owner')
          |> Lwt_result.ok
        ;;

        let mem ?ctx id =
          let caqti =
            Caqti_type.(string ->? string)
              {sql|SELECT roles FROM guardian_targets WHERE id = ?|sql}
          in
          Db.find_opt ?ctx caqti (Uuid.Target.to_string id)
          >|= CCOption.is_some
          |> Lwt_result.ok
        ;;
      end

      let find ?ctx typ id =
        let open Lwt_result.Syntax in
        let caqti =
          {sql|SELECT roles, parent FROM guardian_targets WHERE id = ?|sql}
          |> Caqti_type.(string ->! tup2 string (option string))
        in
        let%lwt entity, owner = Db.find ?ctx caqti (Uuid.Target.to_string id) in
        let* entity =
          entity
          |> Yojson.Safe.from_string
          |> TargetSet.of_yojson
          |> Lwt_result.lift
        in
        let owner = owner |> CCFun.flip CCOption.bind Uuid.Actor.of_string in
        Guardian.AuthorizableTarget.make ?owner entity typ id |> Lwt.return_ok
      ;;

      let find_roles ?ctx id =
        let caqti =
          {sql|SELECT roles FROM guardian_targets WHERE id = ?|sql}
          |> Caqti_type.(string ->! string)
        in
        let%lwt roles = Db.find ?ctx caqti (Uuid.Target.to_string id) in
        roles |> Yojson.Safe.from_string |> TargetSet.of_yojson |> Lwt.return
      ;;

      let find_owner ?ctx id =
        let caqti =
          Caqti_type.(string ->! option string)
            {sql|SELECT parent FROM guardian_targets WHERE id = ?|sql}
        in
        Db.find ?ctx caqti (Uuid.Target.to_string id)
        >|= CCFun.flip CCOption.bind Uuid.Actor.of_string
        |> Lwt_result.ok
      ;;

      let save_owner ?ctx ?owner id =
        let caqti =
          Caqti_type.(tup2 (option string) string ->. unit)
            {sql|UPDATE guardian_targets SET parent = ? WHERE id = ?|sql}
        in
        Db.exec
          ?ctx
          caqti
          Uuid.(owner |> CCOption.map Actor.to_string, Target.to_string id)
        |> Lwt_result.ok
      ;;
    end

    (** [find_migrations ()] returns a list of all migrations as a tuple with
        key, datetime and sql query **)
    let find_migrations () = Migrations.all

    (** [find_clean ()] returns a list of all migrations as a tuple with key and
        sql query **)
    let find_clean () =
      Migrations.all_tables
      |> CCList.map (fun m -> m, Format.asprintf "TRUNCATE TABLE %s" m)
    ;;

    (** [migrate ()] runs all migration on a specified context [?ctx] **)
    let migrate ?ctx () =
      ()
      |> find_migrations
      |> Lwt_list.iter_s (fun (key, date, sql) ->
           Logs.debug (fun m -> m "Migration: Run '%s' from '%s'" key date);
           Db.exec ?ctx (sql |> Caqti_type.(unit ->. unit)) ())
    ;;

    (** [clean ()] runs clean on a specified context [?ctx] **)
    let clean ?ctx () =
      ()
      |> find_clean
      |> Lwt_list.iter_s (fun (key, sql) ->
           Logs.debug (fun m -> m "Clean: Run '%s'" key);
           Db.exec ?ctx (sql |> Caqti_type.(unit ->. unit)) ())
    ;;
  end)
end
OCaml

Innovation. Community. Security.