Profpatsch · September 2, 2024 12:16
diff --git a/Permission.hs b/Permission.hs
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}

 module Permissions
  ( Permission,
    PermissionLabel,
    HasPermission,

    -- * Creating permissions
    conjurePermission,
    conjureMapPermission,

    -- * Requiring permissions
    requirePermission,
    requirePermissionValue,
  )
 where

 import GHC.Records (HasField (..))
 import GHC.TypeLits (Symbol)
 import Label
 import PossehlAnalyticsPrelude

 -- | A Permission is a simple token that contains a proof of required permission to call a function/method.
 --
 -- Each permission should have a unique name, and creating them
 -- must depend on actually checking whether this permission exists for the given context/user.
 --
 -- For example, a the @createUser@ method will take an argument @Permission "CreateUser" ()@.
 -- This permission can only be created by running the @assertUserPermission@ function,
 -- which checks the actual permissions of a user, and returns @Maybe (Permission "CreateUser"()@.
 --
 -- This way, if you want to call the @createUser@ method, you can /only/ do so if you have
 -- checked for the required permission beforehand.
 --
 -- Permissions can also carry more data, for example a @Permission "CanAccessDevices" [DeviceId]@
 -- would carry the ids of all devices that are accessible.
 data Permission (perm :: Symbol) a = Permission a

 -- | A 'Permission' wrapped in a 'Label' with its name; This allows us to combine multiple permissions by wrapping in 'T2' or 'T3' and check all of them the same, via the 'HasPermission' constraint.
 type PermissionLabel perm val = Label perm (Permission perm val)

 -- | A constraint that requires the user of this function to provide the given permission.
 --
 -- A permission is a proof that we have somehow checked that this permission is given before calling this function.
 type HasPermission perm perms a = HasField perm perms (Permission perm a)

 instance (Show a) => Show (Permission perms a) where
  show (Permission perm) = "Permission " <> show perm

 -- | Create a new permission token from “nothing”.
 --
 -- This must /only/ be done after checking that the permission is actually given.
 conjurePermission :: forall (perm :: Symbol) a. a -> PermissionLabel perm a
 conjurePermission a = label @perm $ Permission a

 -- | Map a function over the permission value; this must *not* change the guarantee the permission gives!
 conjureMapPermission :: forall (perm :: Symbol) a b. (a -> b) -> PermissionLabel perm a -> PermissionLabel perm b
 conjureMapPermission f perm = do
  let (Permission a) = getField @perm perm
  conjurePermission $ f a

 -- | “Consume” a @Permission@, this will put the burden on callers to pass @Permission@ tokens
 -- with all the permissions required here.
 --
 -- This is intended to be called like
 --
 -- @@
 -- requirePermission @"myPermission" perms
 -- @@
 requirePermission ::
  forall perm a perms m.
  ( Applicative m,
    HasPermission perm perms a
  ) =>
  perms ->
  m ()
 requirePermission perms = do
  let _perm = getField @perm perms
  pure ()

 -- | Read a single value out of the given permission.
 --
 -- Which value to read should be specified with a type application, like so:
 --
 -- @requirePermissionValue \@"thispermission" perms@
 requirePermissionValue ::
  forall perm val perms m.
  ( Applicative m,
    -- The fields of the inner record
    HasPermission perm perms val
  ) =>
  perms ->
  m val
 requirePermissionValue perms = do
  let (Permission perm) = getField @perm perms
  pure perm
	{-# LANGUAGE AllowAmbiguousTypes #-}
	{-# LANGUAGE PolyKinds #-}
	{-# LANGUAGE TypeFamilies #-}
	{-# LANGUAGE UndecidableInstances #-}

	module Permissions
	( Permission,
	PermissionLabel,
	HasPermission,

	-- * Creating permissions
	conjurePermission,
	conjureMapPermission,

	-- * Requiring permissions
	requirePermission,
	requirePermissionValue,
	)
	where

	import GHC.Records (HasField (..))
	import GHC.TypeLits (Symbol)
	import Label
	import PossehlAnalyticsPrelude

	-- \| A Permission is a simple token that contains a proof of required permission to call a function/method.
	--
	-- Each permission should have a unique name, and creating them
	-- must depend on actually checking whether this permission exists for the given context/user.
	--
	-- For example, a the @createUser@ method will take an argument @Permission "CreateUser" ()@.
	-- This permission can only be created by running the @assertUserPermission@ function,
	-- which checks the actual permissions of a user, and returns @Maybe (Permission "CreateUser"()@.
	--
	-- This way, if you want to call the @createUser@ method, you can /only/ do so if you have
	-- checked for the required permission beforehand.
	--
	-- Permissions can also carry more data, for example a @Permission "CanAccessDevices" [DeviceId]@
	-- would carry the ids of all devices that are accessible.
	data Permission (perm :: Symbol) a = Permission a

	-- \| A 'Permission' wrapped in a 'Label' with its name; This allows us to combine multiple permissions by wrapping in 'T2' or 'T3' and check all of them the same, via the 'HasPermission' constraint.
	type PermissionLabel perm val = Label perm (Permission perm val)

	-- \| A constraint that requires the user of this function to provide the given permission.
	--
	-- A permission is a proof that we have somehow checked that this permission is given before calling this function.
	type HasPermission perm perms a = HasField perm perms (Permission perm a)

	instance (Show a) => Show (Permission perms a) where
	show (Permission perm) = "Permission " <> show perm

	-- \| Create a new permission token from “nothing”.
	--
	-- This must /only/ be done after checking that the permission is actually given.
	conjurePermission :: forall (perm :: Symbol) a. a -> PermissionLabel perm a
	conjurePermission a = label @perm $ Permission a

	-- \| Map a function over the permission value; this must not change the guarantee the permission gives!
	conjureMapPermission :: forall (perm :: Symbol) a b. (a -> b) -> PermissionLabel perm a -> PermissionLabel perm b
	conjureMapPermission f perm = do
	let (Permission a) = getField @perm perm
	conjurePermission $ f a

	-- \| “Consume” a @Permission@, this will put the burden on callers to pass @Permission@ tokens
	-- with all the permissions required here.
	--
	-- This is intended to be called like
	--
	-- @@
	-- requirePermission @"myPermission" perms
	-- @@
	requirePermission ::
	forall perm a perms m.
	( Applicative m,
	HasPermission perm perms a
	) =>
	perms ->
	m ()
	requirePermission perms = do
	let _perm = getField @perm perms
	pure ()

	-- \| Read a single value out of the given permission.
	--
	-- Which value to read should be specified with a type application, like so:
	--
	-- @requirePermissionValue \@"thispermission" perms@
	requirePermissionValue ::
	forall perm val perms m.
	( Applicative m,
	-- The fields of the inner record
	HasPermission perm perms val
	) =>
	perms ->
	m val
	requirePermissionValue perms = do
	let (Permission perm) = getField @perm perms
	pure perm