A simple record-based capability system in Haskell

Permissions.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Permissions
  ( Permission,

    -- * Creating permissions
    createPermission,
    SimplePermission,
    AllValuesUnit,
    ConstUnit,
    createSimplePermissions,

    -- * Requiring permissions
    requirePermissions,
    permissionValue,
    withPermissions,

    -- * Managing permissions
    combinePermissions,
    permissionSubset,

    -- * displaying permissions
    permissionNames,

    -- * Re-exports From superrecord
    Rec.Has,
    (Rec.:=),
    Rec.UnsafeRecBuild,
    Rec.Sort,
    Rec.RecKeys,
  )
where

import Data.Kind (Type)
import GHC.TypeLits (KnownNat, KnownSymbol, Symbol, type (+))
import PossehlAnalyticsPrelude
import qualified SuperRecord as Rec

-- | A Permission is a simple token that contains a set of required permissions 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 @assertUserPermissions@ 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.
newtype Permission (perms :: [Type]) = Permission (Rec.Rec (Rec.Sort perms))

instance
  ( rec ~ Rec.Sort perms,
    Rec.RecApply rec rec (Rec.ConstC Show)
  ) =>
  Show (Permission perms)
  where
  show (Permission perms) = "Permission " <> show perms

-- | Create a new permission token from “nothing”.
--
-- This must /only/ be done after checking that the permission is actually given.
createPermission ::
  forall name value.
  KnownSymbol name =>
  value ->
  Permission '[name Rec.:= value]
createPermission val =
  Permission
    ( Rec.rnil
        & Rec.rcons ((Rec.FldProxy @name) Rec.:= val)
    )

-- | A 'Permission' where all Permission values are empty (@()@).
--
-- Can be constructed with a simple list of strings:
--
-- @SimplePermission '["perm1", "perm2"]@
type SimplePermission permList = Permission (AllValuesUnit permList)

-- | Takes a type level list of strings and returns a 'Rec.Rec' with the given keys, where all values are @()@.
type family AllValuesUnit (perms :: [Symbol]) where
  AllValuesUnit '[] = '[]
  AllValuesUnit (perm : perms) = perm Rec.:= () : AllValuesUnit perms

-- | Create a multiple simple permission tokens from “nothing”.
--
-- This must /only/ be done after checking that the permissions are actually given.
createSimplePermissions ::
  forall (permList :: [Symbol]) perms.
  ( Rec.UnsafeRecBuild (Rec.Sort perms) (Rec.Sort perms) ConstUnit
  ) =>
  Proxy permList ->
  Permission perms
createSimplePermissions Proxy =
  Permission $ Rec.recBuildPure @ConstUnit @perms (\_key _proxy -> ())

-- | Helper Constraint for 'createSimplePermissions', asserts that all values in the given Permission are equal to @()@.
class val ~ () => ConstUnit lbl val

instance val ~ () => ConstUnit lbl val

