{-# LANGUAGE TemplateHaskell #-}

module Hasura.RQL.Types.Allowlist
  ( -- | The schema cache representation of the allowlist
    InlinedAllowlist (..),
    inlineAllowlist,
    AllowlistMode (..),
    allowlistAllowsQuery,
    -- | The normalised metadata representation of the allowlist
    AllowlistEntry (..),
    UpdateScopeOfCollectionInAllowlist (..),
    MetadataAllowlist,
    DropCollectionFromAllowlist (..),
    AllowlistScope (..),
    metadataAllowlistInsert,
    metadataAllowlistUpdateScope,
    metadataAllowlistAllCollections,
    NormalizedQuery (..),
  )
where

import Data.Aeson
import Data.Aeson.TH (deriveJSON, deriveToJSON)
import Data.HashMap.Strict.Extended qualified as M
import Data.HashMap.Strict.InsOrd.Extended qualified as OM
import Data.HashSet qualified as S
import Data.Text.Extended ((<<>))
import Hasura.GraphQL.Parser.Name qualified as GName
import Hasura.Prelude
import Hasura.RQL.Types.QueryCollection
import Hasura.Session (RoleName)
import Language.GraphQL.Draft.Syntax qualified as G

newtype DropCollectionFromAllowlist = DropCollectionFromAllowlist
  { DropCollectionFromAllowlist -> CollectionName
_dcfaCollection :: CollectionName
  }
  deriving (Int -> DropCollectionFromAllowlist -> ShowS
[DropCollectionFromAllowlist] -> ShowS
DropCollectionFromAllowlist -> String
(Int -> DropCollectionFromAllowlist -> ShowS)
-> (DropCollectionFromAllowlist -> String)
-> ([DropCollectionFromAllowlist] -> ShowS)
-> Show DropCollectionFromAllowlist
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DropCollectionFromAllowlist] -> ShowS
$cshowList :: [DropCollectionFromAllowlist] -> ShowS
show :: DropCollectionFromAllowlist -> String
$cshow :: DropCollectionFromAllowlist -> String
showsPrec :: Int -> DropCollectionFromAllowlist -> ShowS
$cshowsPrec :: Int -> DropCollectionFromAllowlist -> ShowS
Show, DropCollectionFromAllowlist -> DropCollectionFromAllowlist -> Bool
(DropCollectionFromAllowlist
 -> DropCollectionFromAllowlist -> Bool)
-> (DropCollectionFromAllowlist
    -> DropCollectionFromAllowlist -> Bool)
-> Eq DropCollectionFromAllowlist
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DropCollectionFromAllowlist -> DropCollectionFromAllowlist -> Bool
$c/= :: DropCollectionFromAllowlist -> DropCollectionFromAllowlist -> Bool
== :: DropCollectionFromAllowlist -> DropCollectionFromAllowlist -> Bool
$c== :: DropCollectionFromAllowlist -> DropCollectionFromAllowlist -> Bool
Eq)

$(deriveJSON hasuraJSON ''DropCollectionFromAllowlist)

data AllowlistScope
  = AllowlistScopeGlobal
  | AllowlistScopeRoles (NonEmpty RoleName)
  deriving (Int -> AllowlistScope -> ShowS
[AllowlistScope] -> ShowS
AllowlistScope -> String
(Int -> AllowlistScope -> ShowS)
-> (AllowlistScope -> String)
-> ([AllowlistScope] -> ShowS)
-> Show AllowlistScope
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AllowlistScope] -> ShowS
$cshowList :: [AllowlistScope] -> ShowS
show :: AllowlistScope -> String
$cshow :: AllowlistScope -> String
showsPrec :: Int -> AllowlistScope -> ShowS
$cshowsPrec :: Int -> AllowlistScope -> ShowS
Show, AllowlistScope -> AllowlistScope -> Bool
(AllowlistScope -> AllowlistScope -> Bool)
-> (AllowlistScope -> AllowlistScope -> Bool) -> Eq AllowlistScope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AllowlistScope -> AllowlistScope -> Bool
$c/= :: AllowlistScope -> AllowlistScope -> Bool
== :: AllowlistScope -> AllowlistScope -> Bool
$c== :: AllowlistScope -> AllowlistScope -> Bool
Eq, (forall x. AllowlistScope -> Rep AllowlistScope x)
-> (forall x. Rep AllowlistScope x -> AllowlistScope)
-> Generic AllowlistScope
forall x. Rep AllowlistScope x -> AllowlistScope
forall x. AllowlistScope -> Rep AllowlistScope x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AllowlistScope x -> AllowlistScope
$cfrom :: forall x. AllowlistScope -> Rep AllowlistScope x
Generic)

