Feature/role assignment (#16)

* update/add packages

* fix deprecation

* add migrations to remove old tables

* add caqti encoders, add populate function for database

* add role assignments to guardian

README.md

@@ -94,7 +94,7 @@ let find_accessible kind =
     GROUP BY posts.uuid
     HAVING guardianValidatePostUuid(guardianEncodeUuid(?), ?, posts.uuid)
   |sql}
-  |> Caqti_type.(tup2 UuidActor.t Action.t ->* Post.t)
+  |> Caqti_type.(t2 UuidActor.t Action.t ->* Post.t)
 ```
 
 ## Development

backend/caqti_encoders.ml

@@ -0,0 +1,52 @@
+(** Helper functions for creating Caqti types with custom encoder/decoders. *)
+
+module Data = struct
+  type _ t =
+    | [] : unit t
+    | ( :: ) : ('a * 'b t) -> ('a * 'b) t
+
+  let rec make_value : type a. a t -> a =
+    fun xs ->
+    match xs with
+    | [] -> ()
+    | x :: xs -> x, make_value xs
+  ;;
+end
+
+module Schema = struct
+  type _ t =
+    | [] : unit t
+    | ( :: ) : ('a Caqti_type.t * 'b t) -> ('a * 'b) t
+
+  let rec make_type : type a. a t -> a Caqti_type.t =
+    fun xs ->
+    match xs with
+    | [] -> failwith "Schema shouldn't be empty"
+    | x :: [] -> Caqti_type.(t2 x unit)
+    | x :: xs -> Caqti_type.(t2 x (make_type xs))
+  ;;
+end
+
+let custom
+  : type a b.
+    encode:(b -> (a Data.t, string) result)
+    -> decode:(a -> (b, string) result)
+    -> a Schema.t
+    -> b Caqti_type.t
+  =
+  fun ~encode ~decode schema ->
+  let typ = Schema.make_type schema in
+  let encode data = encode data |> Result.map Data.make_value in
+  Caqti_type.custom ~encode ~decode typ
+;;
+
+let custom_ok
+  : type a b.
+    encode:(b -> a Data.t) -> decode:(a -> b) -> a Schema.t -> b Caqti_type.t
+  =
+  let open CCFun in
+  fun ~encode ~decode schema ->
+    let typ = Schema.make_type schema in
+    let encode = CCResult.(encode %> return %> map Data.make_value) in
+    Caqti_type.custom ~encode ~decode:(decode %> CCResult.return) typ
+;;

backend/database_pools.ml

@@ -213,6 +213,18 @@ module Make (Config : ConfigSig) = struct
 
   let transaction' ?ctx f = transaction ?ctx f |> Lwt.map (get_or_raise ?ctx ())
 
+  let exec_with_connection
+    (request : ('a, unit, [< `Zero ]) Caqti_request.t)
+    (input : 'a)
+    (connection : (module Caqti_lwt.CONNECTION))
+    : unit Lwt.t
+    =
+    let open CCFun in
+    let (module Connection : Caqti_lwt.CONNECTION) = connection in
+    Connection.exec request input
+    |> Lwt.map CCResult.(map_err Caqti_error.show %> get_or_failwith)
+  ;;
+
   let query ?ctx f =
     let open Lwt.Infix in
     let pool = fetch_pool ?ctx () in
@@ -248,4 +260,15 @@ module Make (Config : ConfigSig) = struct
       let module Connection = (val connection : Caqti_lwt.CONNECTION) in
       Connection.exec request input)
   ;;
+
+  let populate ?ctx table columns request input =
+    query' ?ctx (fun connection ->
+      let module Connection = (val connection : Caqti_lwt.CONNECTION) in
+      Connection.populate
+        ~table
+        ~columns
+        request
+        (Caqti_lwt.Stream.of_list input)
+      |> Lwt.map Caqti_error.uncongested)
+  ;;
 end

backend/database_pools_sig.ml

@@ -37,4 +37,18 @@ module type Sig = sig
     :  ?ctx:(string * string) list
     -> (Caqti_lwt.connection -> 'a)
     -> 'a Lwt.t
+
+  val exec_with_connection
+    :  ('a, unit, [< `Zero ]) Caqti_request.t
+    -> 'a
+    -> (module Caqti_lwt.CONNECTION)
+    -> unit Lwt.t
+
+  val populate
+    :  ?ctx:(string * string) list
+    -> string
+    -> string list
+    -> 'a Caqti_type.t
+    -> 'a list
+    -> unit Lwt.t
 end

backend/dune

@@ -19,4 +19,5 @@
    ppx_deriving.eq
    ppx_deriving.make
    ppx_deriving.ord
-   ppx_deriving.show)))
+   ppx_deriving.show
+   ppx_string)))

