hasura/graphql-engine
1
0
Fork 0
mirror of https://github.com/hasura/graphql-engine.git synced 2025-01-07 08:13:18 +03:00
Code Issues Projects Releases Wiki Activity

Add support for fine-grained dependency tracking to Incremental

Browse Source
This commit is contained in:
Alexis King 2019-12-15 07:28:23 -06:00
parent 89af4ae4d7
commit fa9077f774
34 changed files with 942 additions and 396 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
server/graphql-engine.cabal
View File

@ -91,6 +91,8 @@ library
, http-client-tls , http-client-tls
, profunctors , profunctors
, deepseq , deepseq
, dependent-map >=0.2.4 && <0.4
, dependent-sum >=0.4 && <0.5
-- `these >=1` is split into several different packages, but our current stack -- `these >=1` is split into several different packages, but our current stack
-- resolver has `these <1`; when we upgrade we just need to add an extra -- resolver has `these <1`; when we upgrade we just need to add an extra
@ -232,7 +234,12 @@ library
, Data.Aeson.Ordered , Data.Aeson.Ordered
other-modules: Hasura.Server.Auth.JWT other-modules: Hasura.Incremental.Select
, Hasura.Incremental.Internal.Cache
, Hasura.Incremental.Internal.Dependency
, Hasura.Incremental.Internal.Rule
, Hasura.Server.Auth.JWT
, Hasura.Server.Middleware , Hasura.Server.Middleware
, Hasura.Server.Cors , Hasura.Server.Cors
, Hasura.Server.CheckUpdates , Hasura.Server.CheckUpdates

13
server/src-lib/Control/Arrow/Extended.hs
View File

@ -13,6 +13,8 @@ module Control.Arrow.Extended
, (>->) , (>->)
, (<-<) , (<-<)
, dup , dup
, bothA
, orA
, foldlA' , foldlA'
, traverseA_ , traverseA_
@ -52,6 +54,17 @@ dup :: (Arrow arr) => arr a (a, a)
dup = arr \x -> (x, x) dup = arr \x -> (x, x)
{-# INLINE dup #-} {-# INLINE dup #-}
bothA :: (Arrow arr) => arr a b -> arr (a, a) (b, b)
bothA f = f *** f
{-# INLINE bothA #-}
orA :: (ArrowChoice arr) => arr a Bool -> arr b Bool -> arr (a, b) Bool
orA f g = proc (a, b) -> do
c <- f -< a
if c then returnA -< True else g -< b
{-# INLINABLE orA #-}
{-# RULES "orA/arr" forall f g. arr f `orA` arr g = arr (f `orA` g) #-}
-- | 'foldl'' lifted to arrows. See also Note [Weird control operator types]. -- | 'foldl'' lifted to arrows. See also Note [Weird control operator types].
foldlA' :: (ArrowChoice arr, Foldable t) => arr (e, (b, (a, s))) b -> arr (e, (b, (t a, s))) b foldlA' :: (ArrowChoice arr, Foldable t) => arr (e, (b, (a, s))) b -> arr (e, (b, (t a, s))) b
foldlA' f = arr (\(e, (v, (xs, s))) -> (e, (v, (toList xs, s)))) >>> go where foldlA' f = arr (\(e, (v, (xs, s))) -> (e, (v, (toList xs, s)))) >>> go where

2
server/src-lib/Control/Arrow/Trans.hs
View File

@ -18,7 +18,7 @@ module Control.Arrow.Trans
, WriterA(WriterA, runWriterA) , WriterA(WriterA, runWriterA)
) where ) where
import Prelude hiding ((.), id) import Prelude hiding (id, (.))
import Control.Arrow import Control.Arrow
import Control.Category import Control.Category

2
server/src-lib/Hasura/GraphQL/Context.hs
View File

@ -6,6 +6,7 @@ import Data.Aeson
import Data.Aeson.Casing import Data.Aeson.Casing
import Data.Aeson.TH import Data.Aeson.TH
import Data.Has import Data.Has
import Hasura.Incremental (Cacheable)
import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax (Lift)
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
@ -90,6 +91,7 @@ data TableCustomRootFields
, _tcrfDelete :: !(Maybe G.Name) , _tcrfDelete :: !(Maybe G.Name)
} deriving (Show, Eq, Lift, Generic) } deriving (Show, Eq, Lift, Generic)
instance NFData TableCustomRootFields instance NFData TableCustomRootFields
instance Cacheable TableCustomRootFields
$(deriveToJSON (aesonDrop 5 snakeCase){omitNothingFields=True} ''TableCustomRootFields) $(deriveToJSON (aesonDrop 5 snakeCase){omitNothingFields=True} ''TableCustomRootFields)
instance FromJSON TableCustomRootFields where instance FromJSON TableCustomRootFields where