instance FromJSON AllowlistScope where
  parseJSON :: Value -> Parser AllowlistScope
parseJSON = String
-> (Object -> Parser AllowlistScope)
-> Value
-> Parser AllowlistScope
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"AllowlistScope" ((Object -> Parser AllowlistScope)
 -> Value -> Parser AllowlistScope)
-> (Object -> Parser AllowlistScope)
-> Value
-> Parser AllowlistScope
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Bool
global <- Object
o Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"global"
    if Bool
global
      then do
        Maybe (NonEmpty RoleName)
roles :: Maybe (NonEmpty RoleName) <- Object
o Object -> Key -> Parser (Maybe (NonEmpty RoleName))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"roles"
        case Maybe (NonEmpty RoleName)
roles of
          Maybe (NonEmpty RoleName)
Nothing -> AllowlistScope -> Parser AllowlistScope
forall (f :: * -> *) a. Applicative f => a -> f a
pure AllowlistScope
AllowlistScopeGlobal
          Just {} -> String -> Parser AllowlistScope
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"roles are not allowed when global is true"
      else do
        NonEmpty RoleName
roles <- Object
o Object -> Key -> Parser (NonEmpty RoleName)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"roles"
        if (NonEmpty RoleName -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty RoleName
roles Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= HashSet RoleName -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([RoleName] -> HashSet RoleName
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList (NonEmpty RoleName -> [RoleName]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty RoleName
roles)))
          then String -> Parser AllowlistScope
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"duplicate roles are not allowed"
          else AllowlistScope -> Parser AllowlistScope
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AllowlistScope -> Parser AllowlistScope)
-> AllowlistScope -> Parser AllowlistScope
forall a b. (a -> b) -> a -> b
$ NonEmpty RoleName -> AllowlistScope
AllowlistScopeRoles NonEmpty RoleName
roles

instance ToJSON AllowlistScope where
  toJSON :: AllowlistScope -> Value
toJSON AllowlistScope
scope = case AllowlistScope
scope of
    AllowlistScope
AllowlistScopeGlobal -> [Pair] -> Value
object [Key
"global" Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
True]
    AllowlistScopeRoles NonEmpty RoleName
roles -> [Pair] -> Value
object [Key
"global" Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
False, Key
"roles" Key -> NonEmpty RoleName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NonEmpty RoleName
roles]

data AllowlistEntry = AllowlistEntry
  { AllowlistEntry -> CollectionName
aeCollection :: CollectionName,
    AllowlistEntry -> AllowlistScope
aeScope :: AllowlistScope
  }
  deriving (Int -> AllowlistEntry -> ShowS
[AllowlistEntry] -> ShowS
AllowlistEntry -> String
(Int -> AllowlistEntry -> ShowS)
-> (AllowlistEntry -> String)
-> ([AllowlistEntry] -> ShowS)
-> Show AllowlistEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AllowlistEntry] -> ShowS
$cshowList :: [AllowlistEntry] -> ShowS
show :: AllowlistEntry -> String
$cshow :: AllowlistEntry -> String
showsPrec :: Int -> AllowlistEntry -> ShowS
$cshowsPrec :: Int -> AllowlistEntry -> ShowS
Show, AllowlistEntry -> AllowlistEntry -> Bool
(AllowlistEntry -> AllowlistEntry -> Bool)
-> (AllowlistEntry -> AllowlistEntry -> Bool) -> Eq AllowlistEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AllowlistEntry -> AllowlistEntry -> Bool
$c/= :: AllowlistEntry -> AllowlistEntry -> Bool
== :: AllowlistEntry -> AllowlistEntry -> Bool
$c== :: AllowlistEntry -> AllowlistEntry -> Bool
Eq, (forall x. AllowlistEntry -> Rep AllowlistEntry x)
-> (forall x. Rep AllowlistEntry x -> AllowlistEntry)
-> Generic AllowlistEntry
forall x. Rep AllowlistEntry x -> AllowlistEntry
forall x. AllowlistEntry -> Rep AllowlistEntry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AllowlistEntry x -> AllowlistEntry
$cfrom :: forall x. AllowlistEntry -> Rep AllowlistEntry x
Generic)

$(deriveToJSON hasuraJSON ''AllowlistEntry)

