graphql-engine/server/src-lib/Hasura/GraphQL/Resolve/Context.hs
2019-03-25 23:55:25 +05:30

178 lines
4.2 KiB
Haskell

module Hasura.GraphQL.Resolve.Context
( FieldMap
, RelationInfoMap
, FuncArgItem(..)
, OrdByCtx
, OrdByItemMap
, OrdByItem(..)
, FuncArgSeq
, PGColArgMap
, UpdPermForIns(..)
, InsCtx(..)
, InsCtxMap
, RespTx
, LazyRespTx
, AnnPGVal(..)
, PrepFn
, InsertTxConflictCtx(..)
, getFldInfo
, getPGColInfo
, getArg
, withArg
, withArgM
, nameAsPath
, PrepArgs
, Convert
, runConvert
, withPrepArgs
, prepare
, prepareColVal
, txtConverter
, module Hasura.GraphQL.Utils
) where
import Data.Has
import Hasura.Prelude
import qualified Data.Aeson as J
import qualified Data.Aeson.Casing as J
import qualified Data.Aeson.TH as J
import qualified Data.HashMap.Strict as Map
import qualified Data.Sequence as Seq
import qualified Database.PG.Query as Q
import qualified Language.GraphQL.Draft.Syntax as G
import Hasura.GraphQL.Resolve.ContextTypes
import Hasura.EncJSON
import Hasura.GraphQL.Utils
import Hasura.GraphQL.Validate.Field
import Hasura.GraphQL.Validate.Types
import Hasura.RQL.Types
import Hasura.SQL.Types
import Hasura.SQL.Value
import qualified Hasura.SQL.DML as S
data InsResp
= InsResp
{ _irAffectedRows :: !Int
, _irResponse :: !(Maybe J.Object)
} deriving (Show, Eq)
$(J.deriveJSON (J.aesonDrop 3 J.snakeCase) ''InsResp)
type RespTx = Q.TxE QErr EncJSON
type LazyRespTx = LazyTx QErr EncJSON
type PrepFn m = AnnPGVal -> m S.SQLExp
data AnnPGVal
= AnnPGVal
{ _apvVariable :: !(Maybe G.Variable)
, _apvIsNullable :: !Bool
, _apvType :: !PGColType
, _apvValue :: !PGColValue
} deriving (Show, Eq)
getFldInfo
:: (MonadError QErr m, MonadReader r m, Has FieldMap r)
=> G.NamedType -> G.Name
-> m (Either PGColInfo (RelInfo, Bool, AnnBoolExpSQL, Maybe Int))
getFldInfo nt n = do
fldMap <- asks getter
onNothing (Map.lookup (nt,n) fldMap) $
throw500 $ "could not lookup " <> showName n <> " in " <>
showNamedTy nt
getPGColInfo
:: (MonadError QErr m, MonadReader r m, Has FieldMap r)
=> G.NamedType -> G.Name -> m PGColInfo
getPGColInfo nt n = do
fldInfo <- getFldInfo nt n
case fldInfo of
Left pgColInfo -> return pgColInfo
Right _ -> throw500 $
"found relinfo when expecting pgcolinfo for "
<> showNamedTy nt <> ":" <> showName n
getArg
:: (MonadError QErr m)
=> ArgsMap
-> G.Name
-> m AnnInpVal
getArg args arg =
onNothing (Map.lookup arg args) $
throw500 $ "missing argument: " <> showName arg
prependArgsInPath
:: (MonadError QErr m)
=> m a -> m a
prependArgsInPath = withPathK "args"
nameAsPath
:: (MonadError QErr m)
=> G.Name -> m a -> m a
nameAsPath name = withPathK (G.unName name)
withArg
:: (MonadError QErr m)
=> ArgsMap
-> G.Name
-> (AnnInpVal -> m a)
-> m a
withArg args arg f = prependArgsInPath $ nameAsPath arg $
getArg args arg >>= f
withArgM
:: (MonadError QErr m)
=> ArgsMap
-> G.Name
-> (AnnInpVal -> m a)
-> m (Maybe a)
withArgM args arg f = prependArgsInPath $ nameAsPath arg $
mapM f $ handleNull =<< Map.lookup arg args
where
handleNull v = bool (Just v) Nothing $
hasNullVal $ _aivValue v
type PrepArgs = Seq.Seq Q.PrepArg
type Convert =
(ReaderT ( FieldMap
, OrdByCtx
, InsCtxMap
, SQLGenCtx
) (Except QErr)
)
prepare
:: (MonadState PrepArgs m) => PrepFn m
prepare (AnnPGVal _ _ colTy colVal) =
prepareColVal colTy colVal
prepareColVal
:: (MonadState PrepArgs m)
=> PGColType -> PGColValue -> m S.SQLExp
prepareColVal colTy colVal = do
preparedArgs <- get
put (preparedArgs Seq.|> binEncoder colVal)
return $ toPrepParam (Seq.length preparedArgs + 1) colTy
txtConverter :: Monad m => PrepFn m
txtConverter (AnnPGVal _ _ a b) =
return $ toTxtValue a b
withPrepArgs :: StateT PrepArgs Convert a -> Convert (a, PrepArgs)
withPrepArgs m = runStateT m Seq.empty
runConvert
:: (MonadError QErr m)
=> (FieldMap, OrdByCtx, InsCtxMap, SQLGenCtx)
-> Convert a
-> m a
runConvert ctx m =
either throwError return $
runExcept $ runReaderT m ctx