backend/mariadb_backend.ml

@@ -2,6 +2,11 @@ open CCFun
 open Lwt.Infix
 open Caqti_request.Infix
 
+let combine_lwt m =
+  let%lwt k = m in
+  k
+;;
+
 module Make
     (ActorModel : Guardian.RoleSig)
     (Role : Guardian.RoleSig)
@@ -221,6 +226,19 @@ struct
             (t3 Permission.t TargetModel.t (option Uuid.Target.t)))
       ;;
     end
+
+    module RoleAssignment = struct
+      include Guard.RoleAssignment
+
+      let t =
+        let open Caqti_encoders in
+        let decode (role, (target_role, ())) = Ok { role; target_role } in
+        let encode m : ('a Caqti_encoders.Data.t, string) result =
+          Ok Data.[ m.role; m.target_role ]
+        in
+        custom ~encode ~decode Schema.[ Role.t; Role.t ]
+      ;;
+    end
   end
 
   module DBCache = struct
@@ -257,6 +275,7 @@ struct
       type actor_role = Guard.ActorRole.t
       type permission_on_target = Guard.PermissionOnTarget.t
       type role = Role.t
+      type role_assignment = Guard.RoleAssignment.t
       type role_permission = Guard.RolePermission.t
       type target = Guard.Target.t
       type target_entity = Guard.TargetEntity.t
@@ -888,6 +907,78 @@ struct
           let promote ?ctx = CCFun.curry (Database.exec ?ctx promote_request)
         end
 
+        module RoleAssignment = struct
+          let table_name = "guardian_assign_roles"
+          let sql_insert_columns = [ "role"; "target_role" ]
+
+          let sql_select_columns =
+            [ "guardian_assign_roles.role"
+            ; "guardian_assign_roles.target_role"
+            ]
+          ;;
+
+          let default_where = Some "mark_as_deleted IS NULL"
+
+          let find_request_sql =
+            Mariadb_utils.find_request_sql
+              sql_select_columns
+              default_where
+              table_name
+              ~joins:""
+          ;;
+
+          let insert ?ctx =
+            Database.populate
+              ?ctx
+              table_name
+              sql_insert_columns
+              Entity.RoleAssignment.t
+          ;;
+
+          let find_all_request ?default_where () =
+            find_request_sql ?default_where ""
+            |> Caqti_type.(unit ->* Entity.RoleAssignment.t)
+          ;;
+
+          let find_all ?ctx ?default_where =
+            Database.collect ?ctx (find_all_request ?default_where ())
+          ;;
+
+          let find_all_by_role_request =
+            find_request_sql {sql|WHERE role = ?|sql}
+            |> Entity.(Role.t ->* RoleAssignment.t)
+          ;;
+
+          let find_all_by_role ?ctx =
+            Database.collect ?ctx find_all_by_role_request
+          ;;
+
+          let delete_add_history_request =
+            {sql|
+              INSERT INTO guardian_assign_roles_history (role, target_role, comment) VALUES (?,?,?)
+            |sql}
+            |> Caqti_type.(t2 Entity.RoleAssignment.t (option string) ->. unit)
+          ;;
+
+          let delete_remove_request =
+            {sql|
+                DELETE FROM guardian_assign_roles WHERE role = ? AND target_role = ?
+            |sql}
+            |> Entity.RoleAssignment.t ->. Caqti_type.unit
+          ;;
+
+          let delete ?ctx ?comment role =
+            let exec = Database.exec_with_connection in
+            (fun conn ->
+              let%lwt () =
+                exec delete_add_history_request (role, comment) conn
+              in
+              exec delete_remove_request role conn)
+            |> Database.transaction ?ctx
+            |> combine_lwt
+          ;;
+        end
+
         let validate_model ?ctx permission model actor_uuid =
           let open Lwt.Infix in
           let validate_request =

backend/mariadb_utils.ml

@@ -0,0 +1,27 @@
+let find_request_sql
+  sql_select_columns
+  default_where
+  table_name
+  ?(default_where = default_where)
+  ?(count = false)
+  ?(joins = "")
+  where_fragment
+  =
+  let where_fragment =
+    CCOption.map_or ~default:where_fragment (fun default_where ->
+      [%string
+        {sql|
+          WHERE %{default_where}
+            AND %{CCString.replace ~which:`Left ~by:"" ~sub:"WHERE" where_fragment}
+        |sql}])
+  in
+  let columns =
+    if count then "COUNT(*)" else sql_select_columns |> CCString.concat ", "
+  in
+  Format.asprintf
+    {sql|SELECT %s FROM %s %s %s|sql}
+    columns
+    table_name
+    joins
+    (where_fragment default_where)
+;;

backend/migrations.ml

@@ -198,6 +198,44 @@ let create_v2_guardian_actor_permissions_table =
 ;;
 
 let drop_relations = {sql|DROP TABLE IF EXISTS guardian_relations|sql}
+let drop_old_actors = {sql|DROP TABLE IF EXISTS guardian_actors_old|sql}
+
+let drop_old_actor_roles =
+  {sql|DROP TABLE IF EXISTS guardian_actor_roles_old|sql}
+;;
+
+let drop_old_targets = {sql|DROP TABLE IF EXISTS guardian_targets_old|sql}
+let drop_old_relations = {sql|DROP TABLE IF EXISTS guardian_relations_old|sql}
+let drop_old_rules = {sql|DROP TABLE IF EXISTS guardian_rules_old|sql}
+
+let create_guardian_assign_roles_table =
+  {sql|
+    CREATE TABLE IF NOT EXISTS guardian_assign_roles (
+      id bigint(20) unsigned NOT NULL AUTO_INCREMENT,
+      role varchar(255) NOT NULL,
+      target_role varchar(255) NOT NULL,
+      mark_as_deleted DATETIME,
+      created_at DATETIME DEFAULT CURRENT_TIMESTAMP,
+      updated_at DATETIME DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP,
+      CONSTRAINT unique_role_target_role UNIQUE (role, target_role),
+      PRIMARY KEY (id)
+    )
+  |sql}
+;;
+
+let create_guardian_assign_roles_history_table =
+  {sql|
+    CREATE TABLE IF NOT EXISTS guardian_assign_roles_history (
+      id bigint(20) unsigned NOT NULL AUTO_INCREMENT,
+      role varchar(255) NOT NULL,
+      target_role varchar(255) NOT NULL,
+      comment text NULL,
+      created_at DATETIME DEFAULT CURRENT_TIMESTAMP,
+      updated_at DATETIME DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP,
+      PRIMARY KEY (id)
+    )
+  |sql}
+;;
 
 let all_tables =
   [ "guardian_actors"
@@ -206,11 +244,8 @@ let all_tables =
   ; "guardian_targets"
   ; "guardian_role_permissions"
   ; "guardian_actor_permissions"
-  ; "guardian_actors_old"
-  ; "guardian_actor_roles_old"
-  ; "guardian_targets_old"
-  ; "guardian_relations_old"
-  ; "guardian_rules_old"
+  ; "guardian_assign_roles"
+  ; "guardian_assign_roles_history"
   ]
 ;;
 
@@ -253,5 +288,18 @@ let all =
     , "2023-08-18T15:21"
     , create_v2_guardian_actor_permissions_table )
   ; "drop guardian relations table", "2023-08-18T15:22", drop_relations
+  ; "drop old guardian actors table", "2024-01-17T09:00", drop_old_actors
+  ; ( "drop old guardian actor roles table"
+    , "2024-01-17T09:01"
+    , drop_old_actor_roles )
+  ; "drop old guardian targets table", "2024-01-17T09:02", drop_old_targets
+  ; "drop old guardian relations table", "2024-01-17T09:03", drop_old_relations
+  ; "drop old guardian rules table", "2024-01-17T09:04", drop_old_rules
+  ; ( "create guardian assign roles table"
+    , "2024-01-18T16:00"
+    , create_guardian_assign_roles_table )
+  ; ( "create guardian assign roles history table"
+    , "2024-01-18T16:01"
+    , create_guardian_assign_roles_history_table )
   ]
 ;;

dune-project

@@ -51,8 +51,12 @@
    (>= 5.2.1))
   (ppx_deriving_yojson
    (>= 3.6.1))
+  (ppx_fields_conv
+   (>= v0.16.0))
   (ppx_sexp_conv
    (>= 0.15.1))
+  (ppx_string
+   (>= v0.16.0))
   (uri
    (>= 4.2.0))
   (uuidm

guardian.opam

@@ -25,7 +25,9 @@ depends: [
   "ocaml" {>= "4.12.0"}
   "ppx_deriving" {>= "5.2.1"}
   "ppx_deriving_yojson" {>= "3.6.1"}
+  "ppx_fields_conv" {>= "v0.16.0"}
   "ppx_sexp_conv" {>= "0.15.1"}
+  "ppx_string" {>= "v0.16.0"}
   "uri" {>= "4.2.0"}
   "uuidm" {>= "0.9.8"}
   "yojson" {>= "2.0.2"}