instance FromJSON AllowlistEntry where
  parseJSON :: Value -> Parser AllowlistEntry
parseJSON = String
-> (Object -> Parser AllowlistEntry)
-> Value
-> Parser AllowlistEntry
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"AllowlistEntry" \Object
o -> do
    CollectionName
collectionName <- Object
o Object -> Key -> Parser CollectionName
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"collection"
    AllowlistScope
scope <- Object
o Object -> Key -> Parser (Maybe AllowlistScope)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"scope" Parser (Maybe AllowlistScope)
-> AllowlistScope -> Parser AllowlistScope
forall a. Parser (Maybe a) -> a -> Parser a
.!= AllowlistScope
AllowlistScopeGlobal
    AllowlistEntry -> Parser AllowlistEntry
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AllowlistEntry -> Parser AllowlistEntry)
-> AllowlistEntry -> Parser AllowlistEntry
forall a b. (a -> b) -> a -> b
$ CollectionName -> AllowlistScope -> AllowlistEntry
AllowlistEntry CollectionName
collectionName AllowlistScope
scope

-- | Wrap 'AllowlistEntry' with a FromJSON instance that requires 'scope' to be set.
newtype UpdateScopeOfCollectionInAllowlist = UpdateScopeOfCollectionInAllowlist AllowlistEntry

instance FromJSON UpdateScopeOfCollectionInAllowlist where
  parseJSON :: Value -> Parser UpdateScopeOfCollectionInAllowlist
parseJSON = String
-> (Object -> Parser UpdateScopeOfCollectionInAllowlist)
-> Value
-> Parser UpdateScopeOfCollectionInAllowlist
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"UpdateScopeOfCollectionInAllowlist" \Object
o -> do
    CollectionName
collectionName <- Object
o Object -> Key -> Parser CollectionName
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"collection"
    AllowlistScope
scope <- Object
o Object -> Key -> Parser AllowlistScope
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"scope"
    UpdateScopeOfCollectionInAllowlist
-> Parser UpdateScopeOfCollectionInAllowlist
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateScopeOfCollectionInAllowlist
 -> Parser UpdateScopeOfCollectionInAllowlist)
-> UpdateScopeOfCollectionInAllowlist
-> Parser UpdateScopeOfCollectionInAllowlist
forall a b. (a -> b) -> a -> b
$ AllowlistEntry -> UpdateScopeOfCollectionInAllowlist
UpdateScopeOfCollectionInAllowlist (AllowlistEntry -> UpdateScopeOfCollectionInAllowlist)
-> AllowlistEntry -> UpdateScopeOfCollectionInAllowlist
forall a b. (a -> b) -> a -> b
$ CollectionName -> AllowlistScope -> AllowlistEntry
AllowlistEntry CollectionName
collectionName AllowlistScope
scope

type MetadataAllowlist = InsOrdHashMap CollectionName AllowlistEntry

metadataAllowlistInsert ::
  AllowlistEntry -> MetadataAllowlist -> Either Text MetadataAllowlist
metadataAllowlistInsert :: AllowlistEntry
-> MetadataAllowlist -> Either Text MetadataAllowlist
metadataAllowlistInsert entry :: AllowlistEntry
entry@(AllowlistEntry CollectionName
coll AllowlistScope
_) MetadataAllowlist
al =
  (Maybe AllowlistEntry -> Either Text (Maybe AllowlistEntry))
-> CollectionName
-> MetadataAllowlist
-> Either Text MetadataAllowlist
forall (f :: * -> *) k v.
(Functor f, Eq k, Hashable k) =>
(Maybe v -> f (Maybe v))
-> k -> InsOrdHashMap k v -> f (InsOrdHashMap k v)
OM.alterF Maybe AllowlistEntry -> Either Text (Maybe AllowlistEntry)
insertIfAbsent CollectionName
coll MetadataAllowlist
al
  where
    insertIfAbsent :: Maybe AllowlistEntry -> Either Text (Maybe AllowlistEntry)
insertIfAbsent = \case
      Maybe AllowlistEntry
Nothing -> Maybe AllowlistEntry -> Either Text (Maybe AllowlistEntry)
forall a b. b -> Either a b
Right (AllowlistEntry -> Maybe AllowlistEntry
forall a. a -> Maybe a
Just AllowlistEntry
entry)
      Just AllowlistEntry
_ ->
        Text -> Either Text (Maybe AllowlistEntry)
forall a b. a -> Either a b
Left (Text -> Either Text (Maybe AllowlistEntry))
-> Text -> Either Text (Maybe AllowlistEntry)
forall a b. (a -> b) -> a -> b
$
          Text
