-- | Permission utilities
module Calamity.Utils.Permissions
    ( basePermissions
    , applyOverwrites
    , PermissionsIn(..)
    , PermissionsIn'(..) ) where

import           Calamity.Client.Types
import           Calamity.Types.Model.Channel.Guild
import           Calamity.Types.Model.Guild.Guild
import           Calamity.Types.Model.Guild.Member
import           Calamity.Types.Model.Guild.Overwrite
import           Calamity.Types.Model.Guild.Permissions
import           Calamity.Types.Model.User
import           Calamity.Types.Snowflake
import           Calamity.Types.Upgradeable
import           Data.Maybe (mapMaybe)
import           Data.Flags
import qualified Data.Vector.Unboxing                   as V
import Optics
import qualified Polysemy                               as P
import Data.Foldable (Foldable(foldl'))
import qualified Calamity.Internal.SnowflakeMap as SM

-- | Calculate a 'Member'\'s 'Permissions' in a 'Guild'
basePermissions :: Guild -> Member -> Permissions
basePermissions :: Guild -> Member -> Permissions
basePermissions Guild
g Member
m
  | Guild
g forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "ownerID" a => a
#ownerID forall (a :: OpticKind). Eq a => a -> a -> Bool
== forall (b :: OpticKind) (a :: OpticKind).
HasID b a =>
a -> Snowflake b
getID Member
m = forall (α :: OpticKind). BoundedFlags α => α
allFlags
  | Bool
otherwise = let everyoneRole :: Maybe (IxValue (SnowflakeMap Role))
everyoneRole  = Guild
g forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "roles" a => a
#roles forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (m :: OpticKind).
At m =>
Index m -> Lens' m (Maybe (IxValue m))
at (forall (a :: OpticKind) (b :: OpticKind).
Snowflake a -> Snowflake b
coerceSnowflake forall (a :: OpticKind) b. (a -> b) -> a -> b
$ forall (b :: OpticKind) (a :: OpticKind).
HasID b a =>
a -> Snowflake b
getID @Guild Guild
g)
                    permsEveryone :: Permissions
permsEveryone = forall (b :: OpticKind) (a :: OpticKind).
b -> (a -> b) -> Maybe a -> b
maybe forall (α :: OpticKind). Flags α => α
noFlags (forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "permissions" a => a
#permissions) Maybe (IxValue (SnowflakeMap Role))
everyoneRole
                    roleIDs :: [Index (SnowflakeMap Role)]
roleIDs       = forall (a :: OpticKind). Unboxable a => Vector a -> [a]
V.toList forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Member
m forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "roles" a => a
#roles
                    rolePerms :: [Permissions]
rolePerms     = forall (a :: OpticKind) (b :: OpticKind).
(a -> Maybe b) -> [a] -> [b]
mapMaybe (\Index (SnowflakeMap Role)
rid -> Guild
g forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall (a :: OpticKind). IsLabel "roles" a => a
#roles forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (m :: OpticKind).
Ixed m =>
Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix Index (SnowflakeMap Role)
rid forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (a :: OpticKind). IsLabel "permissions" a => a
#permissions) [Index (SnowflakeMap Role)]
roleIDs
                    perms :: Permissions
perms         = forall (t :: OpticKind -> OpticKind) (b :: OpticKind)
       (a :: OpticKind).
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (α :: OpticKind). Flags α => α -> α -> α
andFlags forall (α :: OpticKind). Flags α => α
noFlags (Permissions
permsEveryoneforall (a :: OpticKind). a -> [a] -> [a]
:[Permissions]
rolePerms)
                in if Permissions
perms forall (α :: OpticKind). Flags α => α -> α -> Bool
.<=. Permissions
administrator
                   then forall (α :: OpticKind). BoundedFlags α => α
allFlags
                   else Permissions
perms

overwrites :: GuildChannel -> SM.SnowflakeMap Overwrite
overwrites :: GuildChannel -> SnowflakeMap Overwrite
overwrites (GuildTextChannel TextChannel
c) = TextChannel
c forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "permissionOverwrites" a => a
#permissionOverwrites
overwrites (GuildVoiceChannel VoiceChannel
c) = VoiceChannel
c forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "permissionOverwrites" a => a
#permissionOverwrites
overwrites (GuildCategory Category
c) = Category
c forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "permissionOverwrites" a => a
#permissionOverwrites
overwrites GuildChannel
_ = forall (a :: OpticKind). SnowflakeMap a
SM.empty

-- | Apply any 'Overwrite's for a 'GuildChannel' onto some 'Permissions'
applyOverwrites :: GuildChannel -> Member -> Permissions -> Permissions
applyOverwrites :: GuildChannel -> Member -> Permissions -> Permissions
applyOverwrites GuildChannel
c Member
m Permissions
p
  | Permissions
p forall (α :: OpticKind). Flags α => α -> α -> Bool
.<=. Permissions
administrator = forall (α :: OpticKind). BoundedFlags α => α
allFlags
  | Bool
otherwise =
    let everyoneOverwrite :: Maybe Overwrite
everyoneOverwrite = GuildChannel -> SnowflakeMap Overwrite
overwrites GuildChannel
c forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (m :: OpticKind).
At m =>
Index m -> Lens' m (Maybe (IxValue m))
at (forall (a :: OpticKind) (b :: OpticKind).
Snowflake a -> Snowflake b
coerceSnowflake forall (a :: OpticKind) b. (a -> b) -> a -> b
$ forall (b :: OpticKind) (a :: OpticKind).
HasID b a =>
a -> Snowflake b
getID @Guild GuildChannel
c)
        everyoneAllow :: Permissions
everyoneAllow     = forall (b :: OpticKind) (a :: OpticKind).
b -> (a -> b) -> Maybe a -> b
maybe forall (α :: OpticKind). Flags α => α
noFlags (forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "allow" a => a
#allow) Maybe Overwrite
everyoneOverwrite
        everyoneDeny :: Permissions
everyoneDeny      = forall (b :: OpticKind) (a :: OpticKind).
b -> (a -> b) -> Maybe a -> b
maybe forall (α :: OpticKind). Flags α => α
noFlags (forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "deny" a => a
#deny) Maybe Overwrite
everyoneOverwrite
        p' :: Permissions
p'                = Permissions
p forall (α :: OpticKind). Flags α => α -> α -> α
.-. Permissions
everyoneDeny forall (α :: OpticKind). Flags α => α -> α -> α
.+. Permissions
everyoneAllow
        roleOverwriteIDs :: [Snowflake Overwrite]
roleOverwriteIDs  = forall (a :: OpticKind) (b :: OpticKind). (a -> b) -> [a] -> [b]
map (forall (a :: OpticKind) (b :: OpticKind).
Snowflake a -> Snowflake b
coerceSnowflake @_ @Overwrite) forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (a :: OpticKind). Unboxable a => Vector a -> [a]
V.toList forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Member
m forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "roles" a => a
#roles
        roleOverwrites :: [Overwrite]
roleOverwrites    = forall (a :: OpticKind) (b :: OpticKind).
(a -> Maybe b) -> [a] -> [b]
mapMaybe (\Snowflake Overwrite
oid -> GuildChannel -> SnowflakeMap Overwrite
overwrites GuildChannel
c forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall (m :: OpticKind).
Ixed m =>
Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix Snowflake Overwrite
oid) [Snowflake Overwrite]
roleOverwriteIDs
        roleAllow :: Permissions
roleAllow         = forall (t :: OpticKind -> OpticKind) (b :: OpticKind)
       (a :: OpticKind).
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (α :: OpticKind). Flags α => α -> α -> α
andFlags forall (α :: OpticKind). Flags α => α
noFlags ([Overwrite]
roleOverwrites forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Fold =>
s -> Optic' k is s a -> [a]
^.. forall (t :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Traversable t =>
Traversal (t a) (t b) a b
traversed forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (a :: OpticKind). IsLabel "allow" a => a
#allow)
        roleDeny :: Permissions
roleDeny          = forall (t :: OpticKind -> OpticKind) (b :: OpticKind)
       (a :: OpticKind).
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (α :: OpticKind). Flags α => α -> α -> α
andFlags forall (α :: OpticKind). Flags α => α
noFlags ([Overwrite]
roleOverwrites forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Fold =>
s -> Optic' k is s a -> [a]
^.. forall (t :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Traversable t =>
Traversal (t a) (t b) a b
traversed forall (k :: OpticKind) (l :: OpticKind) (m :: OpticKind)
       (is :: IxList) (js :: IxList) (ks :: IxList) (s :: OpticKind)
       (t :: OpticKind) (u :: OpticKind) (v :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall (a :: OpticKind). IsLabel "deny" a => a
#deny)
        p'' :: Permissions
p''               = Permissions
p' forall (α :: OpticKind). Flags α => α -> α -> α
.-. Permissions
roleDeny forall (α :: OpticKind). Flags α => α -> α -> α
.+. Permissions
roleAllow
        memberOverwrite :: Maybe Overwrite
memberOverwrite   = GuildChannel -> SnowflakeMap Overwrite
overwrites GuildChannel
c forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (m :: OpticKind).
At m =>
Index m -> Lens' m (Maybe (IxValue m))
at (forall (a :: OpticKind) (b :: OpticKind).
Snowflake a -> Snowflake b
coerceSnowflake @_ @Overwrite forall (a :: OpticKind) b. (a -> b) -> a -> b
$ forall (b :: OpticKind) (a :: OpticKind).
HasID b a =>
a -> Snowflake b
getID @Member Member
m)
        memberAllow :: Permissions
memberAllow       = forall (b :: OpticKind) (a :: OpticKind).
b -> (a -> b) -> Maybe a -> b
maybe forall (α :: OpticKind). Flags α => α
noFlags (forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "allow" a => a
#allow) Maybe Overwrite
memberOverwrite
        memberDeny :: Permissions
memberDeny        = forall (b :: OpticKind) (a :: OpticKind).
b -> (a -> b) -> Maybe a -> b
maybe forall (α :: OpticKind). Flags α => α
noFlags (forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "deny" a => a
#deny) Maybe Overwrite
memberOverwrite
        p''' :: Permissions
p'''              = Permissions
p'' forall (α :: OpticKind). Flags α => α -> α -> α
.-. Permissions
memberDeny forall (α :: OpticKind). Flags α => α -> α -> α
.+. Permissions
memberAllow
    in Permissions
p'''

-- | Things that 'Member's have 'Permissions' in
class PermissionsIn a where
  -- | Calculate a 'Member'\'s 'Permissions' in something
  --
  -- If permissions could not be calculated because something couldn't be found
  -- in the cache, this will return an empty set of permissions. Use
  -- 'permissionsIn'' if you want to handle cases where something might not exist
  -- in cache.
  permissionsIn :: a -> Member -> Permissions

-- | A 'Member'\'s 'Permissions' in a channel are their roles and overwrites
instance PermissionsIn (Guild, GuildChannel) where
  permissionsIn :: (Guild, GuildChannel) -> Member -> Permissions
permissionsIn (Guild
g, GuildChannel
c) Member
m = GuildChannel -> Member -> Permissions -> Permissions
applyOverwrites GuildChannel
c Member
m forall (a :: OpticKind) b. (a -> b) -> a -> b
$ Guild -> Member -> Permissions
basePermissions Guild
g Member
m

-- | A 'Member'\'s 'Permissions' in a guild are just their roles
instance PermissionsIn Guild where
  permissionsIn :: Guild -> Member -> Permissions
permissionsIn Guild
g Member
m = Guild -> Member -> Permissions
basePermissions Guild
g Member
m

-- | A variant of 'PermissionsIn' that will use the cache/http.
class PermissionsIn' a where
  -- | Calculate the permissions of something that has a 'User' id
  permissionsIn' :: (BotC r, HasID User u) => a -> u -> P.Sem r Permissions

-- | A 'User''s 'Permissions' in a channel are their roles and overwrites
--
-- This will fetch the guild from the cache or http as needed
instance PermissionsIn' GuildChannel where
  permissionsIn' :: forall (r :: EffectRow) (u :: OpticKind).
(BotC r, HasID User u) =>
GuildChannel -> u -> Sem r Permissions
permissionsIn' GuildChannel
c (forall (b :: OpticKind) (a :: OpticKind).
HasID b a =>
a -> Snowflake b
getID @User -> Snowflake User
uid) = do
    Maybe Member
m <- forall (a :: OpticKind) (ids :: OpticKind) (r :: EffectRow).
(Upgradeable a ids, BotC r) =>
ids -> Sem r (Maybe a)
upgrade (forall (b :: OpticKind) (a :: OpticKind).
HasID b a =>
a -> Snowflake b
getID @Guild GuildChannel
c, forall (a :: OpticKind) (b :: OpticKind).
Snowflake a -> Snowflake b
coerceSnowflake @_ @Member Snowflake User
uid)
    Maybe Guild
g <- forall (a :: OpticKind) (ids :: OpticKind) (r :: EffectRow).
(Upgradeable a ids, BotC r) =>
ids -> Sem r (Maybe a)
upgrade (forall (b :: OpticKind) (a :: OpticKind).
HasID b a =>
a -> Snowflake b
getID @Guild GuildChannel
c)
    case (Maybe Member
m, Maybe Guild
g) of
      (Just Member
m, Just Guild
g') -> forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> a -> b
$ forall (a :: OpticKind).
PermissionsIn a =>
a -> Member -> Permissions
permissionsIn (Guild
g', GuildChannel
c) Member
m
      (Maybe Member, Maybe Guild)
_cantFind         -> forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (α :: OpticKind). Flags α => α
noFlags

-- | A 'Member'\'s 'Permissions' in a guild are just their roles
instance PermissionsIn' Guild where
  permissionsIn' :: forall (r :: EffectRow) (u :: OpticKind).
(BotC r, HasID User u) =>
Guild -> u -> Sem r Permissions
permissionsIn' Guild
g (forall (b :: OpticKind) (a :: OpticKind).
HasID b a =>
a -> Snowflake b
getID @User -> Snowflake User
uid) = do
    Maybe Member
m <- forall (a :: OpticKind) (ids :: OpticKind) (r :: EffectRow).
(Upgradeable a ids, BotC r) =>
ids -> Sem r (Maybe a)
upgrade (forall (b :: OpticKind) (a :: OpticKind).
HasID b a =>
a -> Snowflake b
getID @Guild Guild
g, forall (a :: OpticKind) (b :: OpticKind).
Snowflake a -> Snowflake b
coerceSnowflake @_ @Member Snowflake User
uid)
    case Maybe Member
m of
      Just Member
m' -> forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (a :: OpticKind) b. (a -> b) -> a -> b
$ forall (a :: OpticKind).
PermissionsIn a =>
a -> Member -> Permissions
permissionsIn Guild
g Member
m'
      Maybe Member
Nothing -> forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (α :: OpticKind). Flags α => α
noFlags

-- | A 'Member'\'s 'Permissions' in a channel are their roles and overwrites
--
-- This will fetch the guild and channel from the cache or http as needed
instance PermissionsIn' (Snowflake GuildChannel) where
  permissionsIn' :: forall (r :: EffectRow) (u :: OpticKind).
(BotC r, HasID User u) =>
Snowflake GuildChannel -> u -> Sem r Permissions
permissionsIn' Snowflake GuildChannel
cid u
u = do
    Maybe GuildChannel
c <- forall (a :: OpticKind) (ids :: OpticKind) (r :: EffectRow).
(Upgradeable a ids, BotC r) =>
ids -> Sem r (Maybe a)
upgrade Snowflake GuildChannel
cid
    case Maybe GuildChannel
c of
      Just GuildChannel
c'  -> forall (a :: OpticKind) (r :: EffectRow) (u :: OpticKind).
(PermissionsIn' a, BotC r, HasID User u) =>
a -> u -> Sem r Permissions
permissionsIn' GuildChannel
c' u
u
      Maybe GuildChannel
Nothing  -> forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (α :: OpticKind). Flags α => α
noFlags

-- | A 'Member'\'s 'Permissions' in a guild are just their roles
--
-- This will fetch the guild from the cache or http as needed
instance PermissionsIn' (Snowflake Guild) where
  permissionsIn' :: forall (r :: EffectRow) (u :: OpticKind).
(BotC r, HasID User u) =>
Snowflake Guild -> u -> Sem r Permissions
permissionsIn' Snowflake Guild
gid u
u = do
    Maybe Guild
g <- forall (a :: OpticKind) (ids :: OpticKind) (r :: EffectRow).
(Upgradeable a ids, BotC r) =>
ids -> Sem r (Maybe a)
upgrade Snowflake Guild
gid
    case Maybe Guild
g of
      Just Guild
g' -> forall (a :: OpticKind) (r :: EffectRow) (u :: OpticKind).
(PermissionsIn' a, BotC r, HasID User u) =>
a -> u -> Sem r Permissions
permissionsIn' Guild
g' u
u
      Maybe Guild
Nothing -> forall (f :: OpticKind -> OpticKind) (a :: OpticKind).
Applicative f =>
a -> f a
pure forall (α :: OpticKind). Flags α => α
noFlags