A simple capability-based type- and value-level permission system for Haskell projects

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