"collection " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CollectionName
coll CollectionName -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" already exists in the allowlist, scope ignored;"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to change scope, use update_scope_of_collection_in_allowlist"

metadataAllowlistUpdateScope ::
  AllowlistEntry -> MetadataAllowlist -> Either Text MetadataAllowlist
metadataAllowlistUpdateScope :: AllowlistEntry
-> MetadataAllowlist -> Either Text MetadataAllowlist
metadataAllowlistUpdateScope entry :: AllowlistEntry
entry@(AllowlistEntry CollectionName
coll AllowlistScope
_) MetadataAllowlist
al =
  (Maybe AllowlistEntry -> Either Text (Maybe AllowlistEntry))
-> CollectionName
-> MetadataAllowlist
-> Either Text MetadataAllowlist
forall (f :: * -> *) k v.
(Functor f, Eq k, Hashable k) =>
(Maybe v -> f (Maybe v))
-> k -> InsOrdHashMap k v -> f (InsOrdHashMap k v)
OM.alterF Maybe AllowlistEntry -> Either Text (Maybe AllowlistEntry)
setIfPresent CollectionName
coll MetadataAllowlist
al
  where
    setIfPresent :: Maybe AllowlistEntry -> Either Text (Maybe AllowlistEntry)
setIfPresent = \case
      Just AllowlistEntry
_ -> Maybe AllowlistEntry -> Either Text (Maybe AllowlistEntry)
forall a b. b -> Either a b
Right (AllowlistEntry -> Maybe AllowlistEntry
forall a. a -> Maybe a
Just AllowlistEntry
entry)
      Maybe AllowlistEntry
Nothing -> Text -> Either Text (Maybe AllowlistEntry)
forall a b. a -> Either a b
Left (Text -> Either Text (Maybe AllowlistEntry))
-> Text -> Either Text (Maybe AllowlistEntry)
forall a b. (a -> b) -> a -> b
$ Text
"collection " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CollectionName
coll CollectionName -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" doesn't exist in the allowlist"

-- | Produce a list of all collections in the allowlist.
-- This is used in 'runDropCollection' to function to ensure that we don't delete
-- any collections which are referred to in the allowlist.
metadataAllowlistAllCollections :: MetadataAllowlist -> [CollectionName]
metadataAllowlistAllCollections :: MetadataAllowlist -> [CollectionName]
metadataAllowlistAllCollections = InsOrdHashMap CollectionName CollectionName -> [CollectionName]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (InsOrdHashMap CollectionName CollectionName -> [CollectionName])
-> (MetadataAllowlist
    -> InsOrdHashMap CollectionName CollectionName)
-> MetadataAllowlist
-> [CollectionName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AllowlistEntry -> CollectionName)
-> MetadataAllowlist -> InsOrdHashMap CollectionName CollectionName
forall v1 v2 k.
(v1 -> v2) -> InsOrdHashMap k v1 -> InsOrdHashMap k v2
OM.map AllowlistEntry -> CollectionName
aeCollection