-- | “Consume” some @SimplePermission@s, this will put the burden on callers to pass @Permission@ tokens
-- with all the permissions required here.
--
-- This is intended to be called like
--
-- @requirePermissions (Proxy @'["CreateUser", "DeleteUser"]) perms@
--
-- which asserts that perms has to be @Permission '["CreateUser" := (), "DeleteUser" := ()]@.
requirePermissions :: forall permList m. (Applicative m) => Proxy permList -> SimplePermission permList -> m ()
requirePermissions Proxy (Permission _perms) = pure ()

-- | Read a single value out of the given permission.
--
-- Which value to read should be specified with a type application, like so:
--
-- @permissionValue @"thispermission" perms@
permissionValue ::
  forall perm val perms recFields.
  ( -- The fields of the inner record
    recFields ~ Rec.Sort perms,
    Rec.Has recFields perm val
  ) =>
  Permission perms ->
  val
permissionValue (Permission perms) = Rec.get (Rec.FldProxy @perm) perms

-- | "Consume" some @Permission@s, this will put the burden on callers to pass @Permission@ tokens
-- with all the permissions required here.
--
-- The internal record is then made accessible to the inner function, so that the fields can be accessed.
withPermissions :: forall perms a. Permission perms -> (Rec.Rec (Rec.Sort perms) -> a) -> a
withPermissions (Permission perms) inner = inner perms

-- | Combine the given permissions into one permission.
combinePermissions ::
  ( KnownNat (Rec.RecSize (Rec.Sort perms1)),
    KnownNat (Rec.RecSize (Rec.Sort perms2)),
    KnownNat (Rec.RecSize (Rec.Sort perms1) + Rec.RecSize (Rec.Sort perms2)),
    Rec.RecCopy (Rec.Sort perms1) (Rec.Sort perms1) (Rec.Sort combinedPerms),
    Rec.RecCopy (Rec.Sort perms2) (Rec.Sort perms2) (Rec.Sort combinedPerms),
    Rec.Sort (Rec.RecAppend (Rec.Sort perms1) (Rec.Sort perms2)) ~ Rec.Sort combinedPerms
  ) =>
  Permission perms1 ->
  Permission perms2 ->
  Permission combinedPerms
combinePermissions (Permission p1) (Permission p2) =
  Permission (Rec.combine p1 p2)

-- | Get a subset of the given permission.
--
--  This can be used if the function you want to pass a 'Permission' to needs *less* permissions.
permissionSubset ::
  Rec.UnsafeRecBuild
    (Rec.Sort permsSubset)
    (Rec.Sort permsSubset)
    (Rec.Has (Rec.Sort permsBigger)) =>
  Permission permsBigger ->
  Permission permsSubset
permissionSubset (Permission perm) = Permission $ Rec.project perm

-- | Get the names (keys) of the given permissions.
-- This is useful for e.g. displaying in log messages.
permissionNames ::
  forall perms permission.
  Rec.RecKeys perms =>
  -- |  This can be a @Permission perms@, but you can pass any @[Type] -> [Type]@, for example a @Proxy perms@.
  permission perms ->
  [Text]
permissionNames perms = Rec.recKeys perms <&> stringToText

-- | Test that all our permission-based logic typechecks.
--
-- This is a “unit test” in the sense that the permission stuff
-- is nearly all on the type level, so if this typechecks it works.
_testHandler :: ()
_testHandler = do
  -- A permission with a single field
  let mypermission = (createPermission @"mypermission" ())
  -- test that we can combine multiple permissions
  let morepermission :: SimplePermission '["mypermission", "otherpermission", "thirdpermission"] =
        combinePermissions
          mypermission
          ( combinePermissions
              (createPermission @"otherpermission" ())
              (createPermission @"thirdpermission" ()) ::
              -- Hm, we have to give this type signature, otherwise GHC can’t infer the list of permissions for this combinePermissions.
              -- It has to do with `Rec.Sort`, maybe it would be solved if we didn’t require `Permission` to be a `Rec.Sort (Rec.Rec perms)`.
              -- I put the `Sort` there because I hoped it would speed up a lot of the type-checker comparisons, but maybe that’s not necessary?
              SimplePermission '["otherpermission", "thirdpermission"]
          )
  let _m = _testRequirePermissions @Identity mypermission
  -- check
  let _m2 = _testRequirePermissions @Identity (permissionSubset morepermission)
  let _deviceIds :: [Int] = _testWithPermissions (createPermission @"deviceAccess" [123, 456])
  -- maybe easier, you can access the permission directly with getPermissionValue. Might want to remove `withPermissions`.
  let _deviceIds' :: [Int] = permissionValue @"deviceAccess" (createPermission @"deviceAccess" [123, 456])
  ()

-- | Test
_testRequirePermissions ::
  (Applicative m) =>
  Permission '["mypermission" Rec.:= ()] ->
  m ()
_testRequirePermissions perms = requirePermissions (Proxy @'["mypermission"]) perms

_testWithPermissions ::
  forall perms.
  (perms ~ '["deviceAccess" Rec.:= [Int]]) =>
  Permission perms ->
  [Int]
_testWithPermissions perms = withPermissions perms (Rec.get #deviceAccess)