339
server/src-lib/Hasura/Incremental.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE Arrows #-}
-- | A simple implementation of /incremental build rules/, which can be used to avoid unnecessary -- | A simple implementation of /incremental build rules/, which can be used to avoid unnecessary
-- recomputation on incrementally-changing input. See 'Rule' for more details. -- recomputation on incrementally-changing input. See 'Rule' for more details.
module Hasura.Incremental module Hasura.Incremental
@ -10,331 +8,18 @@ module Hasura.Incremental
, rebuildRule , rebuildRule
, result , result
, ArrowCache(..)
, ArrowDistribute(..) , ArrowDistribute(..)
, ArrowCache(..)
, Dependency
, Selector
, selectD
, selectKeyD
, Cacheable(..)
, Accesses
) where ) where
import Hasura.Prelude hiding (id, (.)) import Hasura.Incremental.Internal.Cache
import Hasura.Incremental.Internal.Dependency
import qualified Data.HashMap.Strict as M import Hasura.Incremental.Internal.Rule
import Hasura.Incremental.Select
import Control.Applicative
import Control.Arrow.Extended
import Control.Category
import Data.Profunctor
import Data.Tuple (swap)
-- | A value of type @'Rule' m a b@ is a /build rule/: a computation that describes how to build a
-- value of type @b@ from a value of type @a@ in a monad @m@. What distinguishes @'Rule' m a b@ from
-- an ordinary function of type @a -> m b@ is that it can be made /incremental/ (in the sense of
-- “incremental compilation”) — after executing it, future executions can perform a subset of the
-- required work if only a portion of the input changed.
--
-- To achieve this, 'Rule's have a more restrictive interface: there is no @Monad ('Rule' m a)@
-- instance, for example. Instead, 'Rule's are composed using the 'Arrow' hierarchy of operations,
-- which ensures that the dependency graph of build rules is mostly static (though it may contain
-- conditional branches, and combinators such as 'keyed' can express restricted forms of dynamic
-- dependencies). Each atomic rule may be defined using the 'Monad' instance for @m@, but
-- incrementalization is not supported inside those rules — they are treated as a single, monolithic
-- computation.
--
-- Atomic rules are created with the 'arrM' function, and caching can be added to a rule using the
-- 'cache' combinator. Rules can be executed using the 'build' function, which returns a 'Result'. A
-- 'Result' contains the built value, accessible via 'result', but it also allows supplying a new
-- input value using 'rebuild' to produce a new result incrementally.
newtype Rule m a b
-- Note: this is a CPS encoding of `a -> m (Result m a b)`. In practice, the CPS encoding seems to
-- provide meaningful performance improvements: it cuts down significantly on allocation and is
-- friendlier to GHC’s optimizer.
= Rule (forall r. a -> (b -> Rule m a b -> m r) -> m r)
build :: (Applicative m) => Rule m a b -> a -> m (Result m a b)
build (Rule r) a = r a \b r' -> pure $ Result b r'
{-# INLINE build #-}
data Result m a b
= Result
{ result :: !b
, rebuildRule :: !(Rule m a b)
} deriving (Functor)
rebuild :: (Applicative m) => Result m a b -> a -> m (Result m a b)
rebuild = build . rebuildRule
{-# INLINE rebuild #-}
{- Note [Rule rewrite rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As explained by Note [Arrow rewrite rules] in Control.Arrow.Extended, it’s important to define
type-specific rewrite rules to get good performance with arrows when the concrete type is used. This
is especially important for `Rule`, since the recursive definitions of operations like `.` and `arr`
are very difficult for the optimizer to deal with, and the composition of lots of small rules
created with `arr` is very inefficient.
Since GHC aggressively specializes and inlines class methods, the rules cannot be defined on the
class methods themselves. Instead, the class methods expand to auxiliary definitions, and those
definitions include an INLINABLE[0] pragma that ensures they do not inline until the final
optimization phase. The rules are defined in terms of those definitions, so they will be able to do
their work in prior phases.
Note [Desugaring derived operations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
One subtlety to the above is that we want to define operations in terms of other operations as much
as possible to avoid the need to write an enormous number of rewrite rules, but if we define them
that way directly, then we’ll end up using needlessly inefficient implementations when the
operations aren’t specialized. Therefore, we provide efficient implementations of operations like
`second`, but aggressively rewrite them in terms of simpler primitives like `first` when GHC is able
to specialize them. -}
rComp :: Rule m a1 b -> Rule m a2 a1 -> Rule m a2 b
Rule f `rComp` Rule g = Rule \a k -> g a \b g' -> f b \c f' -> k c (f' `rComp` g')
{-# INLINABLE[0] rComp #-}
{-# RULES "associate" forall f g h. f `rComp` (g `rComp` h) = (f `rComp` g) `rComp` h #-}
rId :: Rule m a a
rId = Rule \a k -> k a rId
{-# INLINABLE[0] rId #-}
{-# RULES
"f/id" forall f. f `rComp` rId = f
"id/f" forall f. rId `rComp` f = f
#-}
rArr :: (a -> b) -> Rule m a b
rArr f = Rule \a k -> k (f a) (rArr f)
{-# INLINABLE[0] rArr #-}
{-# RULES
"arr/id" rArr (\x -> x) = rId
"arr/const" [1] forall x. rArr (\_ -> x) = rPure x
"arr/arr" forall f g. rArr f `rComp` rArr g = rArr (f . g)
"arr/arr/f" forall f g h. (f `rComp` rArr g) `rComp` rArr h = f `rComp` rArr (g . h)
#-}
rArrM :: (Monad m) => (a -> m b) -> Rule m a b
rArrM f = Rule \a k -> f a >>= \b -> k b (rArrM f)
{-# INLINABLE[0] rArrM #-}
{-# RULES
"arrM/arrM" forall f g. rArrM f `rComp` rArrM g = rArrM (f <=< g)
"arr/arrM" forall f g. rArr f `rComp` rArrM g = rArrM (fmap f . g)
"arrM/arr" forall f g. rArrM f `rComp` rArr g = rArrM (f . g)
"arrM/arrM/f" forall f g h. (f `rComp` rArrM g) `rComp` rArrM h = f `rComp` rArrM (g <=< h)
"arr/arrM/f" forall f g h. (f `rComp` rArr g) `rComp` rArrM h = f `rComp` rArrM (fmap g . h)
"arrM/arr/f" forall f g h. (f `rComp` rArrM g) `rComp` rArr h = f `rComp` rArrM (g . h)
#-}
rFirst :: Rule m a b1 -> Rule m (a, b2) (b1, b2)
rFirst (Rule r) = Rule \(a, c) k -> r a \b r' -> k (b, c) (rFirst r')
{-# INLINABLE[0] rFirst #-}
{-# RULES
"first/id" rFirst rId = rId
"first/arr" forall f. rFirst (rArr f) = rArr (second f)
"first/arrM" forall f. rFirst (rArrM f) = rArrM (runKleisli (first (Kleisli f)))
"first/push" [~1] forall f g. rFirst (f `rComp` g) = rFirst f `rComp` rFirst g
"first/pull" [1] forall f g. rFirst f `rComp` rFirst g = rFirst (f `rComp` g)
"first/f/pull" [1] forall f g h. (f `rComp` rFirst g) `rComp` rFirst h = f `rComp` rFirst (g `rComp` h)
#-}
rLeft :: Rule m a b1 -> Rule m (Either a b2) (Either b1 b2)
rLeft r0 = go r0 where
go (Rule r) = Rule \e k -> case e of
Left a -> r a \b r' -> k (Left b) (go r')
Right c -> k (Right c) (go r0)
{-# INLINABLE[0] rLeft #-}
{-# RULES
"left/id" rLeft rId = rId
"left/arr" forall f. rLeft (rArr f) = rArr (left f)
"left/arrM" forall f. rLeft (rArrM f) = rArrM (runKleisli (left (Kleisli f)))
"left/push" [~1] forall f g. rLeft (f `rComp` g) = rLeft f `rComp` rLeft g
"left/pull" [1] forall f g. rLeft f `rComp` rLeft g = rLeft (f `rComp` g)
"left/f/pull" [1] forall f g h. (f `rComp` rLeft g) `rComp` rLeft h = f `rComp` rLeft (g `rComp` h)
#-}
rPure :: b -> Rule m a b
rPure a = Rule \_ k -> k a (rPure a)
{-# INLINABLE[0] rPure #-}
{-# RULES "pure/push" [~1] rPure = rArr . const #-} -- see Note [Desugaring derived operations]
rSecond :: Rule m a1 b -> Rule m (a2, a1) (a2, b)
rSecond (Rule r) = Rule \(c, a) k -> r a \b r' -> k (c, b) (rSecond r')
{-# INLINABLE[0] rSecond #-}
-- see Note [Desugaring derived operations]
{-# RULES "second/push" [~1] forall f. rSecond f = rArr swap . rFirst f . rArr swap #-}
swapEither :: Either a b -> Either b a
swapEither = either Right Left
{-# INLINE[0] swapEither #-}
rRight :: Rule m a1 b -> Rule m (Either a2 a1) (Either a2 b)
rRight r0 = go r0 where
go (Rule r) = Rule \e k -> case e of
Left c -> k (Left c) (go r0)
Right a -> r a \b r' -> k (Right b) (go r')
{-# INLINABLE[0] rRight #-}
-- see Note [Desugaring derived operations]
{-# RULES "right/push" [~1] forall f. rRight f = rArr swapEither . rLeft f . rArr swapEither #-}
rSplit :: Rule m a1 b1 -> Rule m a2 b2 -> Rule m (a1, a2) (b1, b2)
Rule f `rSplit` Rule g = Rule \(a, b) k -> f a \c f' -> g b \d g' -> k (c, d) (f' `rSplit` g')
{-# INLINABLE[0] rSplit #-}
-- see Note [Desugaring derived operations]
{-# RULES "***/push" [~1] forall f g. f `rSplit` g = rSecond g . rFirst f #-}
rFanout :: Rule m a b1 -> Rule m a b2 -> Rule m a (b1, b2)
Rule f `rFanout` Rule g = Rule \a k -> f a \b f' -> g a \c g' -> k (b, c) (f' `rFanout` g')
{-# INLINABLE[0] rFanout #-}
-- see Note [Desugaring derived operations]
{-# RULES "&&&/push" [~1] forall f g. f `rFanout` g = (f *** g) . rArr (\a -> (a, a)) #-}
rFork :: Rule m a1 b1 -> Rule m a2 b2 -> Rule m (Either a1 a2) (Either b1 b2)
f0 `rFork` g0 = go f0 g0 where
go (Rule f) (Rule g) = Rule \e k -> case e of
Left a -> f a \b f' -> k (Left b) (go f' g0)
Right a -> g a \b g' -> k (Right b) (go f0 g')
{-# INLINABLE[0] rFork #-}
-- see Note [Desugaring derived operations]
{-# RULES "+++/push" [~1] forall f g. f `rFork` g = rRight g . rLeft f #-}
fromEither :: Either a a -> a
fromEither = either id id
{-# INLINE[0] fromEither #-}
rFanin :: Rule m a1 b -> Rule m a2 b -> Rule m (Either a1 a2) b
f0 `rFanin` g0 = go f0 g0 where
go (Rule f) (Rule g) = Rule \e k -> case e of
Left a -> f a \b f' -> k b (go f' g0)
Right a -> g a \b g' -> k b (go f0 g')
{-# INLINABLE[0] rFanin #-}
-- see Note [Desugaring derived operations]
{-# RULES "|||/push" [~1] forall f g. f `rFanin` g = rArr fromEither . (f +++ g) #-}
instance Functor (Rule m a) where
fmap f r = arr f . r
{-# INLINE fmap #-}
instance Applicative (Rule m a) where
pure = rPure
{-# INLINE pure #-}
(<*>) = liftA2 ($)
{-# INLINE (<*>) #-}
liftA2 f g h = arr (uncurry f) . (g &&& h)
{-# INLINE liftA2 #-}
instance Profunctor (Rule m) where
dimap f g r = arr g . r . arr f
{-# INLINE dimap #-}
lmap f r = r . arr f
{-# INLINE lmap #-}
rmap = fmap
{-# INLINE rmap #-}
instance Strong (Rule m) where
first' = rFirst
{-# INLINE first' #-}
second' = rSecond
{-# INLINE second' #-}
instance Choice (Rule m) where
left' = rLeft
{-# INLINE left' #-}
right' = rRight
{-# INLINE right' #-}
instance Category (Rule m) where
id = rId
{-# INLINE id #-}
(.) = rComp
{-# INLINE (.) #-}
instance Arrow (Rule m) where
arr = rArr
{-# INLINE arr #-}
first = rFirst
{-# INLINE first #-}
second = rSecond
{-# INLINE second #-}
(***) = rSplit
{-# INLINE (***) #-}
(&&&) = rFanout
{-# INLINE (&&&) #-}
instance ArrowChoice (Rule m) where
left = rLeft
{-# INLINE left #-}
right = rRight
{-# INLINE right #-}
(+++) = rFork
{-# INLINE (+++) #-}
(|||) = rFanin
{-# INLINE (|||) #-}
instance (Monad m) => ArrowKleisli m (Rule m) where
arrM = rArrM
{-# INLINE arrM #-}
class (Arrow arr) => ArrowCache arr where
-- | Adds equality-based caching to the given arrow. After each execution of the arrow, its input
-- and result values are cached. On the next execution, the new input value is compared via '=='
-- to the previous input value. If they are the same, the previous result is returned /without/
-- re-executing the arrow. Otherwise, the old cached values are discarded, and the arrow is
-- re-executed to produce a new set of cached values.
--
-- Indescriminate use of 'cache' is likely to have little effect except to increase memory usage,
-- since the input and result of each execution must be retained in memory. Avoid using 'cache'
-- around arrows with large input or output that is likely to change often unless profiling
-- indicates it is computationally expensive enough to be worth the memory overhead.
--
-- __Note that only direct inputs and outputs of the given arrow are cached.__ If an arrow
-- provides access to values through a side-channel, they will __not__ participate in caching.
cache :: (Eq a) => arr a b -> arr a b
instance (ArrowChoice arr, ArrowCache arr) => ArrowCache (ErrorA e arr) where
cache (ErrorA f) = ErrorA (cache f)
{-# INLINE cache #-}
instance (Monoid w, ArrowCache arr) => ArrowCache (WriterA w arr) where
cache (WriterA f) = WriterA (cache f)
{-# INLINE cache #-}
instance ArrowCache (Rule m) where
cache (Rule r0) = Rule \a k -> r0 a \b r0' -> k b (cached a b r0')
where
cached a b (Rule r) = Rule \a' k -> if
| a == a' -> k b (cached a b (Rule r))
| otherwise -> r a' \b' r' -> k b' (cached a' b' r')
{-# INLINABLE cache #-}
class (Arrow arr) => ArrowDistribute arr where
-- | Distributes an arrow that operates on key-value pairs, over a 'M.HashMap' in an
-- order-independent way.
--
-- This is intended to be used as a control operator in @proc@ notation; see
-- Note [Weird control operator types] in "Control.Arrow.Extended".
keyed
:: (Eq k, Hashable k)
=> arr (e, (k, (a, s))) b
-> arr (e, (HashMap k a, s)) (HashMap k b)
instance (Monoid w, ArrowDistribute arr) => ArrowDistribute (WriterA w arr) where
keyed (WriterA f) = WriterA (arr (swap . sequence . fmap swap) . keyed f)
{-# INLINE keyed #-}
-- | Unlike 'traverseA', using 'keyed' preserves incrementalization: if the input rule is
-- incremental in its argument, the resulting rule will be incremental as well for any entries in
-- the map that do not change between builds.
instance ArrowDistribute (Rule m) where
keyed
:: forall a b k e s
. (Eq k, Hashable k)
=> Rule m (e, (k, (a, s))) b
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
keyed r0 = keyedWith M.empty
where
keyedWith
:: HashMap k (Rule m (e, (k, (a, s))) b)
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
keyedWith !rs = Rule \(e, (vs, s)) c ->
M.foldrWithKey (process rs e s) (finish c) vs M.empty M.empty
process
:: HashMap k (Rule m (e, (k, (a, s))) b)
-> e -> s -> k -> a
-> (HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r)
-> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r
process rs e s k a c !vs' !rs' =
let Rule r = M.lookupDefault r0 k rs
in r (e, (k, (a, s))) \b r' -> c (M.insert k b vs') (M.insert k r' rs')
finish
:: (HashMap k b -> Rule m (e, (HashMap k a, s)) (HashMap k b) -> m r)
-> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r
finish c !vs' !rs' = c vs' (keyedWith rs')
{-# INLINABLE keyed #-}

70
server/src-lib/Hasura/Incremental/Internal/Cache.hs Normal file
View File

@ -0,0 +1,70 @@
{-# OPTIONS_HADDOCK not-home #-}
module Hasura.Incremental.Internal.Cache where
import Hasura.Prelude
import Control.Arrow.Extended
import Control.Monad.Unique
import Hasura.Incremental.Internal.Dependency
import Hasura.Incremental.Internal.Rule
import Hasura.Incremental.Select
class (Arrow arr) => ArrowCache arr where
-- | Adds equality-based caching to the given arrow. After each execution of the arrow, its input
-- and result values are cached. On the next execution, the new input value is compared via '=='
-- to the previous input value. If they are the same, the previous result is returned /without/
-- re-executing the arrow. Otherwise, the old cached values are discarded, and the arrow is
-- re-executed to produce a new set of cached values.
--
-- Indescriminate use of 'cache' is likely to have little effect except to increase memory usage,
-- since the input and result of each execution must be retained in memory. Avoid using 'cache'
-- around arrows with large input or output that is likely to change often unless profiling
-- indicates it is computationally expensive enough to be worth the memory overhead.
--
-- __Note that only direct inputs and outputs of the given arrow are cached.__ If an arrow
-- provides access to values through a side-channel, they will __not__ participate in caching.
cache :: (Cacheable a) => arr a b -> arr a b
-- | Creates a new 'Dependency', which allows fine-grained caching of composite values; see the
-- documentation for 'Dependency' for more details.
newDependency :: arr a (Dependency a)
-- | Extract the value from a 'Dependency', incurring a dependency on its entirety. To depend on
-- only a portion of the value, use 'selectD' or 'selectKeyD' before passing it to 'dependOn'.
dependOn :: (Cacheable a) => arr (Dependency a) a
instance (ArrowChoice arr, ArrowCache arr) => ArrowCache (ErrorA e arr) where
cache (ErrorA f) = ErrorA (cache f)
{-# INLINE cache #-}
newDependency = liftA newDependency
{-# INLINE newDependency #-}
dependOn = liftA dependOn
{-# INLINE dependOn #-}
instance (Monoid w, ArrowCache arr) => ArrowCache (WriterA w arr) where
cache (WriterA f) = WriterA (cache f)
{-# INLINE cache #-}
newDependency = liftA newDependency
{-# INLINE newDependency #-}
dependOn = liftA dependOn
{-# INLINE dependOn #-}
instance (MonadUnique m) => ArrowCache (Rule m) where
cache r0 = Rule \s a k -> do
let Rule r = listenAccesses r0
r s a \s' (b, accesses) r' -> k s' b (cached accesses a b r')
where
listenAccesses :: Rule m a b -> Rule m a (b, Accesses)
listenAccesses (Rule r) = Rule \s a k -> r mempty a \s' b r' ->
(k $! (s <> s')) (b, s') (listenAccesses r')
cached accesses a b (Rule r) = Rule \s a' k -> if
| unchanged accesses a a' -> k s b (cached accesses a b (Rule r))
| otherwise -> r s a' \s' (b', accesses') r' -> k s' b' (cached accesses' a' b' r')
newDependency = arrM \a -> newUniqueS <&> \u -> Dependency (DependencyRoot u) a
{-# INLINABLE newDependency #-}
dependOn = Rule \s (Dependency key v) k -> (k $! recordAccess key AccessedAll s) v dependOn

242
server/src-lib/Hasura/Incremental/Internal/Dependency.hs Normal file
View File

@ -0,0 +1,242 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE GADTs #-}
-- | Supporting functionality for fine-grained dependency tracking.
module Hasura.Incremental.Internal.Dependency where
import Hasura.Prelude
import qualified Data.Dependent.Map as DM
import qualified Language.GraphQL.Draft.Syntax as G
import qualified Network.URI.Extended as N
import Control.Applicative
import Data.Aeson (Value)
import Data.Functor.Classes (Eq1 (..), Eq2 (..))
import Data.GADT.Compare
import Data.Int
import Data.Scientific (Scientific)
import Data.Vector (Vector)
import GHC.Generics ((:*:) (..), (:+:) (..), Generic (..), K1 (..),
M1 (..), U1 (..), V1)
import Hasura.Incremental.Select
-- | A 'Dependency' represents a value that a 'Rule' can /conditionally/ depend on. A 'Dependency'
-- is created using 'newDependency', and it can be “opened” again using 'dependOn'. What makes a
-- 'Dependency' useful is the way it cooperates with 'cache'---if a 'Dependency' is passed to a
-- cached rule, but that rule (or any of its sub-rules) never “opens” it using 'dependOn', then
-- subsequent executions of the rule will ignore the 'Dependency' when computing whether or not it
-- is necessary to re-execute the rule.
--
-- The above functionality is useful on its own to express conditional dependencies, but even more
-- useful is the ability to express /partial/ dependencies. For example, if a 'Dependency' contains
-- a 'HashMap', a rule can choose to only depend on the value associated with a particular key by
-- using 'selectKeyD' (or the more general 'selectD'). Only the parts that are actually used will be
-- counted when computing whether a rule needs to be re-executed.
data Dependency a = Dependency !(DependencyKey a) !a
instance (Eq a) => Eq (Dependency a) where
Dependency _ a == Dependency _ b = a == b
-- | Applies a 'Selector' to select part of a 'Dependency'.
selectD :: (Select a) => Selector a b -> Dependency a -> Dependency b
selectD k (Dependency dk a) = Dependency (DependencyChild k dk) (select k a)
-- | Selects a single key from a dependency containing a map-like data structure.
selectKeyD :: (Select a, Selector a ~ ConstS k v) => k -> Dependency a -> Dependency v
selectKeyD = selectD . ConstS
-- | Tracks whether a 'Dependency' is a “root” dependency created by 'newDependency' or a “child”
-- dependency created from an existing dependency using 'selectD'.
data DependencyKey a where
DependencyRoot :: !(UniqueS a) -> DependencyKey a
DependencyChild :: (Select a) => !(Selector a b) -> !(DependencyKey a) -> DependencyKey b
instance GEq DependencyKey where
DependencyRoot a `geq` DependencyRoot b
| Just Refl <- a `geq` b
= Just Refl
DependencyChild a1 a2 `geq` DependencyChild b1 b2
| Just Refl <- a2 `geq` b2
, Just Refl <- a1 `geq` b1
= Just Refl
_ `geq` _ = Nothing
instance GCompare DependencyKey where
DependencyRoot a `gcompare` DependencyRoot b = case gcompare a b of
GLT -> GLT
GEQ -> GEQ
GGT -> GGT
DependencyChild a1 a2 `gcompare` DependencyChild b1 b2 = case gcompare a2 b2 of
GLT -> GLT
GEQ -> case gcompare a1 b1 of
GLT -> GLT
GEQ -> GEQ
GGT -> GGT
GGT -> GGT
DependencyRoot _ `gcompare` DependencyChild _ _ = GLT
DependencyChild _ _ `gcompare` DependencyRoot _ = GGT
-- | A typeclass that implements the dependency-checking machinery used by 'cache'. Morally, this
-- class is like 'Eq', but it only checks the parts of a 'Dependency' that were actually accessed on
-- the previous execution. It is highly unlikely you will need to implement any 'Cacheable'
-- instances yourself; the default implementation uses 'Generic' to derive an instance
-- automatically.
class (Eq a) => Cacheable a where
unchanged :: Accesses -> a -> a -> Bool
default unchanged :: (Generic a, GCacheable (Rep a)) => Accesses -> a -> a -> Bool
unchanged accesses a b = gunchanged (from a) (from b) accesses
{-# INLINABLE unchanged #-}
-- | A mapping from root 'Dependency' keys to the accesses made against those dependencies.
newtype Accesses = Accesses { unAccesses :: DM.DMap UniqueS Access }
instance Semigroup Accesses where
Accesses a <> Accesses b = Accesses $ DM.unionWithKey (const (<>)) a b
instance Monoid Accesses where
mempty = Accesses DM.empty
recordAccess :: DependencyKey a -> Access a -> Accesses -> Accesses
recordAccess depKey !access (Accesses accesses) = case depKey of
DependencyRoot rootKey -> Accesses $ DM.insertWith' (<>) rootKey access accesses
DependencyChild selector parentKey ->
recordAccess parentKey (AccessedParts $ DM.singleton selector access) (Accesses accesses)
-- | Records the accesses made within a single 'Dependency' and its children. The 'Semigroup'
-- instance for 'Access' computes a least upper bound:
--
-- * 'AccessedAll' serves as the top of the lattice and records the dependency’s entire value was
-- accessed.
-- * 'AccessedParts' records a set of accesses for individual parts of a dependency.
data Access a where
AccessedAll :: (Cacheable a) => Access a
AccessedParts :: (Select a) => !(DM.DMap (Selector a) Access) -> Access a
instance Semigroup (Access a) where
AccessedAll <> _ = AccessedAll
_ <> AccessedAll = AccessedAll
AccessedParts a <> AccessedParts b = AccessedParts $ DM.unionWithKey (const (<>)) a b
instance (Cacheable a) => Cacheable (Dependency a) where
unchanged accesses (Dependency key1 v1) (Dependency _ v2) =
-- look up which parts of this dependency were previously accessed
case lookupAccess key1 of
-- looking up the access was enough to determine the result
Left result -> result
-- otherwise, look through the accessed children
Right access -> unchangedBy v1 v2 access
where
-- Looks up the Access associated with the given DependencyKey, if it exists.
lookupAccess :: DependencyKey b -> Either Bool (Access b)
lookupAccess = \case
DependencyRoot key -> handleNoAccess $ DM.lookup key (unAccesses accesses)
DependencyChild selector key -> lookupAccess key >>= \case
AccessedAll -> Left (unchanged accesses v1 v2)
AccessedParts parts -> handleNoAccess $ DM.lookup selector parts
where
-- if this dependency was never accessed, then it’s certainly unchanged
handleNoAccess = maybe (Left True) Right
-- Walks the given values guided by the given Access, checking that all the subparts
-- identified by the AccessedAll leaves are unchanged.
unchangedBy :: forall b. b -> b -> Access b -> Bool
unchangedBy a b = \case
AccessedAll -> unchanged accesses a b
AccessedParts parts -> DM.foldrWithKey reduce True parts
where
reduce :: (Select b) => Selector b c -> Access c -> Bool -> Bool
reduce selector = (&&) . unchangedBy (select selector a) (select selector b)
-- -------------------------------------------------------------------------------------------------
-- boilerplate Cacheable instances
instance Cacheable Char where unchanged _ = (==)
instance Cacheable Double where unchanged _ = (==)
instance Cacheable Int where unchanged _ = (==)
instance Cacheable Int32 where unchanged _ = (==)
instance Cacheable Integer where unchanged _ = (==)
instance Cacheable Scientific where unchanged _ = (==)
instance Cacheable Text where unchanged _ = (==)
instance Cacheable N.URIAuth where unchanged _ = (==)
instance (Cacheable a) => Cacheable (Seq a) where
unchanged = liftEq . unchanged
instance (Cacheable a) => Cacheable (Vector a) where
unchanged = liftEq . unchanged
instance (Cacheable k, Cacheable v) => Cacheable (HashMap k v) where
unchanged accesses = liftEq2 (unchanged accesses) (unchanged accesses)
instance (Cacheable a) => Cacheable (HashSet a) where
unchanged = liftEq . unchanged
instance Cacheable ()
instance (Cacheable a, Cacheable b) => Cacheable (a, b)
instance (Cacheable a, Cacheable b, Cacheable c) => Cacheable (a, b, c)
instance (Cacheable a, Cacheable b, Cacheable c, Cacheable d) => Cacheable (a, b, c, d)
instance (Cacheable a, Cacheable b, Cacheable c, Cacheable d, Cacheable e) => Cacheable (a, b, c, d, e)
instance Cacheable Bool
instance Cacheable Value
instance Cacheable G.Argument
instance Cacheable G.Directive
instance Cacheable G.ExecutableDefinition
instance Cacheable G.Field
instance Cacheable G.FragmentDefinition
instance Cacheable G.FragmentSpread
instance Cacheable G.GType
instance Cacheable G.InlineFragment
instance Cacheable G.Nullability
instance Cacheable G.OperationDefinition
instance Cacheable G.OperationType
instance Cacheable G.Selection
instance Cacheable G.TypedOperationDefinition
instance Cacheable G.Value
instance Cacheable G.ValueConst
instance Cacheable G.VariableDefinition
instance Cacheable N.URI
instance (Cacheable a) => Cacheable (Maybe a)
instance (Cacheable a, Cacheable b) => Cacheable (Either a b)
instance (Cacheable a) => Cacheable [a]
instance (Cacheable a) => Cacheable (NonEmpty a)
instance (Cacheable a) => Cacheable (G.ObjectFieldG a)
deriving instance Cacheable G.Alias
deriving instance Cacheable G.EnumValue
deriving instance Cacheable G.ExecutableDocument
deriving instance Cacheable G.ListType
deriving instance Cacheable G.Name
deriving instance Cacheable G.NamedType
deriving instance Cacheable G.StringValue
deriving instance Cacheable G.Variable
deriving instance (Cacheable a) => Cacheable (G.ListValueG a)
deriving instance (Cacheable a) => Cacheable (G.ObjectValueG a)
class GCacheable f where
gunchanged :: f p -> f p -> Accesses -> Bool
instance GCacheable V1 where
gunchanged a = case a of {}
{-# INLINE gunchanged #-}
instance GCacheable U1 where
gunchanged U1 U1 _ = True
{-# INLINE gunchanged #-}
instance (Cacheable a) => GCacheable (K1 t a) where
gunchanged (K1 a) (K1 b) accesses = unchanged accesses a b
{-# INLINE gunchanged #-}
instance (GCacheable f) => GCacheable (M1 t m f) where
gunchanged (M1 a) (M1 b) = gunchanged a b
{-# INLINE gunchanged #-}
instance (GCacheable f, GCacheable g) => GCacheable (f :*: g) where
gunchanged (a1 :*: a2) (b1 :*: b2) = liftA2 (&&) (gunchanged a1 b1) (gunchanged a2 b2)
{-# INLINE gunchanged #-}
instance (GCacheable f, GCacheable g) => GCacheable (f :+: g) where
gunchanged (L1 a) (L1 b) = gunchanged a b
gunchanged (R1 a) (R1 b) = gunchanged a b
gunchanged _ _ = const False
{-# INLINE gunchanged #-}

304
server/src-lib/Hasura/Incremental/Internal/Rule.hs Normal file
View File

@ -0,0 +1,304 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Defines the basic 'Rule' datatype and its core operations.
module Hasura.Incremental.Internal.Rule where
import Hasura.Prelude hiding (id, (.))
import qualified Data.HashMap.Strict as HM
import Control.Applicative hiding (liftA)
import Control.Arrow.Extended
import Control.Category
import Data.Profunctor
import Data.Tuple (swap)
import Hasura.Incremental.Internal.Dependency
-- | A value of type @'Rule' m a b@ is a /build rule/: a computation that describes how to build a
-- value of type @b@ from a value of type @a@ in a monad @m@. What distinguishes @'Rule' m a b@ from
-- an ordinary function of type @a -> m b@ is that it can be made /incremental/ (in the sense of
-- “incremental compilation”)—after executing it, future executions can perform a subset of the
-- required work if only a portion of the input changed.
--
-- To achieve this, 'Rule's have a more restrictive interface: there is no @Monad ('Rule' m a)@
-- instance, for example. Instead, 'Rule's are composed using the 'Arrow' hierarchy of operations,
-- which ensures that the dependency graph of build rules is mostly static (though it may contain
-- conditional branches, and combinators such as 'keyed' can express restricted forms of dynamic
-- dependencies). Each atomic rule may be defined using the 'Monad' instance for @m@, but
-- incrementalization is not supported inside those rules — they are treated as a single, monolithic
-- computation.
--
-- Atomic rules are created with the 'arrM' function, and caching can be added to a rule using the
-- 'cache' combinator. Rules can be executed using the 'build' function, which returns a 'Result'. A
-- 'Result' contains the built value, accessible via 'result', but it also allows supplying a new
-- input value using 'rebuild' to produce a new result incrementally.
newtype Rule m a b
-- Note: this is a CPS encoding of `Accesses -> a -> m (Result m a b)`. In practice, the CPS
-- encoding seems to provide meaningful performance improvements: it cuts down significantly on
-- allocation and is friendlier to GHC’s optimizer.
= Rule (forall r. Accesses -> a -> (Accesses -> b -> Rule m a b -> m r) -> m r)
build :: (Applicative m) => Rule m a b -> a -> m (Result m a b)
build (Rule r) a = r mempty a \_ b r' -> pure $ Result b r'
{-# INLINE build #-}
data Result m a b
= Result
{ result :: !b
, rebuildRule :: !(Rule m a b)
} deriving (Functor)
rebuild :: (Applicative m) => Result m a b -> a -> m (Result m a b)
rebuild = build . rebuildRule
{-# INLINE rebuild #-}
{- Note [Rule rewrite rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As explained by Note [Arrow rewrite rules] in Control.Arrow.Extended, it’s important to define
type-specific rewrite rules to get good performance with arrows when the concrete type is used. This
is especially important for `Rule`, since the recursive definitions of operations like `.` and `arr`
are very difficult for the optimizer to deal with, and the composition of lots of small rules
created with `arr` is very inefficient.
Since GHC aggressively specializes and inlines class methods, the rules cannot be defined on the
class methods themselves. Instead, the class methods expand to auxiliary definitions, and those
definitions include an INLINABLE[0] pragma that ensures they do not inline until the final
optimization phase. The rules are defined in terms of those definitions, so they will be able to do
their work in prior phases.
Note [Desugaring derived operations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
One subtlety to the above is that we want to define operations in terms of other operations as much
as possible to avoid the need to write an enormous number of rewrite rules, but if we define them
that way directly, then we’ll end up using needlessly inefficient implementations when the
operations aren’t specialized. Therefore, we provide efficient implementations of operations like
`second`, but aggressively rewrite them in terms of simpler primitives like `first` when GHC is able
to specialize them. -}
rComp :: Rule m a1 b -> Rule m a2 a1 -> Rule m a2 b
Rule f `rComp` Rule g = Rule \s a k -> g s a \s' b g' -> f s' b \s'' c f' -> k s'' c (f' `rComp` g')
{-# INLINABLE[0] rComp #-}
{-# RULES "associate" forall f g h. f `rComp` (g `rComp` h) = (f `rComp` g) `rComp` h #-}
rId :: Rule m a a
rId = Rule \s a k -> k s a rId
{-# INLINABLE[0] rId #-}
{-# RULES
"f/id" forall f. f `rComp` rId = f
"id/f" forall f. rId `rComp` f = f
#-}
rArr :: (a -> b) -> Rule m a b
rArr f = Rule \s a k -> k s (f a) (rArr f)
{-# INLINABLE[0] rArr #-}
{-# RULES
"arr/id" rArr (\x -> x) = rId
"arr/const" [1] forall x. rArr (\_ -> x) = rPure x
"arr/arr" forall f g. rArr f `rComp` rArr g = rArr (f . g)
"arr/arr/f" forall f g h. (f `rComp` rArr g) `rComp` rArr h = f `rComp` rArr (g . h)
#-}
rArrM :: (Monad m) => (a -> m b) -> Rule m a b
rArrM f = Rule \s a k -> f a >>= \b -> k s b (rArrM f)
{-# INLINABLE[0] rArrM #-}
{-# RULES
"arrM/arrM" forall f g. rArrM f `rComp` rArrM g = rArrM (f <=< g)
"arr/arrM" forall f g. rArr f `rComp` rArrM g = rArrM (fmap f . g)
"arrM/arr" forall f g. rArrM f `rComp` rArr g = rArrM (f . g)
"arrM/arrM/f" forall f g h. (f `rComp` rArrM g) `rComp` rArrM h = f `rComp` rArrM (g <=< h)
"arr/arrM/f" forall f g h. (f `rComp` rArr g) `rComp` rArrM h = f `rComp` rArrM (fmap g . h)
"arrM/arr/f" forall f g h. (f `rComp` rArrM g) `rComp` rArr h = f `rComp` rArrM (g . h)
#-}
rFirst :: Rule m a b1 -> Rule m (a, b2) (b1, b2)
rFirst (Rule r) = Rule \s (a, c) k -> r s a \s' b r' -> k s' (b, c) (rFirst r')
{-# INLINABLE[0] rFirst #-}
{-# RULES
"first/id" rFirst rId = rId
"first/arr" forall f. rFirst (rArr f) = rArr (second f)
"first/arrM" forall f. rFirst (rArrM f) = rArrM (runKleisli (first (Kleisli f)))
"first/push" [~1] forall f g. rFirst (f `rComp` g) = rFirst f `rComp` rFirst g
"first/pull" [1] forall f g. rFirst f `rComp` rFirst g = rFirst (f `rComp` g)
"first/f/pull" [1] forall f g h. (f `rComp` rFirst g) `rComp` rFirst h = f `rComp` rFirst (g `rComp` h)
#-}
rLeft :: Rule m a b1 -> Rule m (Either a b2) (Either b1 b2)
rLeft r0 = go r0 where
go (Rule r) = Rule \s e k -> case e of
Left a -> r s a \s' b r' -> k s' (Left b) (go r')
Right c -> k s (Right c) (go r0)
{-# INLINABLE[0] rLeft #-}
{-# RULES
"left/id" rLeft rId = rId
"left/arr" forall f. rLeft (rArr f) = rArr (left f)
"left/arrM" forall f. rLeft (rArrM f) = rArrM (runKleisli (left (Kleisli f)))
"left/push" [~1] forall f g. rLeft (f `rComp` g) = rLeft f `rComp` rLeft g
"left/pull" [1] forall f g. rLeft f `rComp` rLeft g = rLeft (f `rComp` g)
"left/f/pull" [1] forall f g h. (f `rComp` rLeft g) `rComp` rLeft h = f `rComp` rLeft (g `rComp` h)
#-}
rPure :: b -> Rule m a b
rPure a = Rule \s _ k -> k s a (rPure a)
{-# INLINABLE[0] rPure #-}
{-# RULES "pure/push" [~1] rPure = rArr . const #-} -- see Note [Desugaring derived operations]
rSecond :: Rule m a1 b -> Rule m (a2, a1) (a2, b)
rSecond (Rule r) = Rule \s (c, a) k -> r s a \s' b r' -> k s' (c, b) (rSecond r')
{-# INLINABLE[0] rSecond #-}
-- see Note [Desugaring derived operations]
{-# RULES "second/push" [~1] forall f. rSecond f = rArr swap . rFirst f . rArr swap #-}
swapEither :: Either a b -> Either b a
swapEither = either Right Left
{-# INLINE[0] swapEither #-}
rRight :: Rule m a1 b -> Rule m (Either a2 a1) (Either a2 b)
rRight r0 = go r0 where
go (Rule r) = Rule \s e k -> case e of
Left c -> k s (Left c) (go r0)
Right a -> r s a \s' b r' -> k s' (Right b) (go r')
{-# INLINABLE[0] rRight #-}
-- see Note [Desugaring derived operations]
{-# RULES "right/push" [~1] forall f. rRight f = rArr swapEither . rLeft f . rArr swapEither #-}
rSplit :: Rule m a1 b1 -> Rule m a2 b2 -> Rule m (a1, a2) (b1, b2)
Rule f `rSplit` Rule g =
Rule \s (a, b) k -> f s a \s' c f' -> g s' b \s'' d g' -> k s'' (c, d) (f' `rSplit` g')
{-# INLINABLE[0] rSplit #-}
-- see Note [Desugaring derived operations]
{-# RULES "***/push" [~1] forall f g. f `rSplit` g = rSecond g . rFirst f #-}
rFanout :: Rule m a b1 -> Rule m a b2 -> Rule m a (b1, b2)
Rule f `rFanout` Rule g =
Rule \s a k -> f s a \s' b f' -> g s' a \s'' c g' -> k s'' (b, c) (f' `rFanout` g')
{-# INLINABLE[0] rFanout #-}
-- see Note [Desugaring derived operations]
{-# RULES "&&&/push" [~1] forall f g. f `rFanout` g = (f *** g) . rArr (\a -> (a, a)) #-}
rFork :: Rule m a1 b1 -> Rule m a2 b2 -> Rule m (Either a1 a2) (Either b1 b2)
f0 `rFork` g0 = go f0 g0 where
go (Rule f) (Rule g) = Rule \s e k -> case e of
Left a -> f s a \s' b f' -> k s' (Left b) (go f' g0)
Right a -> g s a \s' b g' -> k s' (Right b) (go f0 g')
{-# INLINABLE[0] rFork #-}
-- see Note [Desugaring derived operations]
{-# RULES "+++/push" [~1] forall f g. f `rFork` g = rRight g . rLeft f #-}
fromEither :: Either a a -> a
fromEither = either id id
{-# INLINE[0] fromEither #-}
rFanin :: Rule m a1 b -> Rule m a2 b -> Rule m (Either a1 a2) b
f0 `rFanin` g0 = go f0 g0 where
go (Rule f) (Rule g) = Rule \s e k -> case e of
Left a -> f s a \s' b f' -> k s' b (go f' g0)
Right a -> g s a \s' b g' -> k s' b (go f0 g')
{-# INLINABLE[0] rFanin #-}
-- see Note [Desugaring derived operations]
{-# RULES "|||/push" [~1] forall f g. f `rFanin` g = rArr fromEither . (f +++ g) #-}
instance Functor (Rule m a) where
fmap f r = arr f . r
{-# INLINE fmap #-}
instance Applicative (Rule m a) where
pure = rPure
{-# INLINE pure #-}
(<*>) = liftA2 ($)
{-# INLINE (<*>) #-}
liftA2 f g h = arr (uncurry f) . (g &&& h)
{-# INLINE liftA2 #-}
instance Profunctor (Rule m) where
dimap f g r = arr g . r . arr f
{-# INLINE dimap #-}
lmap f r = r . arr f
{-# INLINE lmap #-}
rmap = fmap
{-# INLINE rmap #-}
instance Strong (Rule m) where
first' = rFirst
{-# INLINE first' #-}
second' = rSecond
{-# INLINE second' #-}
instance Choice (Rule m) where
left' = rLeft
{-# INLINE left' #-}
right' = rRight
{-# INLINE right' #-}
instance Category (Rule m) where
id = rId
{-# INLINE id #-}
(.) = rComp
{-# INLINE (.) #-}
instance Arrow (Rule m) where
arr = rArr
{-# INLINE arr #-}
first = rFirst
{-# INLINE first #-}
second = rSecond
{-# INLINE second #-}
(***) = rSplit
{-# INLINE (***) #-}
(&&&) = rFanout
{-# INLINE (&&&) #-}
instance ArrowChoice (Rule m) where
left = rLeft
{-# INLINE left #-}
right = rRight
{-# INLINE right #-}
(+++) = rFork
{-# INLINE (+++) #-}
(|||) = rFanin
{-# INLINE (|||) #-}
instance (Monad m) => ArrowKleisli m (Rule m) where
arrM = rArrM
{-# INLINE arrM #-}
class (Arrow arr) => ArrowDistribute arr where
-- | Distributes an arrow that operates on key-value pairs, over a 'HM.HashMap' in an
-- order-independent way.
--
-- This is intended to be used as a control operator in @proc@ notation; see
-- Note [Weird control operator types] in "Control.Arrow.Extended".
keyed
:: (Eq k, Hashable k)
=> arr (e, (k, (a, s))) b
-> arr (e, (HashMap k a, s)) (HashMap k b)
instance (Monoid w, ArrowDistribute arr) => ArrowDistribute (WriterA w arr) where
keyed (WriterA f) = WriterA (arr (swap . sequence . fmap swap) . keyed f)
{-# INLINE keyed #-}
-- | Unlike 'traverseA', using 'keyed' preserves incrementalization: if the input rule is
-- incremental in its argument, the resulting rule will be incremental as well for any entries in
-- the map that do not change between builds.
instance ArrowDistribute (Rule m) where
keyed
:: forall a b k e s
. (Eq k, Hashable k)
=> Rule m (e, (k, (a, s))) b
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
keyed r0 = keyedWith HM.empty
where
keyedWith
:: HashMap k (Rule m (e, (k, (a, s))) b)
-> Rule m (e, (HashMap k a, s)) (HashMap k b)
keyedWith !rs = Rule \s (e, (vs, sk)) c ->
HM.foldrWithKey (process rs e sk) (finish c) vs s HM.empty HM.empty
process
:: HashMap k (Rule m (e, (k, (a, s))) b)
-> e -> s -> k -> a
-> (Accesses -> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r)
-> Accesses -> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r
process rs e sk k a c s !vs' !rs' =
let Rule r = HM.lookupDefault r0 k rs
in r s (e, (k, (a, sk))) \s' b r' -> c s' (HM.insert k b vs') (HM.insert k r' rs')
finish
:: (Accesses -> HashMap k b -> Rule m (e, (HashMap k a, s)) (HashMap k b) -> m r)
-> Accesses -> HashMap k b -> HashMap k (Rule m (e, (k, (a, s))) b) -> m r
finish c s !vs' !rs' = c s vs' (keyedWith rs')
{-# INLINABLE keyed #-}

103
server/src-lib/Hasura/Incremental/Select.hs Normal file
View File

@ -0,0 +1,103 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RoleAnnotations #-}
module Hasura.Incremental.Select
( Select(..)
, ConstS(..)
, selectKey
, UniqueS
, newUniqueS
, DMapS(..)
) where
import Hasura.Prelude
import qualified Data.Dependent.Map as DM
import qualified Data.HashMap.Strict as M
import Control.Monad.Unique
import Data.GADT.Compare
import Data.Kind
import Unsafe.Coerce (unsafeCoerce)
-- | The 'Select' class provides a way to access subparts of a product type using a reified
-- 'Selector'. A @'Selector' a b@ is essentially a function from @a@ to @b@, and indeed 'select'
-- converts a 'Selector' to such a function. However, unlike functions, 'Selector's can be compared
-- for equality using 'GEq' and ordered using 'GCompare'.
--
-- This is useful to implement dependency tracking, since it’s possible to track in a reified form
-- exactly which parts of a data structure are used.
class (GCompare (Selector a)) => Select a where
type Selector a :: Type -> Type
select :: Selector a b -> a -> b
instance (Eq k, Ord k, Hashable k) => Select (HashMap k v) where
type Selector (HashMap k v) = ConstS k (Maybe v)
select (ConstS k) = M.lookup k
instance (GCompare k) => Select (DM.DMap k f) where
type Selector (DM.DMap k f) = DMapS k f
select (DMapS k) = DM.lookup k
-- | The constant selector, which is useful for representing selectors into data structures where
-- all fields have the same type. Matching on a value of type @'ConstS' k a b@ causes @a@ and @b@ to
-- unify, effectively “pinning” @b@ to @a@.
data ConstS k a b where
ConstS :: !k -> ConstS k a a
selectKey :: (Select a, Selector a ~ ConstS k v) => k -> a -> v
selectKey = select . ConstS
instance (Eq k) => GEq (ConstS k a) where
ConstS a `geq` ConstS b
| a == b = Just Refl
| otherwise = Nothing
instance (Ord k) => GCompare (ConstS k a) where
ConstS a `gcompare` ConstS b = case compare a b of
LT -> GLT
EQ -> GEQ
GT -> GGT
-- | A 'UniqueS' is, as the name implies, a globally-unique 'Selector', which can be created using
-- 'newUniqueS'. If a value of type @'UniqueS' a@ is found to be equal (via 'geq') with another
-- value of type @'UniqueS' b@, then @a@ and @b@ must be the same type. This effectively allows the
-- creation of a dynamically-extensible sum type, where new constructors can be created at runtime
-- using 'newUniqueS'.
type role UniqueS nominal
newtype UniqueS a = UniqueS Unique
deriving (Eq)
newUniqueS :: (MonadUnique m) => m (UniqueS a)
newUniqueS = UniqueS <$> newUnique
{-# INLINE newUniqueS #-}
instance GEq UniqueS where
UniqueS a `geq` UniqueS b
-- This use of `unsafeCoerce` is safe as long as we don’t export the constructor of `UniqueS`.
-- Because a `UniqueS` is, in fact, unique, then we can be certain that equality of 'UniqueS's
-- implies equality of their argument types.
| a == b = Just (unsafeCoerce Refl)
| otherwise = Nothing
instance GCompare UniqueS where
UniqueS a `gcompare` UniqueS b = case compare a b of
LT -> GLT
-- See note about `unsafeCoerce` above.
EQ -> unsafeCoerce GEQ
GT -> GGT
data DMapS k f a where
DMapS :: !(k a) -> DMapS k f (Maybe (f a))
instance (GEq k) => GEq (DMapS k f) where
DMapS a `geq` DMapS b = case a `geq` b of
Just Refl -> Just Refl
Nothing -> Nothing
instance (GCompare k) => GCompare (DMapS k f) where
DMapS a `gcompare` DMapS b = case a `gcompare` b of
GLT -> GLT
GEQ -> GEQ
GGT -> GGT

2
server/src-lib/Hasura/Prelude.hs
View File

@ -23,7 +23,7 @@ import Control.Monad.Fail as M (MonadFail)
import Control.Monad.Identity as M import Control.Monad.Identity as M
import Control.Monad.Reader as M import Control.Monad.Reader as M
import Control.Monad.State.Strict as M import Control.Monad.State.Strict as M
import Control.Monad.Writer.Strict as M import Control.Monad.Writer.Strict as M (MonadWriter (..), WriterT (..))
import Data.Align as M (Align (align, alignWith)) import Data.Align as M (Align (align, alignWith))
import Data.Align.Key as M (AlignWithKey (..)) import Data.Align.Key as M (AlignWithKey (..))
import Data.Bool as M (bool) import Data.Bool as M (bool)

3
server/src-lib/Hasura/RQL/DDL/ComputedField.hs
View File

@ -15,6 +15,7 @@ module Hasura.RQL.DDL.ComputedField
import Hasura.Prelude import Hasura.Prelude
import Hasura.EncJSON import Hasura.EncJSON
import Hasura.Incremental (Cacheable)
import Hasura.RQL.DDL.Deps import Hasura.RQL.DDL.Deps
import Hasura.RQL.DDL.Permission.Internal import Hasura.RQL.DDL.Permission.Internal
import Hasura.RQL.DDL.Schema.Function (RawFunctionInfo (..), mkFunctionArgs) import Hasura.RQL.DDL.Schema.Function (RawFunctionInfo (..), mkFunctionArgs)
@ -39,6 +40,7 @@ data ComputedFieldDefinition
, _cfdTableArgument :: !(Maybe FunctionArgName) , _cfdTableArgument :: !(Maybe FunctionArgName)
} deriving (Show, Eq, Lift, Generic) } deriving (Show, Eq, Lift, Generic)
instance NFData ComputedFieldDefinition instance NFData ComputedFieldDefinition
instance Cacheable ComputedFieldDefinition
$(deriveJSON (aesonDrop 4 snakeCase) ''ComputedFieldDefinition) $(deriveJSON (aesonDrop 4 snakeCase) ''ComputedFieldDefinition)
data AddComputedField data AddComputedField
@ -49,6 +51,7 @@ data AddComputedField
, _afcComment :: !(Maybe Text) , _afcComment :: !(Maybe Text)
} deriving (Show, Eq, Lift, Generic) } deriving (Show, Eq, Lift, Generic)
instance NFData AddComputedField instance NFData AddComputedField
instance Cacheable AddComputedField
$(deriveJSON (aesonDrop 4 snakeCase) ''AddComputedField) $(deriveJSON (aesonDrop 4 snakeCase) ''AddComputedField)
runAddComputedField :: (MonadTx m, CacheRWM m) => AddComputedField -> m EncJSON runAddComputedField :: (MonadTx m, CacheRWM m) => AddComputedField -> m EncJSON

3
server/src-lib/Hasura/RQL/DDL/Headers.hs
View File

@ -1,6 +1,7 @@
module Hasura.RQL.DDL.Headers where module Hasura.RQL.DDL.Headers where
import Data.Aeson import Data.Aeson
import Hasura.Incremental (Cacheable)
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.Instances () import Hasura.RQL.Instances ()
import Hasura.RQL.Types.Error import Hasura.RQL.Types.Error
@ -14,6 +15,7 @@ data HeaderConf = HeaderConf HeaderName HeaderValue
deriving (Show, Eq, Lift, Generic) deriving (Show, Eq, Lift, Generic)
instance NFData HeaderConf instance NFData HeaderConf
instance Hashable HeaderConf instance Hashable HeaderConf
instance Cacheable HeaderConf
type HeaderName = T.Text type HeaderName = T.Text
@ -21,6 +23,7 @@ data HeaderValue = HVValue T.Text | HVEnv T.Text
deriving (Show, Eq, Lift, Generic) deriving (Show, Eq, Lift, Generic)
instance NFData HeaderValue instance NFData HeaderValue
instance Hashable HeaderValue instance Hashable HeaderValue
instance Cacheable HeaderValue
instance FromJSON HeaderConf where instance FromJSON HeaderConf where
parseJSON (Object o) = do parseJSON (Object o) = do

8
server/src-lib/Hasura/RQL/DDL/Permission.hs
View File

@ -48,6 +48,7 @@ module Hasura.RQL.DDL.Permission
) where ) where
import Hasura.EncJSON import Hasura.EncJSON
import Hasura.Incremental (Cacheable)
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.DDL.Permission.Internal import Hasura.RQL.DDL.Permission.Internal
import Hasura.RQL.DDL.Permission.Triggers import Hasura.RQL.DDL.Permission.Triggers
@ -76,7 +77,7 @@ data InsPerm
, ipSet :: !(Maybe (ColumnValues Value)) , ipSet :: !(Maybe (ColumnValues Value))
, ipColumns :: !(Maybe PermColSpec) , ipColumns :: !(Maybe PermColSpec)
} deriving (Show, Eq, Lift, Generic) } deriving (Show, Eq, Lift, Generic)
instance Cacheable InsPerm
$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''InsPerm) $(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''InsPerm)
type InsPermDef = PermDef InsPerm type InsPermDef = PermDef InsPerm
@ -208,6 +209,7 @@ data SelPerm
, spAllowAggregations :: !Bool -- ^ Allow aggregation , spAllowAggregations :: !Bool -- ^ Allow aggregation
, spComputedFields :: ![ComputedFieldName] -- ^ Allowed computed fields , spComputedFields :: ![ComputedFieldName] -- ^ Allowed computed fields
} deriving (Show, Eq, Lift, Generic) } deriving (Show, Eq, Lift, Generic)
instance Cacheable SelPerm
$(deriveToJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''SelPerm) $(deriveToJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''SelPerm)
instance FromJSON SelPerm where instance FromJSON SelPerm where
@ -295,7 +297,7 @@ data UpdPerm
, ucSet :: !(Maybe (ColumnValues Value)) -- Preset columns , ucSet :: !(Maybe (ColumnValues Value)) -- Preset columns
, ucFilter :: !BoolExp -- Filter expression , ucFilter :: !BoolExp -- Filter expression
} deriving (Show, Eq, Lift, Generic) } deriving (Show, Eq, Lift, Generic)
instance Cacheable UpdPerm
$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''UpdPerm) $(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''UpdPerm)
type UpdPermDef = PermDef UpdPerm type UpdPermDef = PermDef UpdPerm
@ -358,7 +360,7 @@ instance IsPerm UpdPerm where
data DelPerm data DelPerm
= DelPerm { dcFilter :: !BoolExp } = DelPerm { dcFilter :: !BoolExp }
deriving (Show, Eq, Lift, Generic) deriving (Show, Eq, Lift, Generic)
instance Cacheable DelPerm
$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''DelPerm) $(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''DelPerm)
type DelPermDef = PermDef DelPerm type DelPermDef = PermDef DelPerm

4
server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs
View File

@ -18,6 +18,7 @@ import qualified Data.Text.Extended as T
import qualified Hasura.SQL.DML as S import qualified Hasura.SQL.DML as S
import Hasura.EncJSON import Hasura.EncJSON
import Hasura.Incremental (Cacheable)
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.GBoolExp import Hasura.RQL.GBoolExp
import Hasura.RQL.Types import Hasura.RQL.Types
@ -31,6 +32,7 @@ data PermColSpec
= PCStar = PCStar
| PCCols ![PGCol] | PCCols ![PGCol]
deriving (Show, Eq, Lift, Generic) deriving (Show, Eq, Lift, Generic)
instance Cacheable PermColSpec
instance FromJSON PermColSpec where instance FromJSON PermColSpec where
parseJSON (String "*") = return PCStar parseJSON (String "*") = return PCStar
@ -156,7 +158,7 @@ data PermDef a =
, pdPermission :: !a , pdPermission :: !a
, pdComment :: !(Maybe T.Text) , pdComment :: !(Maybe T.Text)
} deriving (Show, Eq, Lift, Generic) } deriving (Show, Eq, Lift, Generic)
instance (Cacheable a) => Cacheable (PermDef a)
$(deriveFromJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''PermDef) $(deriveFromJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''PermDef)
instance (ToJSON a) => ToJSON (PermDef a) where instance (ToJSON a) => ToJSON (PermDef a) where

2
server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs
View File

@ -57,7 +57,7 @@ import Hasura.SQL.Types
import Debug.Trace import Debug.Trace
buildRebuildableSchemaCache buildRebuildableSchemaCache
:: (MonadIO m, MonadTx m, HasHttpManager m, HasSQLGenCtx m) :: (MonadIO m, MonadUnique m, MonadTx m, HasHttpManager m, HasSQLGenCtx m)
=> m (RebuildableSchemaCache m) => m (RebuildableSchemaCache m)
buildRebuildableSchemaCache = do buildRebuildableSchemaCache = do
catalogMetadata <- liftTx fetchCatalogData catalogMetadata <- liftTx fetchCatalogData

1
server/src-lib/Hasura/RQL/DDL/Schema/Cache/Dependencies.hs
View File

@ -11,6 +11,7 @@ import Control.Arrow.Extended
import Control.Lens hiding ((.=)) import Control.Lens hiding ((.=))
import Data.Aeson import Data.Aeson
import Data.List (nub) import Data.List (nub)
import Data.Monoid (First)
import Hasura.RQL.DDL.Schema.Cache.Common import Hasura.RQL.DDL.Schema.Cache.Common
import Hasura.RQL.Types import Hasura.RQL.Types

4
server/src-lib/Hasura/RQL/DDL/Schema/Cache/Permission.hs
View File

@ -82,7 +82,7 @@ withPermission f = proc (e, (permission, s)) -> do
buildPermission buildPermission
:: ( ArrowChoice arr, Inc.ArrowCache arr, ArrowKleisli m arr :: ( ArrowChoice arr, Inc.ArrowCache arr, ArrowKleisli m arr
, ArrowWriter (Seq CollectedInfo) arr, MonadTx m, MonadReader BuildReason m , ArrowWriter (Seq CollectedInfo) arr, MonadTx m, MonadReader BuildReason m
, Eq a, IsPerm a, FromJSON a, Eq (PermInfo a) ) , Inc.Cacheable a, IsPerm a, FromJSON a, Inc.Cacheable (PermInfo a) )
=> ( TableCoreCache => ( TableCoreCache
, TableCoreInfo , TableCoreInfo
, [CatalogPermission] , [CatalogPermission]
@ -109,7 +109,7 @@ buildPermission = Inc.cache proc (tableCache, tableInfo, permissions) -> do
rebuildViewsIfNeeded rebuildViewsIfNeeded
:: ( Inc.ArrowCache arr, ArrowKleisli m arr, MonadTx m, MonadReader BuildReason m :: ( Inc.ArrowCache arr, ArrowKleisli m arr, MonadTx m, MonadReader BuildReason m
, Eq a, IsPerm a, Eq (PermInfo a) ) , Inc.Cacheable a, IsPerm a, Inc.Cacheable (PermInfo a) )
=> (QualifiedTable, PermDef a, PermInfo a) `arr` () => (QualifiedTable, PermDef a, PermInfo a) `arr` ()
rebuildViewsIfNeeded = Inc.cache $ arrM \(tableName, permDef, info) -> do rebuildViewsIfNeeded = Inc.cache $ arrM \(tableName, permDef, info) -> do
liftTx . liftIO $ traceEventIO "START permissions/build/views" liftTx . liftIO $ traceEventIO "START permissions/build/views"

3
server/src-lib/Hasura/RQL/DDL/Schema/Function.hs
View File

@ -6,6 +6,7 @@ module Hasura.RQL.DDL.Schema.Function where
import Hasura.EncJSON import Hasura.EncJSON
import Hasura.GraphQL.Utils (showNames) import Hasura.GraphQL.Utils (showNames)
import Hasura.Incremental (Cacheable)
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.Types import Hasura.RQL.Types
import Hasura.Server.Utils (makeReasonMessage) import Hasura.Server.Utils (makeReasonMessage)
@ -41,6 +42,7 @@ data RawFunctionInfo
, rfiDescription :: !(Maybe PGDescription) , rfiDescription :: !(Maybe PGDescription)
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData RawFunctionInfo instance NFData RawFunctionInfo
instance Cacheable RawFunctionInfo
$(deriveJSON (aesonDrop 3 snakeCase) ''RawFunctionInfo) $(deriveJSON (aesonDrop 3 snakeCase) ''RawFunctionInfo)
mkFunctionArgs :: Int -> [QualifiedPGType] -> [FunctionArgName] -> [FunctionArg] mkFunctionArgs :: Int -> [QualifiedPGType] -> [FunctionArgName] -> [FunctionArg]
@ -184,6 +186,7 @@ data FunctionConfig
{ _fcSessionArgument :: !(Maybe FunctionArgName) { _fcSessionArgument :: !(Maybe FunctionArgName)
} deriving (Show, Eq, Generic, Lift) } deriving (Show, Eq, Generic, Lift)
instance NFData FunctionConfig instance NFData FunctionConfig
instance Cacheable FunctionConfig
$(deriveJSON (aesonDrop 3 snakeCase){omitNothingFields = True} ''FunctionConfig) $(deriveJSON (aesonDrop 3 snakeCase){omitNothingFields = True} ''FunctionConfig)
emptyFunctionConfig :: FunctionConfig emptyFunctionConfig :: FunctionConfig

24
server/src-lib/Hasura/RQL/Instances.hs
View File

@ -4,12 +4,14 @@ module Hasura.RQL.Instances where
import Hasura.Prelude import Hasura.Prelude
import Instances.TH.Lift ()
import qualified Language.Haskell.TH.Syntax as TH
import qualified Data.HashMap.Strict as M import qualified Data.HashMap.Strict as M
import qualified Data.HashSet as S import qualified Data.HashSet as S
import qualified Language.GraphQL.Draft.Syntax as G import qualified Language.GraphQL.Draft.Syntax as G
import qualified Language.Haskell.TH.Syntax as TH
import Data.Functor.Product
import Data.GADT.Compare
import Instances.TH.Lift ()
instance NFData G.Argument instance NFData G.Argument
instance NFData G.Directive instance NFData G.Directive
@ -45,3 +47,19 @@ instance (TH.Lift k, TH.Lift v) => TH.Lift (M.HashMap k v) where
instance TH.Lift a => TH.Lift (S.HashSet a) where instance TH.Lift a => TH.Lift (S.HashSet a) where
lift s = [| S.fromList $(TH.lift $ S.toList s) |] lift s = [| S.fromList $(TH.lift $ S.toList s) |]
instance (GEq f, GEq g) => GEq (Product f g) where
Pair a1 a2 `geq` Pair b1 b2
| Just Refl <- a1 `geq` b1
, Just Refl <- a2 `geq` b2
= Just Refl
| otherwise = Nothing
instance (GCompare f, GCompare g) => GCompare (Product f g) where
Pair a1 a2 `gcompare` Pair b1 b2 = case gcompare a1 b1 of
GLT -> GLT
GEQ -> case gcompare a2 b2 of
GLT -> GLT
GEQ -> GEQ
GGT -> GGT
GGT -> GGT

10
server/src-lib/Hasura/RQL/Types/BoolExp.hs
View File

@ -36,6 +36,7 @@ module Hasura.RQL.Types.BoolExp
, PreSetColsPartial , PreSetColsPartial
) where ) where
import Hasura.Incremental (Cacheable)
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.Types.Column import Hasura.RQL.Types.Column
import Hasura.RQL.Types.Common import Hasura.RQL.Types.Common
@ -61,6 +62,7 @@ data GExists a
} deriving (Show, Eq, Lift, Functor, Foldable, Traversable, Data, Generic) } deriving (Show, Eq, Lift, Functor, Foldable, Traversable, Data, Generic)
instance (NFData a) => NFData (GExists a) instance (NFData a) => NFData (GExists a)
instance (Data a) => Plated (GExists a) instance (Data a) => Plated (GExists a)
instance (Cacheable a) => Cacheable (GExists a)
gExistsToJSON :: (a -> (Text, Value)) -> GExists a -> Value gExistsToJSON :: (a -> (Text, Value)) -> GExists a -> Value
gExistsToJSON f (GExists qt wh) = gExistsToJSON f (GExists qt wh) =
@ -86,6 +88,7 @@ data GBoolExp a
deriving (Show, Eq, Lift, Functor, Foldable, Traversable, Data, Generic) deriving (Show, Eq, Lift, Functor, Foldable, Traversable, Data, Generic)
instance (NFData a) => NFData (GBoolExp a) instance (NFData a) => NFData (GBoolExp a)
instance (Data a) => Plated (GBoolExp a) instance (Data a) => Plated (GBoolExp a)
instance (Cacheable a) => Cacheable (GBoolExp a)
gBoolExpTrue :: GBoolExp a gBoolExpTrue :: GBoolExp a
gBoolExpTrue = BoolAnd [] gBoolExpTrue = BoolAnd []
@ -136,6 +139,7 @@ data DWithinGeomOp a =
, dwgeomFrom :: !a , dwgeomFrom :: !a
} deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data) } deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data)
instance (NFData a) => NFData (DWithinGeomOp a) instance (NFData a) => NFData (DWithinGeomOp a)
instance (Cacheable a) => Cacheable (DWithinGeomOp a)
$(deriveJSON (aesonDrop 6 snakeCase) ''DWithinGeomOp) $(deriveJSON (aesonDrop 6 snakeCase) ''DWithinGeomOp)
data DWithinGeogOp a = data DWithinGeogOp a =
@ -145,6 +149,7 @@ data DWithinGeogOp a =
, dwgeogUseSpheroid :: !a , dwgeogUseSpheroid :: !a
} deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data) } deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data)
instance (NFData a) => NFData (DWithinGeogOp a) instance (NFData a) => NFData (DWithinGeogOp a)
instance (Cacheable a) => Cacheable (DWithinGeogOp a)
$(deriveJSON (aesonDrop 6 snakeCase) ''DWithinGeogOp) $(deriveJSON (aesonDrop 6 snakeCase) ''DWithinGeogOp)
data STIntersectsNbandGeommin a = data STIntersectsNbandGeommin a =
@ -153,6 +158,7 @@ data STIntersectsNbandGeommin a =
, singGeommin :: !a , singGeommin :: !a
} deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data) } deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data)
instance (NFData a) => NFData (STIntersectsNbandGeommin a) instance (NFData a) => NFData (STIntersectsNbandGeommin a)
instance (Cacheable a) => Cacheable (STIntersectsNbandGeommin a)
$(deriveJSON (aesonDrop 4 snakeCase) ''STIntersectsNbandGeommin) $(deriveJSON (aesonDrop 4 snakeCase) ''STIntersectsNbandGeommin)
data STIntersectsGeomminNband a = data STIntersectsGeomminNband a =
@ -161,6 +167,7 @@ data STIntersectsGeomminNband a =
, signNband :: !(Maybe a) , signNband :: !(Maybe a)
} deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data) } deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data)
instance (NFData a) => NFData (STIntersectsGeomminNband a) instance (NFData a) => NFData (STIntersectsGeomminNband a)
instance (Cacheable a) => Cacheable (STIntersectsGeomminNband a)
$(deriveJSON (aesonDrop 4 snakeCase) ''STIntersectsGeomminNband) $(deriveJSON (aesonDrop 4 snakeCase) ''STIntersectsGeomminNband)
type CastExp a = M.HashMap PGScalarType [OpExpG a] type CastExp a = M.HashMap PGScalarType [OpExpG a]
@ -219,6 +226,7 @@ data OpExpG a
| CLTE !PGCol | CLTE !PGCol
deriving (Eq, Show, Functor, Foldable, Traversable, Generic, Data) deriving (Eq, Show, Functor, Foldable, Traversable, Generic, Data)
instance (NFData a) => NFData (OpExpG a) instance (NFData a) => NFData (OpExpG a)
instance (Cacheable a) => Cacheable (OpExpG a)
opExpDepCol :: OpExpG a -> Maybe PGCol opExpDepCol :: OpExpG a -> Maybe PGCol
opExpDepCol = \case opExpDepCol = \case
@ -291,6 +299,7 @@ data AnnBoolExpFld a
| AVRel !RelInfo !(AnnBoolExp a) | AVRel !RelInfo !(AnnBoolExp a)
deriving (Show, Eq, Functor, Foldable, Traversable, Generic) deriving (Show, Eq, Functor, Foldable, Traversable, Generic)
instance (NFData a) => NFData (AnnBoolExpFld a) instance (NFData a) => NFData (AnnBoolExpFld a)
instance (Cacheable a) => Cacheable (AnnBoolExpFld a)
type AnnBoolExp a type AnnBoolExp a
= GBoolExp (AnnBoolExpFld a) = GBoolExp (AnnBoolExpFld a)
@ -336,6 +345,7 @@ data PartialSQLExp
| PSESQLExp !S.SQLExp | PSESQLExp !S.SQLExp
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData PartialSQLExp instance NFData PartialSQLExp
instance Cacheable PartialSQLExp
mkTypedSessionVar :: PGType PGColumnType -> SessVar -> PartialSQLExp mkTypedSessionVar :: PGType PGColumnType -> SessVar -> PartialSQLExp
mkTypedSessionVar columnType = mkTypedSessionVar columnType =

11
server/src-lib/Hasura/RQL/Types/Catalog.hs
View File

@ -22,6 +22,7 @@ import Data.Aeson
import Data.Aeson.Casing import Data.Aeson.Casing
import Data.Aeson.TH import Data.Aeson.TH
import Hasura.Incremental (Cacheable)
import Hasura.RQL.DDL.ComputedField import Hasura.RQL.DDL.ComputedField
import Hasura.RQL.DDL.Schema.Function import Hasura.RQL.DDL.Schema.Function
import Hasura.RQL.Types.Column import Hasura.RQL.Types.Column
@ -36,7 +37,7 @@ import Hasura.SQL.Types
newtype CatalogForeignKey newtype CatalogForeignKey
= CatalogForeignKey = CatalogForeignKey
{ unCatalogForeignKey :: ForeignKey { unCatalogForeignKey :: ForeignKey
} deriving (Show, Eq, NFData, Hashable) } deriving (Show, Eq, NFData, Hashable, Cacheable)
instance FromJSON CatalogForeignKey where instance FromJSON CatalogForeignKey where
parseJSON = withObject "CatalogForeignKey" \o -> do parseJSON = withObject "CatalogForeignKey" \o -> do
@ -66,6 +67,7 @@ data CatalogTableInfo
, _ctiDescription :: !(Maybe PGDescription) , _ctiDescription :: !(Maybe PGDescription)
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData CatalogTableInfo instance NFData CatalogTableInfo
instance Cacheable CatalogTableInfo
$(deriveFromJSON (aesonDrop 4 snakeCase) ''CatalogTableInfo) $(deriveFromJSON (aesonDrop 4 snakeCase) ''CatalogTableInfo)
data CatalogTable data CatalogTable
@ -77,6 +79,7 @@ data CatalogTable
, _ctInfo :: !(Maybe CatalogTableInfo) , _ctInfo :: !(Maybe CatalogTableInfo)
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData CatalogTable instance NFData CatalogTable
instance Cacheable CatalogTable
$(deriveFromJSON (aesonDrop 3 snakeCase) ''CatalogTable) $(deriveFromJSON (aesonDrop 3 snakeCase) ''CatalogTable)
data CatalogRelation data CatalogRelation
@ -88,6 +91,7 @@ data CatalogRelation
, _crComment :: !(Maybe Text) , _crComment :: !(Maybe Text)
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData CatalogRelation instance NFData CatalogRelation
instance Cacheable CatalogRelation
$(deriveFromJSON (aesonDrop 3 snakeCase) ''CatalogRelation) $(deriveFromJSON (aesonDrop 3 snakeCase) ''CatalogRelation)
data CatalogPermission data CatalogPermission
@ -100,6 +104,7 @@ data CatalogPermission
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData CatalogPermission instance NFData CatalogPermission
instance Hashable CatalogPermission instance Hashable CatalogPermission
instance Cacheable CatalogPermission
$(deriveFromJSON (aesonDrop 3 snakeCase) ''CatalogPermission) $(deriveFromJSON (aesonDrop 3 snakeCase) ''CatalogPermission)
data CatalogComputedField data CatalogComputedField
@ -108,6 +113,7 @@ data CatalogComputedField
, _cccFunctionInfo :: ![RawFunctionInfo] -- ^ multiple functions with same name , _cccFunctionInfo :: ![RawFunctionInfo] -- ^ multiple functions with same name
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData CatalogComputedField instance NFData CatalogComputedField
instance Cacheable CatalogComputedField
$(deriveFromJSON (aesonDrop 4 snakeCase) ''CatalogComputedField) $(deriveFromJSON (aesonDrop 4 snakeCase) ''CatalogComputedField)
data CatalogEventTrigger data CatalogEventTrigger
@ -117,6 +123,7 @@ data CatalogEventTrigger
, _cetDef :: !Value , _cetDef :: !Value
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData CatalogEventTrigger instance NFData CatalogEventTrigger
instance Cacheable CatalogEventTrigger
$(deriveFromJSON (aesonDrop 4 snakeCase) ''CatalogEventTrigger) $(deriveFromJSON (aesonDrop 4 snakeCase) ''CatalogEventTrigger)
data CatalogFunction data CatalogFunction
@ -127,6 +134,7 @@ data CatalogFunction
, _cfInfo :: ![RawFunctionInfo] -- ^ multiple functions with same name , _cfInfo :: ![RawFunctionInfo] -- ^ multiple functions with same name
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData CatalogFunction instance NFData CatalogFunction
instance Cacheable CatalogFunction
$(deriveFromJSON (aesonDrop 3 snakeCase) ''CatalogFunction) $(deriveFromJSON (aesonDrop 3 snakeCase) ''CatalogFunction)
data CatalogMetadata data CatalogMetadata
@ -141,4 +149,5 @@ data CatalogMetadata
, _cmComputedFields :: ![CatalogComputedField] , _cmComputedFields :: ![CatalogComputedField]
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData CatalogMetadata instance NFData CatalogMetadata
instance Cacheable CatalogMetadata
$(deriveFromJSON (aesonDrop 3 snakeCase) ''CatalogMetadata) $(deriveFromJSON (aesonDrop 3 snakeCase) ''CatalogMetadata)

9
server/src-lib/Hasura/RQL/Types/Column.hs
View File

@ -35,6 +35,7 @@ import Data.Aeson.Casing
import Data.Aeson.TH import Data.Aeson.TH
import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax (Lift)
import Hasura.Incremental (Cacheable)
import Hasura.RQL.Instances () import Hasura.RQL.Instances ()
import Hasura.RQL.Types.Error import Hasura.RQL.Types.Error
import Hasura.SQL.Types import Hasura.SQL.Types
@ -42,12 +43,12 @@ import Hasura.SQL.Value
newtype EnumValue newtype EnumValue
= EnumValue { getEnumValue :: T.Text } = EnumValue { getEnumValue :: T.Text }
deriving (Show, Eq, Lift, NFData, Hashable, ToJSON, ToJSONKey, FromJSON, FromJSONKey) deriving (Show, Eq, Lift, NFData, Hashable, ToJSON, ToJSONKey, FromJSON, FromJSONKey, Cacheable)
newtype EnumValueInfo newtype EnumValueInfo
= EnumValueInfo = EnumValueInfo
{ evComment :: Maybe T.Text { evComment :: Maybe T.Text
} deriving (Show, Eq, Lift, NFData, Hashable) } deriving (Show, Eq, Lift, NFData, Hashable, Cacheable)
$(deriveJSON (aesonDrop 2 snakeCase) ''EnumValueInfo) $(deriveJSON (aesonDrop 2 snakeCase) ''EnumValueInfo)
type EnumValues = M.HashMap EnumValue EnumValueInfo type EnumValues = M.HashMap EnumValue EnumValueInfo
@ -61,6 +62,7 @@ data EnumReference
} deriving (Show, Eq, Generic, Lift) } deriving (Show, Eq, Generic, Lift)
instance NFData EnumReference instance NFData EnumReference
instance Hashable EnumReference instance Hashable EnumReference
instance Cacheable EnumReference
$(deriveJSON (aesonDrop 2 snakeCase) ''EnumReference) $(deriveJSON (aesonDrop 2 snakeCase) ''EnumReference)
-- | The type we use for columns, which are currently always “scalars” (though see the note about -- | The type we use for columns, which are currently always “scalars” (though see the note about
@ -77,6 +79,7 @@ data PGColumnType
deriving (Show, Eq, Generic) deriving (Show, Eq, Generic)
instance NFData PGColumnType instance NFData PGColumnType
instance Hashable PGColumnType instance Hashable PGColumnType
instance Cacheable PGColumnType
$(deriveToJSON defaultOptions{constructorTagModifier = drop 8} ''PGColumnType) $(deriveToJSON defaultOptions{constructorTagModifier = drop 8} ''PGColumnType)
$(makePrisms ''PGColumnType) $(makePrisms ''PGColumnType)
@ -137,6 +140,7 @@ data PGRawColumnInfo
, prciDescription :: !(Maybe PGDescription) , prciDescription :: !(Maybe PGDescription)
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData PGRawColumnInfo instance NFData PGRawColumnInfo
instance Cacheable PGRawColumnInfo
$(deriveJSON (aesonDrop 4 snakeCase) ''PGRawColumnInfo) $(deriveJSON (aesonDrop 4 snakeCase) ''PGRawColumnInfo)
-- | “Resolved” column info, produced from a 'PGRawColumnInfo' value that has been combined with -- | “Resolved” column info, produced from a 'PGRawColumnInfo' value that has been combined with
@ -151,6 +155,7 @@ data PGColumnInfo
, pgiDescription :: !(Maybe PGDescription) , pgiDescription :: !(Maybe PGDescription)
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData PGColumnInfo instance NFData PGColumnInfo
instance Cacheable PGColumnInfo
$(deriveToJSON (aesonDrop 3 snakeCase) ''PGColumnInfo) $(deriveToJSON (aesonDrop 3 snakeCase) ''PGColumnInfo)
onlyIntCols :: [PGColumnInfo] -> [PGColumnInfo] onlyIntCols :: [PGColumnInfo] -> [PGColumnInfo]

16
server/src-lib/Hasura/RQL/Types/Common.hs
View File

@ -33,6 +33,7 @@ module Hasura.RQL.Types.Common
, isSystemDefined , isSystemDefined
) where ) where
import Hasura.Incremental (Cacheable)
import Hasura.Prelude import Hasura.Prelude
import Hasura.SQL.Types import Hasura.SQL.Types
@ -52,7 +53,7 @@ import qualified PostgreSQL.Binary.Decoding as PD
import qualified Test.QuickCheck as QC import qualified Test.QuickCheck as QC
newtype NonEmptyText = NonEmptyText {unNonEmptyText :: T.Text} newtype NonEmptyText = NonEmptyText {unNonEmptyText :: T.Text}
deriving (Show, Eq, Ord, Hashable, ToJSON, ToJSONKey, Lift, Q.ToPrepArg, DQuote, Generic, NFData) deriving (Show, Eq, Ord, Hashable, ToJSON, ToJSONKey, Lift, Q.ToPrepArg, DQuote, Generic, NFData, Cacheable)
instance Arbitrary NonEmptyText where instance Arbitrary NonEmptyText where
arbitrary = NonEmptyText . T.pack <$> QC.listOf1 (QC.elements alphaNumerics) arbitrary = NonEmptyText . T.pack <$> QC.listOf1 (QC.elements alphaNumerics)
@ -84,7 +85,7 @@ rootText = NonEmptyText "root"
newtype RelName newtype RelName
= RelName { getRelTxt :: NonEmptyText } = RelName { getRelTxt :: NonEmptyText }
deriving (Show, Eq, Hashable, FromJSON, ToJSON, Q.ToPrepArg, Q.FromCol, Lift, Generic, Arbitrary, NFData) deriving (Show, Eq, Hashable, FromJSON, ToJSON, Q.ToPrepArg, Q.FromCol, Lift, Generic, Arbitrary, NFData, Cacheable)
instance IsIden RelName where instance IsIden RelName where
toIden rn = Iden $ relNameToTxt rn toIden rn = Iden $ relNameToTxt rn
@ -108,6 +109,7 @@ data RelType
deriving (Show, Eq, Generic) deriving (Show, Eq, Generic)
instance NFData RelType instance NFData RelType
instance Hashable RelType instance Hashable RelType
instance Cacheable RelType
instance ToJSON RelType where instance ToJSON RelType where
toJSON = String . relTypeToTxt toJSON = String . relTypeToTxt
@ -132,11 +134,12 @@ data RelInfo
, riIsManual :: !Bool , riIsManual :: !Bool
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData RelInfo instance NFData RelInfo
instance Cacheable RelInfo
$(deriveToJSON (aesonDrop 2 snakeCase) ''RelInfo) $(deriveToJSON (aesonDrop 2 snakeCase) ''RelInfo)
newtype FieldName newtype FieldName
= FieldName { getFieldNameTxt :: T.Text } = FieldName { getFieldNameTxt :: T.Text }
deriving (Show, Eq, Ord, Hashable, FromJSON, ToJSON, FromJSONKey, ToJSONKey, Lift, Data, Generic, Arbitrary, NFData) deriving (Show, Eq, Ord, Hashable, FromJSON, ToJSON, FromJSONKey, ToJSONKey, Lift, Data, Generic, Arbitrary, NFData, Cacheable)
instance IsIden FieldName where instance IsIden FieldName where
toIden (FieldName f) = Iden f toIden (FieldName f) = Iden f
@ -182,7 +185,7 @@ type ColMapping = HM.HashMap PGCol PGCol
-- | Postgres OIDs. <https://www.postgresql.org/docs/12/datatype-oid.html> -- | Postgres OIDs. <https://www.postgresql.org/docs/12/datatype-oid.html>
newtype OID = OID { unOID :: Int } newtype OID = OID { unOID :: Int }
deriving (Show, Eq, NFData, Hashable, ToJSON, FromJSON, Q.FromCol) deriving (Show, Eq, NFData, Hashable, ToJSON, FromJSON, Q.FromCol, Cacheable)
data Constraint data Constraint
= Constraint = Constraint
@ -191,6 +194,7 @@ data Constraint
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData Constraint instance NFData Constraint
instance Hashable Constraint instance Hashable Constraint
instance Cacheable Constraint
$(deriveJSON (aesonDrop 2 snakeCase) ''Constraint) $(deriveJSON (aesonDrop 2 snakeCase) ''Constraint)
data PrimaryKey a data PrimaryKey a
@ -199,6 +203,7 @@ data PrimaryKey a
, _pkColumns :: !(NonEmpty a) , _pkColumns :: !(NonEmpty a)
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance (NFData a) => NFData (PrimaryKey a) instance (NFData a) => NFData (PrimaryKey a)
instance (Cacheable a) => Cacheable (PrimaryKey a)
$(makeLenses ''PrimaryKey) $(makeLenses ''PrimaryKey)
$(deriveJSON (aesonDrop 3 snakeCase) ''PrimaryKey) $(deriveJSON (aesonDrop 3 snakeCase) ''PrimaryKey)
@ -210,12 +215,13 @@ data ForeignKey
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData ForeignKey instance NFData ForeignKey
instance Hashable ForeignKey instance Hashable ForeignKey
instance Cacheable ForeignKey
$(deriveJSON (aesonDrop 3 snakeCase) ''ForeignKey) $(deriveJSON (aesonDrop 3 snakeCase) ''ForeignKey)
type CustomColumnNames = HM.HashMap PGCol G.Name type CustomColumnNames = HM.HashMap PGCol G.Name
newtype SystemDefined = SystemDefined { unSystemDefined :: Bool } newtype SystemDefined = SystemDefined { unSystemDefined :: Bool }
deriving (Show, Eq, FromJSON, ToJSON, Q.ToPrepArg, NFData) deriving (Show, Eq, FromJSON, ToJSON, Q.ToPrepArg, NFData, Cacheable)
isSystemDefined :: SystemDefined -> Bool isSystemDefined :: SystemDefined -> Bool
isSystemDefined = unSystemDefined isSystemDefined = unSystemDefined

15
server/src-lib/Hasura/RQL/Types/ComputedField.hs
View File

@ -4,6 +4,7 @@ Description: Schema cache types related to computed field
module Hasura.RQL.Types.ComputedField where module Hasura.RQL.Types.ComputedField where
import Hasura.Incremental (Cacheable)
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.Types.Common import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Function import Hasura.RQL.Types.Function
@ -21,7 +22,7 @@ import qualified Database.PG.Query as Q
newtype ComputedFieldName = newtype ComputedFieldName =
ComputedFieldName { unComputedFieldName :: NonEmptyText} ComputedFieldName { unComputedFieldName :: NonEmptyText}
deriving (Show, Eq, NFData, Lift, FromJSON, ToJSON, Q.ToPrepArg, DQuote, Hashable, Q.FromCol, Generic, Arbitrary) deriving (Show, Eq, NFData, Lift, FromJSON, ToJSON, Q.ToPrepArg, DQuote, Hashable, Q.FromCol, Generic, Arbitrary, Cacheable)
computedFieldNameToText :: ComputedFieldName -> Text computedFieldNameToText :: ComputedFieldName -> Text
computedFieldNameToText = unNonEmptyText . unComputedFieldName computedFieldNameToText = unNonEmptyText . unComputedFieldName
@ -36,7 +37,8 @@ data FunctionTableArgument
| FTANamed | FTANamed
!FunctionArgName -- ^ argument name !FunctionArgName -- ^ argument name
!Int -- ^ argument index !Int -- ^ argument index
deriving (Show, Eq) deriving (Show, Eq, Generic)
instance Cacheable FunctionTableArgument
instance ToJSON FunctionTableArgument where instance ToJSON FunctionTableArgument where
toJSON FTAFirst = String "first_argument" toJSON FTAFirst = String "first_argument"
@ -45,7 +47,8 @@ instance ToJSON FunctionTableArgument where
data ComputedFieldReturn data ComputedFieldReturn
= CFRScalar !PGScalarType = CFRScalar !PGScalarType
| CFRSetofTable !QualifiedTable | CFRSetofTable !QualifiedTable
deriving (Show, Eq) deriving (Show, Eq, Generic)
instance Cacheable ComputedFieldReturn
$(deriveToJSON defaultOptions { constructorTagModifier = snakeCase . drop 3 $(deriveToJSON defaultOptions { constructorTagModifier = snakeCase . drop 3
, sumEncoding = TaggedObject "type" "info" , sumEncoding = TaggedObject "type" "info"
} }
@ -59,7 +62,8 @@ data ComputedFieldFunction
, _cffInputArgs :: !(Seq.Seq FunctionArg) , _cffInputArgs :: !(Seq.Seq FunctionArg)
, _cffTableArgument :: !FunctionTableArgument , _cffTableArgument :: !FunctionTableArgument
, _cffDescription :: !(Maybe PGDescription) , _cffDescription :: !(Maybe PGDescription)
} deriving (Show, Eq) } deriving (Show, Eq, Generic)
instance Cacheable ComputedFieldFunction
$(deriveToJSON (aesonDrop 4 snakeCase) ''ComputedFieldFunction) $(deriveToJSON (aesonDrop 4 snakeCase) ''ComputedFieldFunction)
data ComputedFieldInfo data ComputedFieldInfo
@ -68,7 +72,8 @@ data ComputedFieldInfo
, _cfiFunction :: !ComputedFieldFunction , _cfiFunction :: !ComputedFieldFunction
, _cfiReturnType :: !ComputedFieldReturn , _cfiReturnType :: !ComputedFieldReturn
, _cfiComment :: !(Maybe Text) , _cfiComment :: !(Maybe Text)
} deriving (Show, Eq) } deriving (Show, Eq, Generic)
instance Cacheable ComputedFieldInfo
$(deriveToJSON (aesonDrop 4 snakeCase) ''ComputedFieldInfo) $(deriveToJSON (aesonDrop 4 snakeCase) ''ComputedFieldInfo)
$(makeLenses ''ComputedFieldInfo) $(makeLenses ''ComputedFieldInfo)

5
server/src-lib/Hasura/RQL/Types/DML.hs
View File

@ -40,6 +40,7 @@ module Hasura.RQL.Types.DML
import qualified Hasura.SQL.DML as S import qualified Hasura.SQL.DML as S
import Hasura.Incremental (Cacheable)
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.Types.BoolExp import Hasura.RQL.Types.BoolExp
import Hasura.RQL.Types.Common import Hasura.RQL.Types.Common
@ -63,9 +64,11 @@ data ColExp
{ ceCol :: !FieldName { ceCol :: !FieldName
, ceVal :: !Value , ceVal :: !Value
} deriving (Show, Eq, Lift, Data, Generic) } deriving (Show, Eq, Lift, Data, Generic)
instance Cacheable ColExp
newtype BoolExp newtype BoolExp
= BoolExp { unBoolExp :: GBoolExp ColExp } deriving (Show, Eq, Lift, Generic) = BoolExp { unBoolExp :: GBoolExp ColExp }
deriving (Show, Eq, Lift, Generic, Cacheable)
$(makeWrapped ''BoolExp) $(makeWrapped ''BoolExp)

6
server/src-lib/Hasura/RQL/Types/EventTrigger.hs
View File

@ -26,6 +26,7 @@ module Hasura.RQL.Types.EventTrigger
import Data.Aeson import Data.Aeson
import Data.Aeson.Casing import Data.Aeson.Casing
import Data.Aeson.TH import Data.Aeson.TH
import Hasura.Incremental (Cacheable)
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.DDL.Headers import Hasura.RQL.DDL.Headers
import Hasura.RQL.Types.Common (NonEmptyText (..)) import Hasura.RQL.Types.Common (NonEmptyText (..))
@ -38,7 +39,7 @@ import qualified Database.PG.Query as Q
import qualified Text.Regex.TDFA as TDFA import qualified Text.Regex.TDFA as TDFA
newtype TriggerName = TriggerName { unTriggerName :: NonEmptyText } newtype TriggerName = TriggerName { unTriggerName :: NonEmptyText }
deriving (Show, Eq, Hashable, Lift, DQuote, FromJSON, ToJSON, ToJSONKey, Q.FromCol, Q.ToPrepArg, Generic, Arbitrary, NFData) deriving (Show, Eq, Hashable, Lift, DQuote, FromJSON, ToJSON, ToJSONKey, Q.FromCol, Q.ToPrepArg, Generic, Arbitrary, NFData, Cacheable)
triggerNameToTxt :: TriggerName -> Text triggerNameToTxt :: TriggerName -> Text
triggerNameToTxt = unNonEmptyText . unTriggerName triggerNameToTxt = unNonEmptyText . unTriggerName
@ -50,6 +51,7 @@ data Ops = INSERT | UPDATE | DELETE | MANUAL deriving (Show)
data SubscribeColumns = SubCStar | SubCArray [PGCol] data SubscribeColumns = SubCStar | SubCArray [PGCol]
deriving (Show, Eq, Generic, Lift) deriving (Show, Eq, Generic, Lift)
instance NFData SubscribeColumns instance NFData SubscribeColumns
instance Cacheable SubscribeColumns
instance FromJSON SubscribeColumns where instance FromJSON SubscribeColumns where
parseJSON (String s) = case s of parseJSON (String s) = case s of
@ -68,6 +70,7 @@ data SubscribeOpSpec
, sosPayload :: !(Maybe SubscribeColumns) , sosPayload :: !(Maybe SubscribeColumns)
} deriving (Show, Eq, Generic, Lift) } deriving (Show, Eq, Generic, Lift)
instance NFData SubscribeOpSpec instance NFData SubscribeOpSpec
instance Cacheable SubscribeOpSpec
$(deriveJSON (aesonDrop 3 snakeCase){omitNothingFields=True} ''SubscribeOpSpec) $(deriveJSON (aesonDrop 3 snakeCase){omitNothingFields=True} ''SubscribeOpSpec)
defaultNumRetries :: Int defaultNumRetries :: Int
@ -177,6 +180,7 @@ data TriggerOpsDef
, tdEnableManual :: !(Maybe Bool) , tdEnableManual :: !(Maybe Bool)
} deriving (Show, Eq, Generic, Lift) } deriving (Show, Eq, Generic, Lift)
instance NFData TriggerOpsDef instance NFData TriggerOpsDef
instance Cacheable TriggerOpsDef
$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''TriggerOpsDef) $(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''TriggerOpsDef)
data DeleteEventTriggerQuery data DeleteEventTriggerQuery

9
server/src-lib/Hasura/RQL/Types/Function.hs
View File

@ -1,5 +1,6 @@
module Hasura.RQL.Types.Function where module Hasura.RQL.Types.Function where
import Hasura.Incremental (Cacheable)
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.Types.Common import Hasura.RQL.Types.Common
import Hasura.SQL.Types import Hasura.SQL.Types
@ -19,6 +20,7 @@ data FunctionType
| FTSTABLE | FTSTABLE
deriving (Eq, Generic) deriving (Eq, Generic)
instance NFData FunctionType instance NFData FunctionType
instance Cacheable FunctionType
$(deriveJSON defaultOptions{constructorTagModifier = drop 2} ''FunctionType) $(deriveJSON defaultOptions{constructorTagModifier = drop 2} ''FunctionType)
funcTypToTxt :: FunctionType -> T.Text funcTypToTxt :: FunctionType -> T.Text
@ -31,17 +33,18 @@ instance Show FunctionType where
newtype FunctionArgName = newtype FunctionArgName =
FunctionArgName { getFuncArgNameTxt :: T.Text} FunctionArgName { getFuncArgNameTxt :: T.Text}
deriving (Show, Eq, NFData, ToJSON, FromJSON, Lift, DQuote, IsString, Generic, Arbitrary) deriving (Show, Eq, NFData, ToJSON, FromJSON, Lift, DQuote, IsString, Generic, Arbitrary, Cacheable)
newtype HasDefault = HasDefault { unHasDefault :: Bool } newtype HasDefault = HasDefault { unHasDefault :: Bool }
deriving (Show, Eq, ToJSON) deriving (Show, Eq, ToJSON, Cacheable)
data FunctionArg data FunctionArg
= FunctionArg = FunctionArg
{ faName :: !(Maybe FunctionArgName) { faName :: !(Maybe FunctionArgName)
, faType :: !QualifiedPGType , faType :: !QualifiedPGType
, faHasDefault :: !HasDefault , faHasDefault :: !HasDefault
} deriving (Show, Eq) } deriving (Show, Eq, Generic)
instance Cacheable FunctionArg
$(deriveToJSON (aesonDrop 2 snakeCase) ''FunctionArg) $(deriveToJSON (aesonDrop 2 snakeCase) ''FunctionArg)
data InputArgument a data InputArgument a

4
server/src-lib/Hasura/RQL/Types/Permission.hs
View File

@ -23,6 +23,7 @@ module Hasura.RQL.Types.Permission
, PermId(..) , PermId(..)
) where ) where
import Hasura.Incremental (Cacheable)
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.Types.Common (NonEmptyText, adminText, mkNonEmptyText, import Hasura.RQL.Types.Common (NonEmptyText, adminText, mkNonEmptyText,
unNonEmptyText) unNonEmptyText)
@ -44,7 +45,7 @@ import qualified PostgreSQL.Binary.Decoding as PD
newtype RoleName newtype RoleName
= RoleName {getRoleTxt :: NonEmptyText} = RoleName {getRoleTxt :: NonEmptyText}
deriving ( Show, Eq, Ord, Hashable, FromJSONKey, ToJSONKey, FromJSON deriving ( Show, Eq, Ord, Hashable, FromJSONKey, ToJSONKey, FromJSON
, ToJSON, Q.FromCol, Q.ToPrepArg, Lift, Generic, Arbitrary, NFData ) , ToJSON, Q.FromCol, Q.ToPrepArg, Lift, Generic, Arbitrary, NFData, Cacheable )
instance DQuote RoleName where instance DQuote RoleName where
dquoteTxt = roleNameToTxt dquoteTxt = roleNameToTxt
@ -122,6 +123,7 @@ data PermType
| PTDelete | PTDelete
deriving (Eq, Lift, Generic) deriving (Eq, Lift, Generic)
instance NFData PermType instance NFData PermType
instance Cacheable PermType
instance Q.FromCol PermType where instance Q.FromCol PermType where
fromCol bs = flip Q.fromColHelper bs $ PD.enum $ \case fromCol bs = flip Q.fromColHelper bs $ PD.enum $ \case

10
server/src-lib/Hasura/RQL/Types/QueryCollection.hs
View File

@ -1,6 +1,7 @@
module Hasura.RQL.Types.QueryCollection where module Hasura.RQL.Types.QueryCollection where
import Hasura.GraphQL.Validate.Types (stripTypenames) import Hasura.GraphQL.Validate.Types (stripTypenames)
import Hasura.Incremental (Cacheable)
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.Types.Common (NonEmptyText) import Hasura.RQL.Types.Common (NonEmptyText)
import Hasura.SQL.Types import Hasura.SQL.Types
@ -24,15 +25,15 @@ newtype CollectionName
newtype QueryName newtype QueryName
= QueryName {unQueryName :: NonEmptyText} = QueryName {unQueryName :: NonEmptyText}
deriving (Show, Eq, Ord, NFData, Hashable, Lift, ToJSON, ToJSONKey, FromJSON, DQuote, Generic, Arbitrary) deriving (Show, Eq, Ord, NFData, Hashable, Lift, ToJSON, ToJSONKey, FromJSON, DQuote, Generic, Arbitrary, Cacheable)
newtype GQLQuery newtype GQLQuery
= GQLQuery {unGQLQuery :: G.ExecutableDocument} = GQLQuery {unGQLQuery :: G.ExecutableDocument}
deriving (Show, Eq, NFData, Hashable, Lift, ToJSON, FromJSON) deriving (Show, Eq, NFData, Hashable, Lift, ToJSON, FromJSON, Cacheable)
newtype GQLQueryWithText newtype GQLQueryWithText
= GQLQueryWithText (T.Text, GQLQuery) = GQLQueryWithText (T.Text, GQLQuery)
deriving (Show, Eq, NFData, Lift, Generic) deriving (Show, Eq, NFData, Lift, Generic, Cacheable)
instance FromJSON GQLQueryWithText where instance FromJSON GQLQueryWithText where
parseJSON v@(String t) = GQLQueryWithText . (t, ) <$> parseJSON v parseJSON v@(String t) = GQLQueryWithText . (t, ) <$> parseJSON v
@ -55,6 +56,7 @@ data ListedQuery
, _lqQuery :: !GQLQueryWithText , _lqQuery :: !GQLQueryWithText
} deriving (Show, Eq, Lift, Generic) } deriving (Show, Eq, Lift, Generic)
instance NFData ListedQuery instance NFData ListedQuery
instance Cacheable ListedQuery
$(deriveJSON (aesonDrop 3 snakeCase) ''ListedQuery) $(deriveJSON (aesonDrop 3 snakeCase) ''ListedQuery)
type QueryList = [ListedQuery] type QueryList = [ListedQuery]
@ -62,7 +64,7 @@ type QueryList = [ListedQuery]
newtype CollectionDef newtype CollectionDef
= CollectionDef = CollectionDef
{ _cdQueries :: QueryList } { _cdQueries :: QueryList }
deriving (Show, Eq, Lift, Generic, NFData) deriving (Show, Eq, Lift, Generic, NFData, Cacheable)
$(deriveJSON (aesonDrop 3 snakeCase) ''CollectionDef) $(deriveJSON (aesonDrop 3 snakeCase) ''CollectionDef)
data CreateCollection data CreateCollection

5
server/src-lib/Hasura/RQL/Types/RemoteSchema.hs
View File

@ -12,6 +12,7 @@ import qualified Data.Text as T
import qualified Database.PG.Query as Q import qualified Database.PG.Query as Q
import qualified Network.URI.Extended as N import qualified Network.URI.Extended as N
import Hasura.Incremental (Cacheable)
import Hasura.RQL.DDL.Headers (HeaderConf (..)) import Hasura.RQL.DDL.Headers (HeaderConf (..))
import Hasura.RQL.Types.Error import Hasura.RQL.Types.Error
import Hasura.SQL.Types (DQuote) import Hasura.SQL.Types (DQuote)
@ -23,7 +24,7 @@ newtype RemoteSchemaName
{ unRemoteSchemaName :: NonEmptyText } { unRemoteSchemaName :: NonEmptyText }
deriving ( Show, Eq, Lift, Hashable, J.ToJSON, J.ToJSONKey deriving ( Show, Eq, Lift, Hashable, J.ToJSON, J.ToJSONKey
, J.FromJSON, Q.ToPrepArg, Q.FromCol, DQuote, NFData , J.FromJSON, Q.ToPrepArg, Q.FromCol, DQuote, NFData
, Generic, Arbitrary , Generic, Cacheable, Arbitrary
) )
data RemoteSchemaInfo data RemoteSchemaInfo
@ -47,6 +48,7 @@ data RemoteSchemaDef
, _rsdTimeoutSeconds :: !(Maybe Int) , _rsdTimeoutSeconds :: !(Maybe Int)
} deriving (Show, Eq, Lift, Generic) } deriving (Show, Eq, Lift, Generic)
instance NFData RemoteSchemaDef instance NFData RemoteSchemaDef
instance Cacheable RemoteSchemaDef
$(J.deriveToJSON (J.aesonDrop 4 J.snakeCase){J.omitNothingFields=True} ''RemoteSchemaDef) $(J.deriveToJSON (J.aesonDrop 4 J.snakeCase){J.omitNothingFields=True} ''RemoteSchemaDef)
instance J.FromJSON RemoteSchemaDef where instance J.FromJSON RemoteSchemaDef where
@ -65,6 +67,7 @@ data AddRemoteSchemaQuery
, _arsqComment :: !(Maybe Text) , _arsqComment :: !(Maybe Text)
} deriving (Show, Eq, Lift, Generic) } deriving (Show, Eq, Lift, Generic)
instance NFData AddRemoteSchemaQuery instance NFData AddRemoteSchemaQuery
instance Cacheable AddRemoteSchemaQuery
$(J.deriveJSON (J.aesonDrop 5 J.snakeCase) ''AddRemoteSchemaQuery) $(J.deriveJSON (J.aesonDrop 5 J.snakeCase) ''AddRemoteSchemaQuery)
newtype RemoteSchemaNameQuery newtype RemoteSchemaNameQuery

13
server/src-lib/Hasura/RQL/Types/SchemaCache.hs
View File

@ -113,6 +113,7 @@ module Hasura.RQL.Types.SchemaCache
import qualified Hasura.GraphQL.Context as GC import qualified Hasura.GraphQL.Context as GC
import Hasura.Db import Hasura.Db
import Hasura.Incremental (Cacheable)
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.Types.BoolExp import Hasura.RQL.Types.BoolExp
import Hasura.RQL.Types.Column import Hasura.RQL.Types.Column
@ -160,7 +161,8 @@ data FieldInfo
= FIColumn !PGColumnInfo = FIColumn !PGColumnInfo
| FIRelationship !RelInfo | FIRelationship !RelInfo
| FIComputedField !ComputedFieldInfo | FIComputedField !ComputedFieldInfo
deriving (Show, Eq) deriving (Show, Eq, Generic)
instance Cacheable FieldInfo
$(deriveToJSON $(deriveToJSON
defaultOptions { constructorTagModifier = snakeCase . drop 2 defaultOptions { constructorTagModifier = snakeCase . drop 2
, sumEncoding = TaggedObject "type" "detail" , sumEncoding = TaggedObject "type" "detail"
@ -211,6 +213,7 @@ data InsPermInfo
, ipiRequiredHeaders :: ![T.Text] , ipiRequiredHeaders :: ![T.Text]
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData InsPermInfo instance NFData InsPermInfo
instance Cacheable InsPermInfo
$(deriveToJSON (aesonDrop 3 snakeCase) ''InsPermInfo) $(deriveToJSON (aesonDrop 3 snakeCase) ''InsPermInfo)
data SelPermInfo data SelPermInfo
@ -224,6 +227,7 @@ data SelPermInfo
, spiRequiredHeaders :: ![T.Text] , spiRequiredHeaders :: ![T.Text]
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData SelPermInfo instance NFData SelPermInfo
instance Cacheable SelPermInfo
$(deriveToJSON (aesonDrop 3 snakeCase) ''SelPermInfo) $(deriveToJSON (aesonDrop 3 snakeCase) ''SelPermInfo)
data UpdPermInfo data UpdPermInfo
@ -235,6 +239,7 @@ data UpdPermInfo
, upiRequiredHeaders :: ![T.Text] , upiRequiredHeaders :: ![T.Text]
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData UpdPermInfo instance NFData UpdPermInfo
instance Cacheable UpdPermInfo
$(deriveToJSON (aesonDrop 3 snakeCase) ''UpdPermInfo) $(deriveToJSON (aesonDrop 3 snakeCase) ''UpdPermInfo)
data DelPermInfo data DelPermInfo
@ -244,6 +249,7 @@ data DelPermInfo
, dpiRequiredHeaders :: ![T.Text] , dpiRequiredHeaders :: ![T.Text]
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData DelPermInfo instance NFData DelPermInfo
instance Cacheable DelPermInfo
$(deriveToJSON (aesonDrop 3 snakeCase) ''DelPermInfo) $(deriveToJSON (aesonDrop 3 snakeCase) ''DelPermInfo)
emptyRolePermInfo :: RolePermInfo emptyRolePermInfo :: RolePermInfo
@ -283,6 +289,7 @@ data ViewInfo
, viIsInsertable :: !Bool , viIsInsertable :: !Bool
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData ViewInfo instance NFData ViewInfo
instance Cacheable ViewInfo
$(deriveJSON (aesonDrop 2 snakeCase) ''ViewInfo) $(deriveJSON (aesonDrop 2 snakeCase) ''ViewInfo)
isMutable :: (ViewInfo -> Bool) -> Maybe ViewInfo -> Bool isMutable :: (ViewInfo -> Bool) -> Maybe ViewInfo -> Bool
@ -302,6 +309,7 @@ data TableConfig
, _tcCustomColumnNames :: !CustomColumnNames , _tcCustomColumnNames :: !CustomColumnNames
} deriving (Show, Eq, Lift, Generic) } deriving (Show, Eq, Lift, Generic)
instance NFData TableConfig instance NFData TableConfig
instance Cacheable TableConfig
$(deriveToJSON (aesonDrop 3 snakeCase) ''TableConfig) $(deriveToJSON (aesonDrop 3 snakeCase) ''TableConfig)
emptyTableConfig :: TableConfig emptyTableConfig :: TableConfig
@ -329,7 +337,8 @@ data TableCoreInfoG field primaryKeyColumn
, _tciViewInfo :: !(Maybe ViewInfo) , _tciViewInfo :: !(Maybe ViewInfo)
, _tciEnumValues :: !(Maybe EnumValues) , _tciEnumValues :: !(Maybe EnumValues)
, _tciCustomConfig :: !TableConfig , _tciCustomConfig :: !TableConfig
} deriving (Show, Eq) } deriving (Show, Eq, Generic)
instance (Cacheable a, Cacheable b) => Cacheable (TableCoreInfoG a b)
$(deriveToJSON (aesonDrop 4 snakeCase) ''TableCoreInfoG) $(deriveToJSON (aesonDrop 4 snakeCase) ''TableCoreInfoG)
$(makeLenses ''TableCoreInfoG) $(makeLenses ''TableCoreInfoG)

46
server/src-lib/Hasura/SQL/DML.hs
View File

@ -1,5 +1,6 @@
module Hasura.SQL.DML where module Hasura.SQL.DML where
import Hasura.Incremental (Cacheable)
import Hasura.Prelude import Hasura.Prelude
import Hasura.SQL.Types import Hasura.SQL.Types
@ -33,6 +34,7 @@ data Select
, selOffset :: !(Maybe OffsetExp) , selOffset :: !(Maybe OffsetExp)
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance NFData Select instance NFData Select
instance Cacheable Select
mkSelect :: Select mkSelect :: Select
mkSelect = Select Nothing [] Nothing mkSelect = Select Nothing [] Nothing
@ -41,7 +43,7 @@ mkSelect = Select Nothing [] Nothing
newtype LimitExp newtype LimitExp
= LimitExp SQLExp = LimitExp SQLExp
deriving (Show, Eq, NFData, Data) deriving (Show, Eq, NFData, Data, Cacheable)
instance ToSQL LimitExp where instance ToSQL LimitExp where
toSQL (LimitExp se) = toSQL (LimitExp se) =
@ -49,7 +51,7 @@ instance ToSQL LimitExp where
newtype OffsetExp newtype OffsetExp
= OffsetExp SQLExp = OffsetExp SQLExp
deriving (Show, Eq, NFData, Data) deriving (Show, Eq, NFData, Data, Cacheable)
instance ToSQL OffsetExp where instance ToSQL OffsetExp where
toSQL (OffsetExp se) = toSQL (OffsetExp se) =
@ -57,7 +59,7 @@ instance ToSQL OffsetExp where
newtype OrderByExp newtype OrderByExp
= OrderByExp [OrderByItem] = OrderByExp [OrderByItem]
deriving (Show, Eq, NFData, Data) deriving (Show, Eq, NFData, Data, Cacheable)
data OrderByItem data OrderByItem
= OrderByItem = OrderByItem
@ -66,6 +68,7 @@ data OrderByItem
, oNulls :: !(Maybe NullsOrder) , oNulls :: !(Maybe NullsOrder)
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance NFData OrderByItem instance NFData OrderByItem
instance Cacheable OrderByItem
instance ToSQL OrderByItem where instance ToSQL OrderByItem where
toSQL (OrderByItem e ot no) = toSQL (OrderByItem e ot no) =
@ -74,6 +77,7 @@ instance ToSQL OrderByItem where
data OrderType = OTAsc | OTDesc data OrderType = OTAsc | OTDesc
deriving (Show, Eq, Lift, Generic, Data) deriving (Show, Eq, Lift, Generic, Data)
instance NFData OrderType instance NFData OrderType
instance Cacheable OrderType
instance ToSQL OrderType where instance ToSQL OrderType where
toSQL OTAsc = "ASC" toSQL OTAsc = "ASC"
@ -84,6 +88,7 @@ data NullsOrder
| NLast | NLast
deriving (Show, Eq, Lift, Generic, Data) deriving (Show, Eq, Lift, Generic, Data)
instance NFData NullsOrder instance NFData NullsOrder
instance Cacheable NullsOrder
instance ToSQL NullsOrder where instance ToSQL NullsOrder where
toSQL NFirst = "NULLS FIRST" toSQL NFirst = "NULLS FIRST"
@ -95,7 +100,7 @@ instance ToSQL OrderByExp where
newtype GroupByExp newtype GroupByExp
= GroupByExp [SQLExp] = GroupByExp [SQLExp]
deriving (Show, Eq, NFData, Data) deriving (Show, Eq, NFData, Data, Cacheable)
instance ToSQL GroupByExp where instance ToSQL GroupByExp where
toSQL (GroupByExp idens) = toSQL (GroupByExp idens) =
@ -103,7 +108,7 @@ instance ToSQL GroupByExp where
newtype FromExp newtype FromExp
= FromExp [FromItem] = FromExp [FromItem]
deriving (Show, Eq, NFData, Data) deriving (Show, Eq, NFData, Data, Cacheable)
instance ToSQL FromExp where instance ToSQL FromExp where
toSQL (FromExp items) = toSQL (FromExp items) =
@ -143,7 +148,7 @@ mkRowExp extrs = let
newtype HavingExp newtype HavingExp
= HavingExp BoolExp = HavingExp BoolExp
deriving (Show, Eq, NFData, Data) deriving (Show, Eq, NFData, Data, Cacheable)
instance ToSQL HavingExp where instance ToSQL HavingExp where
toSQL (HavingExp be) = toSQL (HavingExp be) =
@ -151,7 +156,7 @@ instance ToSQL HavingExp where
newtype WhereFrag newtype WhereFrag
= WhereFrag { getWFBoolExp :: BoolExp } = WhereFrag { getWFBoolExp :: BoolExp }
deriving (Show, Eq, NFData, Data) deriving (Show, Eq, NFData, Data, Cacheable)
instance ToSQL WhereFrag where instance ToSQL WhereFrag where
toSQL (WhereFrag be) = toSQL (WhereFrag be) =
@ -182,6 +187,7 @@ data Qual
| QualVar !T.Text | QualVar !T.Text
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData Qual instance NFData Qual
instance Cacheable Qual
mkQual :: QualifiedTable -> Qual mkQual :: QualifiedTable -> Qual
mkQual = QualTable mkQual = QualTable
@ -198,6 +204,7 @@ data QIden
= QIden !Qual !Iden = QIden !Qual !Iden
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData QIden instance NFData QIden
instance Cacheable QIden
instance ToSQL QIden where instance ToSQL QIden where
toSQL (QIden qual iden) = toSQL (QIden qual iden) =
@ -205,7 +212,7 @@ instance ToSQL QIden where
newtype SQLOp newtype SQLOp
= SQLOp {sqlOpTxt :: T.Text} = SQLOp {sqlOpTxt :: T.Text}
deriving (Show, Eq, NFData, Data) deriving (Show, Eq, NFData, Data, Cacheable)
incOp :: SQLOp incOp :: SQLOp
incOp = SQLOp "+" incOp = SQLOp "+"
@ -227,7 +234,7 @@ jsonbDeleteAtPathOp = SQLOp "#-"
newtype TypeAnn newtype TypeAnn
= TypeAnn { unTypeAnn :: T.Text } = TypeAnn { unTypeAnn :: T.Text }
deriving (Show, Eq, NFData, Data) deriving (Show, Eq, NFData, Data, Cacheable)
mkTypeAnn :: PGType PGScalarType -> TypeAnn mkTypeAnn :: PGType PGScalarType -> TypeAnn
mkTypeAnn = TypeAnn . toSQLTxt mkTypeAnn = TypeAnn . toSQLTxt
@ -253,6 +260,7 @@ data CountType
| CTDistinct ![PGCol] | CTDistinct ![PGCol]
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData CountType instance NFData CountType
instance Cacheable CountType
instance ToSQL CountType where instance ToSQL CountType where
toSQL CTStar = "*" toSQL CTStar = "*"
@ -263,7 +271,7 @@ instance ToSQL CountType where
newtype TupleExp newtype TupleExp
= TupleExp [SQLExp] = TupleExp [SQLExp]
deriving (Show, Eq, NFData, Data) deriving (Show, Eq, NFData, Data, Cacheable)
instance ToSQL TupleExp where instance ToSQL TupleExp where
toSQL (TupleExp exps) = toSQL (TupleExp exps) =
@ -293,6 +301,7 @@ data SQLExp
| SEFunction !FunctionExp | SEFunction !FunctionExp
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData SQLExp instance NFData SQLExp
instance Cacheable SQLExp
withTyAnn :: PGScalarType -> SQLExp -> SQLExp withTyAnn :: PGScalarType -> SQLExp -> SQLExp
withTyAnn colTy v = SETyAnn v . mkTypeAnn $ PGTypeScalar colTy withTyAnn colTy v = SETyAnn v . mkTypeAnn $ PGTypeScalar colTy
@ -302,7 +311,7 @@ instance J.ToJSON SQLExp where
newtype Alias newtype Alias
= Alias { getAlias :: Iden } = Alias { getAlias :: Iden }
deriving (Show, Eq, NFData, Hashable, Data) deriving (Show, Eq, NFData, Hashable, Data, Cacheable)
instance IsIden Alias where instance IsIden Alias where
toIden (Alias iden) = iden toIden (Alias iden) = iden
@ -365,6 +374,7 @@ intToSQLExp =
data Extractor = Extractor !SQLExp !(Maybe Alias) data Extractor = Extractor !SQLExp !(Maybe Alias)
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData Extractor instance NFData Extractor
instance Cacheable Extractor
mkSQLOpExp mkSQLOpExp
:: SQLOp :: SQLOp
@ -411,6 +421,7 @@ data DistinctExpr
| DistinctOn ![SQLExp] | DistinctOn ![SQLExp]
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData DistinctExpr instance NFData DistinctExpr
instance Cacheable DistinctExpr
instance ToSQL DistinctExpr where instance ToSQL DistinctExpr where
toSQL DistinctSimple = "DISTINCT" toSQL DistinctSimple = "DISTINCT"
@ -423,6 +434,7 @@ data FunctionArgs
, fasNamed :: !(HM.HashMap Text SQLExp) , fasNamed :: !(HM.HashMap Text SQLExp)
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance NFData FunctionArgs instance NFData FunctionArgs
instance Cacheable FunctionArgs
instance ToSQL FunctionArgs where instance ToSQL FunctionArgs where
toSQL (FunctionArgs positionalArgs namedArgsMap) = toSQL (FunctionArgs positionalArgs namedArgsMap) =
@ -437,6 +449,7 @@ data FunctionExp
, feAlias :: !(Maybe Alias) , feAlias :: !(Maybe Alias)
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance NFData FunctionExp instance NFData FunctionExp
instance Cacheable FunctionExp
instance ToSQL FunctionExp where instance ToSQL FunctionExp where
toSQL (FunctionExp qf args alsM) = toSQL (FunctionExp qf args alsM) =
@ -452,6 +465,7 @@ data FromItem
| FIJoin !JoinExpr | FIJoin !JoinExpr
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData FromItem instance NFData FromItem
instance Cacheable FromItem
mkSelFromItem :: Select -> Alias -> FromItem mkSelFromItem :: Select -> Alias -> FromItem
mkSelFromItem = FISelect (Lateral False) mkSelFromItem = FISelect (Lateral False)
@ -481,7 +495,7 @@ instance ToSQL FromItem where
toSQL je toSQL je
newtype Lateral = Lateral Bool newtype Lateral = Lateral Bool
deriving (Show, Eq, Data, NFData) deriving (Show, Eq, Data, NFData, Cacheable)
instance ToSQL Lateral where instance ToSQL Lateral where
toSQL (Lateral True) = "LATERAL" toSQL (Lateral True) = "LATERAL"
@ -495,6 +509,7 @@ data JoinExpr
, tjeJC :: !JoinCond , tjeJC :: !JoinCond
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance NFData JoinExpr instance NFData JoinExpr
instance Cacheable JoinExpr
instance ToSQL JoinExpr where instance ToSQL JoinExpr where
toSQL je = toSQL je =
@ -510,6 +525,7 @@ data JoinType
| FullOuter | FullOuter
deriving (Eq, Show, Generic, Data) deriving (Eq, Show, Generic, Data)
instance NFData JoinType instance NFData JoinType
instance Cacheable JoinType
instance ToSQL JoinType where instance ToSQL JoinType where
toSQL Inner = "INNER JOIN" toSQL Inner = "INNER JOIN"
@ -522,6 +538,7 @@ data JoinCond
| JoinUsing ![PGCol] | JoinUsing ![PGCol]
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData JoinCond instance NFData JoinCond
instance Cacheable JoinCond
instance ToSQL JoinCond where instance ToSQL JoinCond where
toSQL (JoinOn be) = toSQL (JoinOn be) =
@ -544,6 +561,7 @@ data BoolExp
| BEExp !SQLExp | BEExp !SQLExp
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData BoolExp instance NFData BoolExp
instance Cacheable BoolExp
-- removes extraneous 'AND true's -- removes extraneous 'AND true's
simplifyBoolExp :: BoolExp -> BoolExp simplifyBoolExp :: BoolExp -> BoolExp
@ -598,6 +616,7 @@ instance ToSQL BoolExp where
data BinOp = AndOp | OrOp data BinOp = AndOp | OrOp
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData BinOp instance NFData BinOp
instance Cacheable BinOp
instance ToSQL BinOp where instance ToSQL BinOp where
toSQL AndOp = "AND" toSQL AndOp = "AND"
@ -625,6 +644,7 @@ data CompareOp
| SHasKeysAll | SHasKeysAll
deriving (Eq, Generic, Data) deriving (Eq, Generic, Data)
instance NFData CompareOp instance NFData CompareOp
instance Cacheable CompareOp
instance Show CompareOp where instance Show CompareOp where
show = \case show = \case
@ -768,7 +788,7 @@ instance ToSQL SQLConflict where
newtype ValuesExp newtype ValuesExp
= ValuesExp [TupleExp] = ValuesExp [TupleExp]
deriving (Show, Eq, Data, NFData) deriving (Show, Eq, Data, NFData, Cacheable)
instance ToSQL ValuesExp where instance ToSQL ValuesExp where
toSQL (ValuesExp tuples) = toSQL (ValuesExp tuples) =

22
server/src-lib/Hasura/SQL/Types.hs
View File

@ -82,6 +82,8 @@ import qualified Language.GraphQL.Draft.Syntax as G
import qualified PostgreSQL.Binary.Decoding as PD import qualified PostgreSQL.Binary.Decoding as PD
import qualified Text.Builder as TB import qualified Text.Builder as TB
import Hasura.Incremental (Cacheable)
class ToSQL a where class ToSQL a where
toSQL :: a -> TB.Builder toSQL :: a -> TB.Builder
@ -100,7 +102,7 @@ infixr 6 <+>
newtype Iden newtype Iden
= Iden { getIdenTxt :: T.Text } = Iden { getIdenTxt :: T.Text }
deriving (Show, Eq, NFData, FromJSON, ToJSON, Hashable, Semigroup, Data) deriving (Show, Eq, NFData, FromJSON, ToJSON, Hashable, Semigroup, Data, Cacheable)
instance ToSQL Iden where instance ToSQL Iden where
toSQL (Iden t) = toSQL (Iden t) =
@ -160,7 +162,7 @@ class ToTxt a where
newtype TableName newtype TableName
= TableName { getTableTxt :: T.Text } = TableName { getTableTxt :: T.Text }
deriving (Show, Eq, FromJSON, ToJSON, Hashable, Q.ToPrepArg, Q.FromCol, Lift, Data, Generic, Arbitrary, NFData) deriving (Show, Eq, FromJSON, ToJSON, Hashable, Q.ToPrepArg, Q.FromCol, Lift, Data, Generic, Arbitrary, NFData, Cacheable)
instance IsIden TableName where instance IsIden TableName where
toIden (TableName t) = Iden t toIden (TableName t) = Iden t
@ -204,7 +206,7 @@ isView _ = False
newtype ConstraintName newtype ConstraintName
= ConstraintName { getConstraintTxt :: T.Text } = ConstraintName { getConstraintTxt :: T.Text }
deriving (Show, Eq, DQuote, FromJSON, ToJSON, Q.ToPrepArg, Q.FromCol, Hashable, Lift, NFData) deriving (Show, Eq, DQuote, FromJSON, ToJSON, Q.ToPrepArg, Q.FromCol, Hashable, Lift, NFData, Cacheable)
instance IsIden ConstraintName where instance IsIden ConstraintName where
toIden (ConstraintName t) = Iden t toIden (ConstraintName t) = Iden t
@ -214,7 +216,7 @@ instance ToSQL ConstraintName where
newtype FunctionName newtype FunctionName
= FunctionName { getFunctionTxt :: T.Text } = FunctionName { getFunctionTxt :: T.Text }
deriving (Show, Eq, Ord, FromJSON, ToJSON, Q.ToPrepArg, Q.FromCol, Hashable, Lift, Data, Generic, Arbitrary, NFData) deriving (Show, Eq, Ord, FromJSON, ToJSON, Q.ToPrepArg, Q.FromCol, Hashable, Lift, Data, Generic, Arbitrary, NFData, Cacheable)
instance IsIden FunctionName where instance IsIden FunctionName where
toIden (FunctionName t) = Iden t toIden (FunctionName t) = Iden t
@ -230,7 +232,7 @@ instance ToTxt FunctionName where
newtype SchemaName newtype SchemaName
= SchemaName { getSchemaTxt :: T.Text } = SchemaName { getSchemaTxt :: T.Text }
deriving (Show, Eq, Ord, FromJSON, ToJSON, Hashable, Q.ToPrepArg, Q.FromCol, Lift, Data, Generic, Arbitrary, NFData) deriving (Show, Eq, Ord, FromJSON, ToJSON, Hashable, Q.ToPrepArg, Q.FromCol, Lift, Data, Generic, Arbitrary, NFData, Cacheable)
publicSchema :: SchemaName publicSchema :: SchemaName
publicSchema = SchemaName "public" publicSchema = SchemaName "public"
@ -250,6 +252,7 @@ data QualifiedObject a
, qName :: !a , qName :: !a
} deriving (Show, Eq, Functor, Ord, Generic, Lift, Data) } deriving (Show, Eq, Functor, Ord, Generic, Lift, Data)
instance (NFData a) => NFData (QualifiedObject a) instance (NFData a) => NFData (QualifiedObject a)
instance (Cacheable a) => Cacheable (QualifiedObject a)
instance (FromJSON a) => FromJSON (QualifiedObject a) where instance (FromJSON a) => FromJSON (QualifiedObject a) where
parseJSON v@(String _) = parseJSON v@(String _) =
@ -299,11 +302,11 @@ type QualifiedFunction = QualifiedObject FunctionName
newtype PGDescription newtype PGDescription
= PGDescription { getPGDescription :: T.Text } = PGDescription { getPGDescription :: T.Text }
deriving (Show, Eq, FromJSON, ToJSON, Q.FromCol, NFData) deriving (Show, Eq, FromJSON, ToJSON, Q.FromCol, NFData, Cacheable)
newtype PGCol newtype PGCol
= PGCol { getPGColTxt :: T.Text } = PGCol { getPGColTxt :: T.Text }
deriving (Show, Eq, Ord, FromJSON, ToJSON, Hashable, Q.ToPrepArg, Q.FromCol, ToJSONKey, FromJSONKey, Lift, Data, Generic, Arbitrary, NFData) deriving (Show, Eq, Ord, FromJSON, ToJSON, Hashable, Q.ToPrepArg, Q.FromCol, ToJSONKey, FromJSONKey, Lift, Data, Generic, Arbitrary, NFData, Cacheable)
instance IsIden PGCol where instance IsIden PGCol where
toIden (PGCol t) = Iden t toIden (PGCol t) = Iden t
@ -342,8 +345,8 @@ data PGScalarType
| PGUnknown !T.Text | PGUnknown !T.Text
deriving (Show, Eq, Lift, Generic, Data) deriving (Show, Eq, Lift, Generic, Data)
instance NFData PGScalarType instance NFData PGScalarType
instance Hashable PGScalarType instance Hashable PGScalarType
instance Cacheable PGScalarType
instance ToSQL PGScalarType where instance ToSQL PGScalarType where
toSQL = \case toSQL = \case
@ -524,6 +527,7 @@ data PGType a
| PGTypeArray !a | PGTypeArray !a
deriving (Show, Eq, Generic, Data, Functor) deriving (Show, Eq, Generic, Data, Functor)
instance (NFData a) => NFData (PGType a) instance (NFData a) => NFData (PGType a)
instance (Cacheable a) => Cacheable (PGType a)
$(deriveJSON defaultOptions{constructorTagModifier = drop 6} ''PGType) $(deriveJSON defaultOptions{constructorTagModifier = drop 6} ''PGType)
instance (ToSQL a) => ToSQL (PGType a) where instance (ToSQL a) => ToSQL (PGType a) where
@ -542,6 +546,7 @@ data PGTypeKind
| PGKindUnknown !T.Text | PGKindUnknown !T.Text
deriving (Show, Eq, Generic) deriving (Show, Eq, Generic)
instance NFData PGTypeKind instance NFData PGTypeKind
instance Cacheable PGTypeKind
instance FromJSON PGTypeKind where instance FromJSON PGTypeKind where
parseJSON = withText "postgresTypeKind" $ parseJSON = withText "postgresTypeKind" $
@ -571,6 +576,7 @@ data QualifiedPGType
, _qptType :: !PGTypeKind , _qptType :: !PGTypeKind
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData QualifiedPGType instance NFData QualifiedPGType
instance Cacheable QualifiedPGType
$(deriveJSON (aesonDrop 4 snakeCase) ''QualifiedPGType) $(deriveJSON (aesonDrop 4 snakeCase) ''QualifiedPGType)
isBaseType :: QualifiedPGType -> Bool isBaseType :: QualifiedPGType -> Bool

15
server/src-test/Hasura/IncrementalSpec.hs
View File

@ -8,6 +8,7 @@ import qualified Data.HashMap.Strict as M
import qualified Data.HashSet as S import qualified Data.HashSet as S
import Control.Arrow.Extended import Control.Arrow.Extended
import Control.Monad.Unique
import Test.Hspec import Test.Hspec
import qualified Hasura.Incremental as Inc import qualified Hasura.Incremental as Inc
@ -16,23 +17,23 @@ spec :: Spec
spec = do spec = do
describe "cache" $ do describe "cache" $ do
it "skips re-running rules if the input didn’t change" $ do it "skips re-running rules if the input didn’t change" $ do
let add1 :: MonadState Integer m => m () let add1 :: (MonadState Integer m) => m ()
add1 = modify' (+1) add1 = modify' (+1)
rule = proc (a, b) -> do rule = proc (a, b) -> do
Inc.cache $ arrM (\_ -> add1) -< a Inc.cache $ arrM (\_ -> add1) -< a
Inc.cache $ arrM (\_ -> add1 *> add1) -< b Inc.cache $ arrM (\_ -> add1 *> add1) -< b
let (result1, state1) = runState (Inc.build rule (False, False)) 0 (result1, state1) <- runStateT (Inc.build rule (False, False)) 0
state1 `shouldBe` 3 state1 `shouldBe` 3
let (result2, state2) = runState (Inc.rebuild result1 (True, False)) 0 (result2, state2) <- runStateT (Inc.rebuild result1 (True, False)) 0
state2 `shouldBe` 1 state2 `shouldBe` 1
let (_, state3) = runState (Inc.rebuild result2 (True, True)) 0 (_, state3) <- runStateT (Inc.rebuild result2 (True, True)) 0
state3 `shouldBe` 2 state3 `shouldBe` 2
describe "keyed" $ do describe "keyed" $ do
it "preserves incrementalization when entries don’t change" $ do it "preserves incrementalization when entries don’t change" $ do
let rule :: MonadWriter (S.HashSet (String, Integer)) m let rule :: (MonadWriter (S.HashSet (String, Integer)) m, MonadUnique m)
=> Inc.Rule m (M.HashMap String Integer) (M.HashMap String Integer) => Inc.Rule m (M.HashMap String Integer) (M.HashMap String Integer)
rule = proc m -> rule = proc m ->
(| Inc.keyed (\k v -> do (| Inc.keyed (\k v -> do
@ -40,9 +41,9 @@ spec = do
returnA -< v * 2) returnA -< v * 2)
|) m |) m
let (result1, log1) = runWriter . Inc.build rule $ M.fromList [("a", 1), ("b", 2)] (result1, log1) <- runWriterT . Inc.build rule $ M.fromList [("a", 1), ("b", 2)]
Inc.result result1 `shouldBe` M.fromList [("a", 2), ("b", 4)] Inc.result result1 `shouldBe` M.fromList [("a", 2), ("b", 4)]
log1 `shouldBe` S.fromList [("a", 1), ("b", 2)] log1 `shouldBe` S.fromList [("a", 1), ("b", 2)]
let (result2, log2) = runWriter . Inc.rebuild result1 $ M.fromList [("a", 1), ("b", 3), ("c", 4)] (result2, log2) <- runWriterT . Inc.rebuild result1 $ M.fromList [("a", 1), ("b", 3), ("c", 4)]
Inc.result result2 `shouldBe` M.fromList [("a", 2), ("b", 6), ("c", 8)] Inc.result result2 `shouldBe` M.fromList [("a", 2), ("b", 6), ("c", 8)]
log2 `shouldBe` S.fromList [("b", 3), ("c", 4)] log2 `shouldBe` S.fromList [("b", 3), ("c", 4)]