-- | A query stripped of typenames. A query is allowed if it occurs
-- in an allowed query collection after normalization.
--
-- Compare docs/graphql/core/deployment/allow-list.rst.
newtype NormalizedQuery = NormalizedQuery {NormalizedQuery -> ExecutableDocument Name
unNormalizedQuery :: G.ExecutableDocument G.Name}
  deriving (Int -> NormalizedQuery -> ShowS
[NormalizedQuery] -> ShowS
NormalizedQuery -> String
(Int -> NormalizedQuery -> ShowS)
-> (NormalizedQuery -> String)
-> ([NormalizedQuery] -> ShowS)
-> Show NormalizedQuery
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NormalizedQuery] -> ShowS
$cshowList :: [NormalizedQuery] -> ShowS
show :: NormalizedQuery -> String
$cshow :: NormalizedQuery -> String
showsPrec :: Int -> NormalizedQuery -> ShowS
$cshowsPrec :: Int -> NormalizedQuery -> ShowS
Show, NormalizedQuery -> NormalizedQuery -> Bool
(NormalizedQuery -> NormalizedQuery -> Bool)
-> (NormalizedQuery -> NormalizedQuery -> Bool)
-> Eq NormalizedQuery
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NormalizedQuery -> NormalizedQuery -> Bool
$c/= :: NormalizedQuery -> NormalizedQuery -> Bool
== :: NormalizedQuery -> NormalizedQuery -> Bool
$c== :: NormalizedQuery -> NormalizedQuery -> Bool
Eq, Int -> NormalizedQuery -> Int
NormalizedQuery -> Int
(Int -> NormalizedQuery -> Int)
-> (NormalizedQuery -> Int) -> Hashable NormalizedQuery
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: NormalizedQuery -> Int
$chash :: NormalizedQuery -> Int
hashWithSalt :: Int -> NormalizedQuery -> Int
$chashWithSalt :: Int -> NormalizedQuery -> Int
Hashable, [NormalizedQuery] -> Value
[NormalizedQuery] -> Encoding
NormalizedQuery -> Value
NormalizedQuery -> Encoding
(NormalizedQuery -> Value)
-> (NormalizedQuery -> Encoding)
-> ([NormalizedQuery] -> Value)
-> ([NormalizedQuery] -> Encoding)
-> ToJSON NormalizedQuery
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [NormalizedQuery] -> Encoding
$ctoEncodingList :: [NormalizedQuery] -> Encoding
toJSONList :: [NormalizedQuery] -> Value
$ctoJSONList :: [NormalizedQuery] -> Value
toEncoding :: NormalizedQuery -> Encoding
$ctoEncoding :: NormalizedQuery -> Encoding
toJSON :: NormalizedQuery -> Value
$ctoJSON :: NormalizedQuery -> Value
ToJSON)

-- | Normalize query for comparison by stripping type names.
normalizeQuery :: G.ExecutableDocument G.Name -> NormalizedQuery
normalizeQuery :: ExecutableDocument Name -> NormalizedQuery
normalizeQuery =
  ExecutableDocument Name -> NormalizedQuery
NormalizedQuery
    (ExecutableDocument Name -> NormalizedQuery)
-> (ExecutableDocument Name -> ExecutableDocument Name)
-> ExecutableDocument Name
-> NormalizedQuery
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ExecutableDefinition Name] -> ExecutableDocument Name
forall var. [ExecutableDefinition var] -> ExecutableDocument var
G.ExecutableDocument
    ([ExecutableDefinition Name] -> ExecutableDocument Name)
-> (ExecutableDocument Name -> [ExecutableDefinition Name])
-> ExecutableDocument Name
-> ExecutableDocument Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExecutableDefinition Name -> ExecutableDefinition Name)
-> [ExecutableDefinition Name] -> [ExecutableDefinition Name]
forall a b. (a -> b) -> [a] -> [b]
map ExecutableDefinition Name -> ExecutableDefinition Name
forall var. ExecutableDefinition var -> ExecutableDefinition var
filterExecDef
    ([ExecutableDefinition Name] -> [ExecutableDefinition Name])
-> (ExecutableDocument Name -> [ExecutableDefinition Name])
-> ExecutableDocument Name
-> [ExecutableDefinition Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExecutableDocument Name -> [ExecutableDefinition Name]
forall var. ExecutableDocument var -> [ExecutableDefinition var]
G.getExecutableDefinitions
  where
    filterExecDef :: G.ExecutableDefinition var -> G.ExecutableDefinition var
    filterExecDef :: ExecutableDefinition var -> ExecutableDefinition var
filterExecDef = \case
      G.ExecutableDefinitionOperation OperationDefinition FragmentSpread var
opDef ->
        OperationDefinition FragmentSpread var -> ExecutableDefinition var
forall var.
OperationDefinition FragmentSpread var -> ExecutableDefinition var
G.ExecutableDefinitionOperation (OperationDefinition FragmentSpread var
 -> ExecutableDefinition var)
-> OperationDefinition FragmentSpread var
-> ExecutableDefinition var
forall a b. (a -> b) -> a -> b
$ OperationDefinition FragmentSpread var
-> OperationDefinition FragmentSpread var
forall (frag :: * -> *) var.
OperationDefinition frag var -> OperationDefinition frag var
filterOpDef OperationDefinition FragmentSpread var
opDef
      G.ExecutableDefinitionFragment FragmentDefinition
fragDef ->
        let newSelset :: [Selection FragmentSpread Name]
newSelset = [Selection FragmentSpread Name] -> [Selection FragmentSpread Name]
forall (frag :: * -> *) var'.
[Selection frag var'] -> [Selection frag var']
filterSelSet ([Selection FragmentSpread Name]
 -> [Selection FragmentSpread Name])
-> [Selection FragmentSpread Name]
-> [Selection FragmentSpread Name]
forall a b. (a -> b) -> a -> b
$ FragmentDefinition -> [Selection FragmentSpread Name]
G._fdSelectionSet FragmentDefinition
fragDef
         in FragmentDefinition -> ExecutableDefinition var
forall var. FragmentDefinition -> ExecutableDefinition var
G.ExecutableDefinitionFragment FragmentDefinition
fragDef {_fdSelectionSet :: [Selection FragmentSpread Name]
G._fdSelectionSet = [Selection FragmentSpread Name]
newSelset}

    filterOpDef :: OperationDefinition frag var -> OperationDefinition frag var
filterOpDef = \case
      G.OperationDefinitionTyped TypedOperationDefinition frag var
typeOpDef ->
        let newSelset :: [Selection frag var]
newSelset = [Selection frag var] -> [Selection frag var]
forall (frag :: * -> *) var'.
[Selection frag var'] -> [Selection frag var']
filterSelSet ([Selection frag var] -> [Selection frag var])
-> [Selection frag var] -> [Selection frag var]
forall a b. (a -> b) -> a -> b
$ TypedOperationDefinition frag var -> [Selection frag var]
forall (frag :: * -> *) var.
TypedOperationDefinition frag var -> SelectionSet frag var
G._todSelectionSet TypedOperationDefinition frag var
typeOpDef
         in TypedOperationDefinition frag var -> OperationDefinition frag var
forall (frag :: * -> *) var.
TypedOperationDefinition frag var -> OperationDefinition frag var
G.OperationDefinitionTyped TypedOperationDefinition frag var
typeOpDef {_todSelectionSet :: [Selection frag var]
G._todSelectionSet = [Selection frag var]
newSelset}
      G.OperationDefinitionUnTyped [Selection frag var]
selset ->
        [Selection frag var] -> OperationDefinition frag var
forall (frag :: * -> *) var.
SelectionSet frag var -> OperationDefinition frag var
G.OperationDefinitionUnTyped ([Selection frag var] -> OperationDefinition frag var)
-> [Selection frag var] -> OperationDefinition frag var
forall a b. (a -> b) -> a -> b
$ [Selection frag var] -> [Selection frag var]
forall (frag :: * -> *) var'.
[Selection frag var'] -> [Selection frag var']
filterSelSet [Selection frag var]
selset

    filterSelSet :: [G.Selection frag var'] -> [G.Selection frag var']
    filterSelSet :: [Selection frag var'] -> [Selection frag var']
filterSelSet = (Selection frag var' -> Maybe (Selection frag var'))
-> [Selection frag var'] -> [Selection frag var']
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe Selection frag var' -> Maybe (Selection frag var')
forall (frag :: * -> *) var'.
Selection frag var' -> Maybe (Selection frag var')
filterSel

    filterSel :: G.Selection frag var' -> Maybe (G.Selection frag var')
    filterSel :: Selection frag var' -> Maybe (Selection frag var')
filterSel Selection frag var'
s = case Selection frag var'
s of
      G.SelectionField Field frag var'
f ->
        if Field frag var' -> Name
forall (frag :: * -> *) var. Field frag var -> Name
G._fName Field frag var'
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GName.___typename
          then Maybe (Selection frag var')
forall a. Maybe a
Nothing
          else
            let newSelset :: [Selection frag var']
newSelset = [Selection frag var'] -> [Selection frag var']
forall (frag :: * -> *) var'.
[Selection frag var'] -> [Selection frag var']
filterSelSet ([Selection frag var'] -> [Selection frag var'])
-> [Selection frag var'] -> [Selection frag var']
forall a b. (a -> b) -> a -> b
$ Field frag var' -> [Selection frag var']
forall (frag :: * -> *) var.
Field frag var -> SelectionSet frag var
G._fSelectionSet Field frag var'
f
             in Selection frag var' -> Maybe (Selection frag var')
forall a. a -> Maybe a
Just (Selection frag var' -> Maybe (Selection frag var'))
-> Selection frag var' -> Maybe (Selection frag var')
forall a b. (a -> b) -> a -> b
$ Field frag var' -> Selection frag var'
forall (frag :: * -> *) var. Field frag var -> Selection frag var
G.SelectionField Field frag var'
f {_fSelectionSet :: [Selection frag var']
G._fSelectionSet = [Selection frag var']
newSelset}
      Selection frag var'
_ -> Selection frag var' -> Maybe (Selection frag var')
forall a. a -> Maybe a
Just Selection frag var'
s

-- | InlinedAllowlist is the data type with which the allowlist is represented
--   in the schema cache, it contains a global and a per role allowlist and when
--   allowlist is enabled in the graphql-engine, the incoming query for a non-admin
--   role should either be in the global allowlist or in the given role's role
--   based allowlist.
--
--   Essentially, it's a memoization of 'allowlistAllowsQuery' implemented
--   in terms of 'MetadataAllowlist'.
data InlinedAllowlist = InlinedAllowlist
  { InlinedAllowlist -> HashSet NormalizedQuery
iaGlobal :: HashSet NormalizedQuery,
    InlinedAllowlist -> HashMap RoleName (HashSet NormalizedQuery)
iaPerRole :: HashMap RoleName (HashSet NormalizedQuery)
  }
  deriving (Int -> InlinedAllowlist -> ShowS
[InlinedAllowlist] -> ShowS
InlinedAllowlist -> String
(Int -> InlinedAllowlist -> ShowS)
-> (InlinedAllowlist -> String)
-> ([InlinedAllowlist] -> ShowS)
-> Show InlinedAllowlist
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InlinedAllowlist] -> ShowS
$cshowList :: [InlinedAllowlist] -> ShowS
show :: InlinedAllowlist -> String
$cshow :: InlinedAllowlist -> String
showsPrec :: Int -> InlinedAllowlist -> ShowS
$cshowsPrec :: Int -> InlinedAllowlist -> ShowS
Show, InlinedAllowlist -> InlinedAllowlist -> Bool
(InlinedAllowlist -> InlinedAllowlist -> Bool)
-> (InlinedAllowlist -> InlinedAllowlist -> Bool)
-> Eq InlinedAllowlist
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InlinedAllowlist -> InlinedAllowlist -> Bool
$c/= :: InlinedAllowlist -> InlinedAllowlist -> Bool
== :: InlinedAllowlist -> InlinedAllowlist -> Bool
$c== :: InlinedAllowlist -> InlinedAllowlist -> Bool
Eq)

$(deriveToJSON hasuraJSON ''InlinedAllowlist)

inlineAllowlist :: QueryCollections -> MetadataAllowlist -> InlinedAllowlist
inlineAllowlist :: QueryCollections -> MetadataAllowlist -> InlinedAllowlist
inlineAllowlist QueryCollections
collections MetadataAllowlist
allowlist = HashSet NormalizedQuery
-> HashMap RoleName (HashSet NormalizedQuery) -> InlinedAllowlist
InlinedAllowlist HashSet NormalizedQuery
global HashMap RoleName (HashSet NormalizedQuery)
perRole
  where
    globalCollections :: [CollectionName]
    globalCollections :: [CollectionName]
globalCollections =
      [CollectionName
coll | AllowlistEntry CollectionName
coll AllowlistScope
AllowlistScopeGlobal <- MetadataAllowlist -> [AllowlistEntry]
forall k v. InsOrdHashMap k v -> [v]
OM.elems MetadataAllowlist
allowlist]
    perRoleCollections :: HashMap RoleName [CollectionName]
    perRoleCollections :: HashMap RoleName [CollectionName]
perRoleCollections =
      [(CollectionName, [RoleName])] -> HashMap RoleName [CollectionName]
forall b a. (Eq b, Hashable b) => [(a, [b])] -> HashMap b [a]
inverseMap ([(CollectionName, [RoleName])]
 -> HashMap RoleName [CollectionName])
-> [(CollectionName, [RoleName])]
-> HashMap RoleName [CollectionName]
forall a b. (a -> b) -> a -> b
$
        [ (CollectionName
coll, NonEmpty RoleName -> [RoleName]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty RoleName
roles)
          | AllowlistEntry CollectionName
coll (AllowlistScopeRoles NonEmpty RoleName
roles) <- MetadataAllowlist -> [AllowlistEntry]
forall k v. InsOrdHashMap k v -> [v]
OM.elems MetadataAllowlist
allowlist
        ]

    inverseMap :: (Eq b, Hashable b) => [(a, [b])] -> HashMap b [a]
    inverseMap :: [(a, [b])] -> HashMap b [a]
inverseMap = ([a] -> [a] -> [a]) -> [(b, [a])] -> HashMap b [a]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
M.fromListWith [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
(<>) ([(b, [a])] -> HashMap b [a])
-> ([(a, [b])] -> [(b, [a])]) -> [(a, [b])] -> HashMap b [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, [b]) -> [(b, [a])]) -> [(a, [b])] -> [(b, [a])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(a
c, [b]
rs) -> [(b
r, [a
c]) | b
r <- [b]
rs])

    global :: HashSet NormalizedQuery
global = [CollectionName] -> HashSet NormalizedQuery
inlineQueries [CollectionName]
globalCollections
    perRole :: HashMap RoleName (HashSet NormalizedQuery)
perRole = [CollectionName] -> HashSet NormalizedQuery
inlineQueries ([CollectionName] -> HashSet NormalizedQuery)
-> HashMap RoleName [CollectionName]
-> HashMap RoleName (HashSet NormalizedQuery)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap RoleName [CollectionName]
perRoleCollections

    -- given a hashset of collections, look up what queries are in each
    -- collection, and inline them all into a hashset of queries
    inlineQueries :: [CollectionName] -> HashSet NormalizedQuery
    inlineQueries :: [CollectionName] -> HashSet NormalizedQuery
inlineQueries =
      (CollectionName -> [ExecutableDocument Name])
-> [CollectionName] -> [ExecutableDocument Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CollectionName -> [ExecutableDocument Name]
lookupQueries
        ([CollectionName] -> [ExecutableDocument Name])
-> ([ExecutableDocument Name] -> HashSet NormalizedQuery)
-> [CollectionName]
-> HashSet NormalizedQuery
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (ExecutableDocument Name -> NormalizedQuery)
-> [ExecutableDocument Name] -> [NormalizedQuery]
forall a b. (a -> b) -> [a] -> [b]
map ExecutableDocument Name -> NormalizedQuery
normalizeQuery
        ([ExecutableDocument Name] -> [NormalizedQuery])
-> ([NormalizedQuery] -> HashSet NormalizedQuery)
-> [ExecutableDocument Name]
-> HashSet NormalizedQuery
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [NormalizedQuery] -> HashSet NormalizedQuery
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList

    lookupQueries :: CollectionName -> [G.ExecutableDocument G.Name]
    lookupQueries :: CollectionName -> [ExecutableDocument Name]
lookupQueries CollectionName
coll =
      [ExecutableDocument Name]
-> (CreateCollection -> [ExecutableDocument Name])
-> Maybe CreateCollection
-> [ExecutableDocument Name]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] CreateCollection -> [ExecutableDocument Name]
collectionQueries (Maybe CreateCollection -> [ExecutableDocument Name])
-> Maybe CreateCollection -> [ExecutableDocument Name]
forall a b. (a -> b) -> a -> b
$ CollectionName -> QueryCollections -> Maybe CreateCollection
forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
OM.lookup CollectionName
coll QueryCollections
collections

-- | The mode in which the allowlist functions. In global mode,
-- collections with non-global scope are ignored.
data AllowlistMode = AllowlistModeGlobalOnly | AllowlistModeFull

allowlistAllowsQuery ::
  InlinedAllowlist -> AllowlistMode -> RoleName -> G.ExecutableDocument G.Name -> Bool
allowlistAllowsQuery :: InlinedAllowlist
-> AllowlistMode -> RoleName -> ExecutableDocument Name -> Bool
allowlistAllowsQuery (InlinedAllowlist HashSet NormalizedQuery
global HashMap RoleName (HashSet NormalizedQuery)
perRole) AllowlistMode
mode RoleName
role ExecutableDocument Name
query =
  case AllowlistMode
mode of
    AllowlistMode
AllowlistModeGlobalOnly -> HashSet NormalizedQuery -> Bool
inAllowlist HashSet NormalizedQuery
global
    AllowlistMode
AllowlistModeFull -> HashSet NormalizedQuery -> Bool
inAllowlist HashSet NormalizedQuery
global Bool -> Bool -> Bool
|| HashSet NormalizedQuery -> Bool
inAllowlist HashSet NormalizedQuery
roleAllowlist
  where
    inAllowlist :: HashSet NormalizedQuery -> Bool
inAllowlist = NormalizedQuery -> HashSet NormalizedQuery -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member (ExecutableDocument Name -> NormalizedQuery
normalizeQuery ExecutableDocument Name
query)
    roleAllowlist :: HashSet NormalizedQuery
roleAllowlist = HashSet NormalizedQuery
-> RoleName
-> HashMap RoleName (HashSet NormalizedQuery)
-> HashSet NormalizedQuery
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
M.findWithDefault HashSet NormalizedQuery
forall a. Monoid a => a
mempty RoleName
role HashMap RoleName (HashSet NormalizedQuery)
perRole