From da8d1b166efccc1a28a4a74efb3fff7c4c29ba54 Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Wed, 9 Jan 2019 18:50:49 +0530 Subject: [PATCH] use bytestring builder to represent encoded json --- server/graphql-engine.cabal | 8 +- server/src-exec/Ops.hs | 4 +- server/src-lib/Hasura/EncJSON.hs | 79 ++++++++++++++++++ server/src-lib/Hasura/GraphQL/Explain.hs | 7 +- server/src-lib/Hasura/GraphQL/Resolve.hs | 31 ++++--- .../src-lib/Hasura/GraphQL/Resolve/Context.hs | 6 +- .../src-lib/Hasura/GraphQL/Resolve/Insert.hs | 28 ++++--- .../Hasura/GraphQL/Resolve/LiveQuery.hs | 8 +- .../Hasura/GraphQL/Resolve/Mutation.hs | 9 +- .../src-lib/Hasura/GraphQL/Transport/HTTP.hs | 13 +-- .../Hasura/GraphQL/Transport/HTTP/Protocol.hs | 40 +++------ .../Hasura/GraphQL/Transport/WebSocket.hs | 7 +- .../GraphQL/Transport/WebSocket/Protocol.hs | 18 ++-- server/src-lib/Hasura/RQL/DDL/Metadata.hs | 19 +++-- server/src-lib/Hasura/RQL/DDL/Permission.hs | 5 +- .../Hasura/RQL/DDL/Permission/Internal.hs | 5 +- .../src-lib/Hasura/RQL/DDL/QueryTemplate.hs | 11 +-- server/src-lib/Hasura/RQL/DDL/Relationship.hs | 18 ++-- .../Hasura/RQL/DDL/Relationship/Rename.hs | 3 +- server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs | 10 +-- .../src-lib/Hasura/RQL/DDL/Schema/Function.hs | 7 +- server/src-lib/Hasura/RQL/DDL/Schema/Table.hs | 34 ++++---- server/src-lib/Hasura/RQL/DDL/Subscribe.hs | 11 +-- server/src-lib/Hasura/RQL/DML/Count.hs | 7 +- server/src-lib/Hasura/RQL/DML/Delete.hs | 5 +- server/src-lib/Hasura/RQL/DML/Insert.hs | 7 +- server/src-lib/Hasura/RQL/DML/Mutation.hs | 11 +-- .../src-lib/Hasura/RQL/DML/QueryTemplate.hs | 13 +-- server/src-lib/Hasura/RQL/DML/Returning.hs | 9 -- server/src-lib/Hasura/RQL/DML/Select.hs | 18 ++-- server/src-lib/Hasura/RQL/DML/Update.hs | 5 +- server/src-lib/Hasura/RQL/Types.hs | 7 +- server/src-lib/Hasura/RQL/Types/Error.hs | 5 -- server/src-lib/Hasura/Server/App.hs | 17 ++-- server/src-lib/Hasura/Server/Query.hs | 83 +++++++++---------- 35 files changed, 315 insertions(+), 253 deletions(-) create mode 100644 server/src-lib/Hasura/EncJSON.hs diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 76e0f1830a2d3..105934c3c0c83 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -138,7 +138,11 @@ library -- pretty printer , ansi-wl-pprint - exposed-modules: Hasura.Server.App + exposed-modules: Hasura.Prelude + , Hasura.Logging + , Hasura.EncJSON + + , Hasura.Server.App , Hasura.Server.Auth , Hasura.Server.Auth.JWT , Hasura.Server.Init @@ -234,8 +238,6 @@ library , Hasura.SQL.GeoJSON , Hasura.SQL.Time , Hasura.SQL.Rewrite - , Hasura.Prelude - , Hasura.Logging , Network.URI.Extended , Ops , Migrate diff --git a/server/src-exec/Ops.hs b/server/src-exec/Ops.hs index 150bd9474e070..0a57ba10a5a58 100644 --- a/server/src-exec/Ops.hs +++ b/server/src-exec/Ops.hs @@ -9,6 +9,7 @@ import Language.Haskell.TH.Syntax (Q, TExp, unTypeQ) import Migrate (curCatalogVer) import Hasura.Prelude +import Hasura.EncJSON import Hasura.RQL.DDL.Schema.Table import Hasura.RQL.Types import Hasura.Server.Query @@ -140,8 +141,7 @@ execQuery queryBs = do Just jVal -> decodeValue jVal Nothing -> throw400 InvalidJSON "invalid json" buildSchemaCache - runQueryM query - + encJToLBS <$> runQueryM query -- error messages pgcryptoReqdMsg :: T.Text diff --git a/server/src-lib/Hasura/EncJSON.hs b/server/src-lib/Hasura/EncJSON.hs new file mode 100644 index 0000000000000..0d8a10ca9beec --- /dev/null +++ b/server/src-lib/Hasura/EncJSON.hs @@ -0,0 +1,79 @@ +-- A module for representing encoded json +-- and efficient operations to construct them + +module Hasura.EncJSON + ( EncJSON + , encJToLBS + , encJFromBuilder + , encJFromJValue + , encJFromChar + , encJFromText + , encJFromBS + , encJFromLBS + , encJFromList + , encJFromAssocList + ) where + +import Hasura.Prelude + +import qualified Data.Aeson as J +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Encoding as TE + +-- encoded json +-- TODO: can be improved with gadts capturing bytestring, lazybytestring +-- and builder +newtype EncJSON + = EncJSON { unEncJSON :: BB.Builder } + deriving (Semigroup, Monoid, IsString) + +encJToLBS :: EncJSON -> BL.ByteString +encJToLBS = BB.toLazyByteString . unEncJSON +{-# INLINE encJToLBS #-} + +encJFromBuilder :: BB.Builder -> EncJSON +encJFromBuilder = EncJSON +{-# INLINE encJFromBuilder #-} + +encJFromBS :: B.ByteString -> EncJSON +encJFromBS = EncJSON . BB.byteString +{-# INLINE encJFromBS #-} + +encJFromLBS :: BL.ByteString -> EncJSON +encJFromLBS = EncJSON . BB.lazyByteString +{-# INLINE encJFromLBS #-} + +encJFromJValue :: J.ToJSON a => a -> EncJSON +encJFromJValue = encJFromBuilder . J.fromEncoding . J.toEncoding +{-# INLINE encJFromJValue #-} + +encJFromChar :: Char -> EncJSON +encJFromChar = EncJSON . BB.charUtf8 +{-# INLINE encJFromChar #-} + +encJFromText :: Text -> EncJSON +encJFromText = encJFromBS . TE.encodeUtf8 +{-# INLINE encJFromText #-} + +encJFromList :: [EncJSON] -> EncJSON +encJFromList = \case + [] -> "[]" + x:xs -> encJFromChar '[' + <> x + <> foldr go (encJFromChar ']') xs + where go v b = encJFromChar ',' <> v <> b + +-- from association list +encJFromAssocList :: [(Text, EncJSON)] -> EncJSON +encJFromAssocList = \case + [] -> "{}" + x:xs -> encJFromChar '{' + <> builder' x + <> foldr go (encJFromChar '}') xs + where + go v b = encJFromChar ',' <> builder' v <> b + -- builds "key":value from (key,value) + builder' (t, v) = + encJFromChar '"' <> encJFromText t <> encJFromText "\":" <> v diff --git a/server/src-lib/Hasura/GraphQL/Explain.hs b/server/src-lib/Hasura/GraphQL/Explain.hs index d8674ddb724e5..7ef3fe35a4d7c 100644 --- a/server/src-lib/Hasura/GraphQL/Explain.hs +++ b/server/src-lib/Hasura/GraphQL/Explain.hs @@ -8,13 +8,13 @@ import Data.Has (getter) import qualified Data.Aeson as J import qualified Data.Aeson.Casing as J import qualified Data.Aeson.TH as J -import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as Map import qualified Database.PG.Query as Q import qualified Language.GraphQL.Draft.Syntax as G import qualified Text.Builder as TB import Hasura.GraphQL.Context +import Hasura.EncJSON import Hasura.GraphQL.Resolve.Context import Hasura.GraphQL.Schema import Hasura.GraphQL.Validate.Field @@ -126,7 +126,7 @@ explainGQLQuery -> SchemaCache -> SQLGenCtx -> GQLExplain - -> m BL.ByteString + -> m EncJSON explainGQLQuery pool iso sc sqlGenCtx (GQLExplain query userVarsRaw)= do (gCtx, _) <- flip runStateT sc $ getGCtx (userRole userInfo) gCtxMap queryParts <- runReaderT (GV.getQueryParts query) gCtx @@ -140,7 +140,8 @@ explainGQLQuery pool iso sc sqlGenCtx (GQLExplain query userVarsRaw)= do throw400 InvalidParams "only queries can be explained" let tx = mapM (explainField userInfo gCtx sqlGenCtx) (toList selSet) plans <- liftIO (runExceptT $ runTx tx) >>= liftEither - return $ J.encode plans + return $ encJFromJValue plans + where gCtxMap = scGCtxMap sc usrVars = mkUserVars $ maybe [] Map.toList userVarsRaw diff --git a/server/src-lib/Hasura/GraphQL/Resolve.hs b/server/src-lib/Hasura/GraphQL/Resolve.hs index b40e161d6a879..51218f0f2975b 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve.hs @@ -4,27 +4,24 @@ module Hasura.GraphQL.Resolve import Hasura.Prelude -import qualified Data.Aeson as J -import qualified Data.ByteString.Lazy as BL -import qualified Data.HashMap.Strict as Map -import qualified Database.PG.Query as Q -import qualified Language.GraphQL.Draft.Syntax as G - +import qualified Data.HashMap.Strict as Map +import qualified Database.PG.Query as Q +import qualified Language.GraphQL.Draft.Syntax as G import Hasura.GraphQL.Context +import Hasura.EncJSON import Hasura.GraphQL.Resolve.Context import Hasura.GraphQL.Resolve.Introspect -import Hasura.GraphQL.Transport.HTTP.Protocol import Hasura.GraphQL.Validate.Field import Hasura.RQL.Types import Hasura.SQL.Types -import qualified Hasura.GraphQL.Resolve.Insert as RI -import qualified Hasura.GraphQL.Resolve.Mutation as RM -import qualified Hasura.GraphQL.Resolve.Select as RS +import qualified Hasura.GraphQL.Resolve.Insert as RI +import qualified Hasura.GraphQL.Resolve.Mutation as RM +import qualified Hasura.GraphQL.Resolve.Select as RS -- {-# SCC buildTx #-} -buildTx :: UserInfo -> GCtx -> SQLGenCtx -> Field -> Q.TxE QErr BL.ByteString +buildTx :: UserInfo -> GCtx -> SQLGenCtx -> Field -> Q.TxE QErr EncJSON buildTx userInfo gCtx sqlCtx fld = do opCxt <- getOpCtx $ _fName fld join $ fmap fst $ runConvert ( fldMap @@ -79,12 +76,12 @@ resolveFld => UserInfo -> GCtx -> SQLGenCtx -> G.OperationType -> Field - -> m BL.ByteString + -> m EncJSON resolveFld userInfo gCtx sqlGenCtx opTy fld = case _fName fld of - "__type" -> J.encode <$> runReaderT (typeR fld) gCtx - "__schema" -> J.encode <$> runReaderT (schemaR fld) gCtx - "__typename" -> return $ J.encode $ mkRootTypeName opTy + "__type" -> encJFromJValue <$> runReaderT (typeR fld) gCtx + "__schema" -> encJFromJValue <$> runReaderT (schemaR fld) gCtx + "__typename" -> return $ encJFromJValue $ mkRootTypeName opTy _ -> liftTx $ buildTx userInfo gCtx sqlGenCtx fld where mkRootTypeName :: G.OperationType -> Text @@ -98,8 +95,8 @@ resolveSelSet => UserInfo -> GCtx -> SQLGenCtx -> G.OperationType -> SelSet - -> m BL.ByteString + -> m EncJSON resolveSelSet userInfo gCtx sqlGenCtx opTy fields = - fmap mkJSONObj $ forM (toList fields) $ \fld -> do + fmap encJFromAssocList $ forM (toList fields) $ \fld -> do fldResp <- resolveFld userInfo gCtx sqlGenCtx opTy fld return (G.unName $ G.unAlias $ _fAlias fld, fldResp) diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Context.hs b/server/src-lib/Hasura/GraphQL/Resolve/Context.hs index 16252777793e5..93b4c45321c2d 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Context.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Context.hs @@ -34,7 +34,6 @@ 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.ByteString.Lazy as BL import qualified Data.HashMap.Strict as Map import qualified Data.Sequence as Seq import qualified Database.PG.Query as Q @@ -42,6 +41,7 @@ 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 @@ -58,9 +58,9 @@ data InsResp } deriving (Show, Eq) $(J.deriveJSON (J.aesonDrop 3 J.snakeCase) ''InsResp) -type RespTx = Q.TxE QErr BL.ByteString +type RespTx = Q.TxE QErr EncJSON -type LazyRespTx = LazyTx QErr BL.ByteString +type LazyRespTx = LazyTx QErr EncJSON type PrepFn m = (PGColType, PGColValue) -> m S.SQLExp getFldInfo diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs b/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs index 014c777f89720..1873a8fd31196 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs @@ -3,6 +3,7 @@ module Hasura.GraphQL.Resolve.Insert where import Data.Has +import Hasura.EncJSON import Hasura.Prelude import Hasura.Server.Utils @@ -260,9 +261,9 @@ execCTEExp -> QualifiedTable -> CTEExp -> RR.MutFlds - -> Q.TxE QErr RespBody + -> Q.TxE QErr J.Object execCTEExp strfyNum tn (CTEExp cteExp args) flds = - runIdentity . Q.getRow + Q.getAltJ . runIdentity . Q.getRow <$> Q.rawQE dmlTxErrorHandler (Q.fromBuilder sqlBuilder) (toList args) True where sqlBuilder = toSQL $ RR.mkSelWith tn cteExp flds True strfyNum @@ -303,7 +304,7 @@ insertObjRel insertObjRel strfyNum role objRelIns = withPathK relNameTxt $ do resp <- insertMultipleObjects strfyNum role tn multiObjIns [] mutFlds "data" - MutateResp aRows colVals <- decodeFromBS resp + MutateResp aRows colVals <- decodeEncJSON resp colValM <- asSingleObject colVals colVal <- onNothing colValM $ throw400 NotSupported errMsg retColsWithVals <- fetchFromColVals colVal rColInfos pgiName @@ -330,6 +331,11 @@ insertObjRel strfyNum role objRelIns = ) ] +decodeEncJSON :: (J.FromJSON a, QErrM m) => EncJSON -> m a +decodeEncJSON = + either (throw500 . T.pack) decodeValue . + J.eitherDecode . encJToLBS + -- | insert an array relationship and return affected rows insertArrRel :: Bool @@ -344,7 +350,7 @@ insertArrRel strfyNum role resCols arrRelIns = (\(_, colVal) (_, rCol) -> (rCol, colVal)) resBS <- insertMultipleObjects strfyNum role tn multiObjIns addCols mutFlds "data" - resObj <- decodeFromBS resBS + resObj <- decodeEncJSON resBS onNothing (Map.lookup ("affected_rows" :: T.Text) resObj) $ throw500 "affected_rows not returned in array rel insert" where @@ -421,7 +427,7 @@ insertMultipleObjects -> [PGColWithValue] -- ^ additional fields -> RR.MutFlds -> T.Text -- ^ error path - -> Q.TxE QErr RespBody + -> Q.TxE QErr EncJSON insertMultipleObjects strfyNum role tn multiObjIns addCols mutFlds errP = bool withoutRelsInsert withRelsInsert anyRelsToInsert where @@ -459,16 +465,15 @@ insertMultipleObjects strfyNum role tn multiObjIns addCols mutFlds errP = let affRows = sum $ map fst insResps cteExps = map snd insResps retFlds = mapMaybe getRet mutFlds - rawResps <- forM cteExps - $ \cteExp -> execCTEExp strfyNum tn cteExp retFlds - respVals :: [J.Object] <- mapM decodeFromBS rawResps + respVals <- forM cteExps $ \cteExp -> + execCTEExp strfyNum tn cteExp retFlds respTups <- forM mutFlds $ \(t, mutFld) -> do jsonVal <- case mutFld of RR.MCount -> return $ J.toJSON affRows RR.MExp txt -> return $ J.toJSON txt RR.MRet _ -> J.toJSON <$> mapM (fetchVal t) respVals return (t, jsonVal) - return $ J.encode $ OMap.fromList respTups + return $ encJFromJValue $ OMap.fromList respTups getRet (t, r@(RR.MRet _)) = Just (t, r) getRet _ = Nothing @@ -487,7 +492,7 @@ convertInsert role tn fld = prefixErrPath fld $ do annVals <- withArg arguments "objects" asArray -- if insert input objects is empty array then -- do not perform insert and return mutation response - bool (withNonEmptyObjs annVals mutFlds) (buildEmptyMutResp mutFlds) $ null annVals + bool (withNonEmptyObjs annVals mutFlds) (withEmptyObjs mutFlds) $ null annVals where withNonEmptyObjs annVals mutFlds = do InsCtx vn tableCols defValMap relInfoMap updPerm uniqCols <- getInsCtx tn @@ -498,7 +503,8 @@ convertInsert role tn fld = prefixErrPath fld $ do strfyNum <- stringifyNum <$> asks getter return $ prefixErrPath fld $ insertMultipleObjects strfyNum role tn multiObjIns [] mutFlds "objects" - + withEmptyObjs mutFlds = + return $ return $ buildEmptyMutResp mutFlds arguments = _fArguments fld onConflictM = Map.lookup "on_conflict" arguments diff --git a/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs b/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs index a5ad176a5a689..08296339c6a2c 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/LiveQuery.hs @@ -8,12 +8,12 @@ module Hasura.GraphQL.Resolve.LiveQuery import qualified Control.Concurrent.Async as A import qualified Control.Concurrent.STM as STM -import qualified Data.ByteString.Lazy as BL import qualified ListT import qualified StmContainers.Map as STMMap import Control.Concurrent (threadDelay) +import Hasura.EncJSON import Hasura.GraphQL.Resolve.Context (LazyRespTx) import Hasura.GraphQL.Transport.HTTP.Protocol import Hasura.Prelude @@ -49,7 +49,7 @@ type LiveQueryMap k = STMMap.Map LiveQuery (LQHandler k, ThreadTM) newLiveQueryMap :: STM.STM (LiveQueryMap k) newLiveQueryMap = STMMap.new -type TxRunner = LazyRespTx -> IO (Either QErr BL.ByteString) +type TxRunner = LazyRespTx -> IO (Either QErr EncJSON) removeLiveQuery :: (Eq k, Hashable k) @@ -140,7 +140,7 @@ pollQuery runTx (LQHandler respTx respTV curOpsTV newOpsTV) = do let resp = case res of Left e -> GQExecError [encodeGQErr False e] - Right bs -> GQSuccess bs + Right bs -> GQSuccess $ encJToLBS bs -- extract the current and new operations (curOps, newOps) <- STM.atomically $ do @@ -154,7 +154,7 @@ pollQuery runTx (LQHandler respTx respTV curOpsTV newOpsTV) = do -- write to the current websockets if needed prevRespM <- STM.readTVarIO respTV - when (isExecError resp || Just resp /= prevRespM) $ do + when (isExecError resp || Just resp /= prevRespM) $ do runOperations resp curOps STM.atomically $ STM.writeTVar respTV $ Just resp diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs b/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs index 1dde2e9900e0a..281629eca79c9 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs @@ -30,6 +30,7 @@ import Hasura.GraphQL.Validate.Types import Hasura.RQL.Types import Hasura.SQL.Types import Hasura.SQL.Value +import Hasura.EncJSON convertMutResp :: G.NamedType -> SelSet -> Convert RR.MutFlds @@ -131,7 +132,7 @@ convertUpdate opCtx fld = do strfyNum <- stringifyNum <$> asks getter let p1 = RU.UpdateQueryP1 tn setItems (filterExp, whereExp) mutFlds uniqCols whenNonEmptyItems = return $ RU.updateQueryToTx strfyNum (p1, prepArgs) - whenEmptyItems = buildEmptyMutResp mutFlds + whenEmptyItems = return $ return $ buildEmptyMutResp mutFlds -- if there are not set items then do not perform -- update and return empty mutation response bool whenNonEmptyItems whenEmptyItems $ null setItems @@ -155,10 +156,10 @@ convertDelete opCtx fld = do DelOpCtx tn _ filterExp uniqCols = opCtx -- | build mutation response for empty objects -buildEmptyMutResp :: Monad m => RR.MutFlds -> m RespTx -buildEmptyMutResp = return . mkTx +buildEmptyMutResp :: RR.MutFlds -> EncJSON +buildEmptyMutResp = mkTx where - mkTx = return . J.encode . OMap.fromList . map (second convMutFld) + mkTx = encJFromJValue . OMap.fromList . map (second convMutFld) -- generate empty mutation response convMutFld = \case RR.MCount -> J.toJSON (0 :: Int) diff --git a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs index 0b2076dccb520..1b25dc5d37245 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs @@ -8,7 +8,6 @@ module Hasura.GraphQL.Transport.HTTP import Control.Exception (try) import Control.Lens -import Hasura.Prelude import qualified Data.ByteString.Lazy as BL import qualified Data.CaseInsensitive as CI @@ -27,6 +26,8 @@ import Hasura.GraphQL.Transport.HTTP.Protocol import Hasura.HTTP import Hasura.RQL.DDL.Headers import Hasura.RQL.Types +import Hasura.Prelude +import Hasura.EncJSON import qualified Hasura.GraphQL.Resolve as R import qualified Hasura.GraphQL.Validate as VQ @@ -43,7 +44,7 @@ runGQ -> [N.Header] -> GraphQLRequest -> BL.ByteString -- this can be removed when we have a pretty-printer - -> m BL.ByteString + -> m EncJSON runGQ pool isoL userInfo sqlGenCtx sc manager reqHdrs req rawReq = do (gCtx, _) <- flip runStateT sc $ getGCtx (userRole userInfo) gCtxRoleMap @@ -106,7 +107,7 @@ runHasuraGQ -> SQLGenCtx -> SchemaCache -> VQ.QueryParts - -> m BL.ByteString + -> m EncJSON runHasuraGQ pool isoL userInfo sqlGenCtx sc queryParts = do (gCtx, _) <- flip runStateT sc $ getGCtx (userRole userInfo) gCtxMap (opTy, fields) <- runReaderT (VQ.validateGQ queryParts) gCtx @@ -114,7 +115,7 @@ runHasuraGQ pool isoL userInfo sqlGenCtx sc queryParts = do "subscriptions are not supported over HTTP, use websockets instead" let tx = R.resolveSelSet userInfo gCtx sqlGenCtx opTy fields resp <- liftIO (runExceptT $ runTx tx) >>= liftEither - return $ encodeGQResp $ GQSuccess resp + return $ encodeGQResp $ GQSuccess $ encJToLBS resp where gCtxMap = scGCtxMap sc runTx tx = runLazyTx pool isoL $ withUserInfo userInfo tx @@ -128,7 +129,7 @@ runRemoteGQ -- ^ the raw request string -> RemoteSchemaInfo -> G.TypedOperationDefinition - -> m BL.ByteString + -> m EncJSON runRemoteGQ manager userInfo reqHdrs q rsi opDef = do let opTy = G._todType opDef when (opTy == G.OperationTypeSubscription) $ @@ -140,7 +141,7 @@ runRemoteGQ manager userInfo reqHdrs q rsi opDef = do res <- liftIO $ try $ Wreq.postWith options (show url) q resp <- either httpThrow return res - return $ resp ^. Wreq.responseBody + return $ encJFromLBS $ resp ^. Wreq.responseBody where RemoteSchemaInfo url hdrConf fwdClientHdrs = rsi diff --git a/server/src-lib/Hasura/GraphQL/Transport/HTTP/Protocol.hs b/server/src-lib/Hasura/GraphQL/Transport/HTTP/Protocol.hs index bf6616aa53e0b..314cc916b4e81 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/HTTP/Protocol.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/HTTP/Protocol.hs @@ -4,28 +4,23 @@ module Hasura.GraphQL.Transport.HTTP.Protocol , OperationName(..) , VariableValues , encodeGQErr - , encodeJSONObject , encodeGQResp - , mkJSONObj , GQResp(..) , isExecError ) where +import Hasura.EncJSON import Hasura.Prelude +import Hasura.RQL.Types import qualified Data.Aeson as J import qualified Data.Aeson.Casing as J import qualified Data.Aeson.TH as J -import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as Map -import qualified Data.Text.Encoding as TE -import qualified Data.Vector as V import qualified Language.GraphQL.Draft.Parser as G import qualified Language.GraphQL.Draft.Syntax as G -import Hasura.RQL.Types - newtype GraphQLQuery = GraphQLQuery { unGraphQLQuery :: [G.ExecutableDefinition] } deriving (Show, Eq, Hashable) @@ -67,9 +62,9 @@ encodeGQErr includeInternal qErr = J.object [ "errors" J..= [encodeGQLErr includeInternal qErr]] data GQResp - = GQSuccess BL.ByteString - | GQPreExecError [J.Value] - | GQExecError [J.Value] + = GQSuccess !BL.ByteString + | GQPreExecError ![J.Value] + | GQExecError ![J.Value] deriving (Show, Eq) isExecError :: GQResp -> Bool @@ -77,24 +72,9 @@ isExecError = \case GQExecError _ -> True _ -> False -encodeJSONObject :: V.Vector (Text, BL.ByteString) -> BB.Builder -encodeJSONObject xs - | V.null xs = BB.char7 '{' <> BB.char7 '}' - | otherwise = BB.char7 '{' <> builder' (V.unsafeHead xs) <> - V.foldr go (BB.char7 '}') (V.unsafeTail xs) - where - go v b = BB.char7 ',' <> builder' v <> b - -- builds "key":value from (key,value) - builder' (t, v) = - BB.char7 '"' <> TE.encodeUtf8Builder t <> BB.string7 "\":" - <> BB.lazyByteString v - -encodeGQResp :: GQResp -> BL.ByteString +encodeGQResp :: GQResp -> EncJSON encodeGQResp gqResp = - mkJSONObj $ case gqResp of - GQSuccess r -> [("data", r)] - GQPreExecError e -> [("errors", J.encode e)] - GQExecError e -> [("data", "null"), ("errors", J.encode e)] - -mkJSONObj :: [(Text, BL.ByteString)] -> BL.ByteString -mkJSONObj = BB.toLazyByteString . encodeJSONObject . V.fromList + encJFromAssocList $ case gqResp of + GQSuccess r -> [("data", encJFromLBS r)] + GQPreExecError e -> [("errors", encJFromJValue e)] + GQExecError e -> [("data", "null"), ("errors", encJFromJValue e)] diff --git a/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs b/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs index 12d317de6b93a..08ea68a392db8 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs @@ -41,6 +41,7 @@ import Hasura.GraphQL.Validate (QueryParts (..), import qualified Hasura.GraphQL.Validate.Types as VT import qualified Hasura.Logging as L import Hasura.Prelude +import Hasura.EncJSON import Hasura.RQL.Types import Hasura.Server.Auth (AuthMode, getUserInfo) @@ -50,7 +51,7 @@ import Hasura.Server.Utils (bsToTxt) -- uniquely identifies an operation type GOperationId = (WS.WSId, OperationId) -type TxRunner = LazyRespTx -> IO (Either QErr BL.ByteString) +type TxRunner = LazyRespTx -> IO (Either QErr EncJSON) type OperationMap = STMMap.Map OperationId LQ.LiveQuery @@ -310,8 +311,8 @@ onStart serverEnv wsConn (StartMsg opId q) msgRaw = catchAndIgnore $ do logOpEv $ ODQueryErr qErr sendMsg wsConn $ SMErr $ ErrorMsg opId $ encodeQErr False qErr - sendSuccResp bs = - sendMsg wsConn $ SMData $ DataMsg opId $ GQSuccess bs + sendSuccResp encJson = + sendMsg wsConn $ SMData $ DataMsg opId $ GQSuccess $ encJToLBS encJson withComplete :: ExceptT () IO () -> ExceptT () IO a withComplete action = do diff --git a/server/src-lib/Hasura/GraphQL/Transport/WebSocket/Protocol.hs b/server/src-lib/Hasura/GraphQL/Transport/WebSocket/Protocol.hs index 259ddfbc798bc..b04a46869478a 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/WebSocket/Protocol.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/WebSocket/Protocol.hs @@ -18,6 +18,7 @@ import qualified Data.Aeson.TH as J import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as Map +import Hasura.EncJSON import Hasura.GraphQL.Transport.HTTP.Protocol import Hasura.Prelude @@ -67,7 +68,7 @@ data DataMsg = DataMsg { _dmId :: !OperationId , _dmPayload :: !GQResp - } deriving (Show, Eq) + } data ErrorMsg = ErrorMsg @@ -90,7 +91,6 @@ data ServerMsg | SMData !DataMsg | SMErr !ErrorMsg | SMComplete !CompletionMsg - deriving (Show, Eq) data ServerMsgType = SMT_GQL_CONNECTION_ACK @@ -115,7 +115,7 @@ instance J.ToJSON ServerMsgType where encodeServerMsg :: ServerMsg -> BL.ByteString encodeServerMsg msg = - mkJSONObj $ case msg of + encJToLBS $ encJFromAssocList $ case msg of SMConnAck -> [encTy SMT_GQL_CONNECTION_ACK] @@ -125,25 +125,25 @@ encodeServerMsg msg = SMConnErr connErr -> [ encTy SMT_GQL_CONNECTION_ERROR - , ("payload", J.encode connErr) + , ("payload", encJFromJValue connErr) ] SMData (DataMsg opId payload) -> [ encTy SMT_GQL_DATA - , ("id", J.encode opId) + , ("id", encJFromJValue opId) , ("payload", encodeGQResp payload) ] SMErr (ErrorMsg opId payload) -> [ encTy SMT_GQL_ERROR - , ("id", J.encode opId) - , ("payload", J.encode payload) + , ("id", encJFromJValue opId) + , ("payload", encJFromJValue payload) ] SMComplete compMsg -> [ encTy SMT_GQL_COMPLETE - , ("id", J.encode $ unCompletionMsg compMsg) + , ("id", encJFromJValue $ unCompletionMsg compMsg) ] where - encTy ty = ("type", J.encode ty) + encTy ty = ("type", encJFromJValue ty) diff --git a/server/src-lib/Hasura/RQL/DDL/Metadata.hs b/server/src-lib/Hasura/RQL/DDL/Metadata.hs index df5ae691a0d2a..707fd49adf034 100644 --- a/server/src-lib/Hasura/RQL/DDL/Metadata.hs +++ b/server/src-lib/Hasura/RQL/DDL/Metadata.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} + module Hasura.RQL.DDL.Metadata ( TableMeta @@ -29,6 +31,7 @@ import qualified Data.HashSet as HS import qualified Data.List as L import qualified Data.Text as T +import Hasura.EncJSON import Hasura.Prelude import Hasura.RQL.Types import Hasura.SQL.Types @@ -123,7 +126,7 @@ runClearMetadata :: ( QErrM m, UserInfoM m, CacheRWM m, MonadTx m , MonadIO m, HasHttpManager m, HasSQLGenCtx m ) - => ClearMetadata -> m RespBody + => ClearMetadata -> m EncJSON runClearMetadata _ = do adminOnly liftTx clearMetadata @@ -201,7 +204,7 @@ applyQP2 , HasSQLGenCtx m ) => ReplaceMetadata - -> m RespBody + -> m EncJSON applyQP2 (ReplaceMetadata tables templates mFunctions mSchemas) = do liftTx clearMetadata @@ -269,7 +272,7 @@ runReplaceMetadata :: ( QErrM m, UserInfoM m, CacheRWM m, MonadTx m , MonadIO m, HasHttpManager m, HasSQLGenCtx m ) - => ReplaceMetadata -> m RespBody + => ReplaceMetadata -> m EncJSON runReplaceMetadata q = do applyQP1 q applyQP2 q @@ -398,10 +401,10 @@ fetchMetadata = do runExportMetadata :: (QErrM m, UserInfoM m, MonadTx m) - => ExportMetadata -> m RespBody + => ExportMetadata -> m EncJSON runExportMetadata _ = do adminOnly - encode <$> liftTx fetchMetadata + encJFromJValue <$> liftTx fetchMetadata data ReloadMetadata = ReloadMetadata @@ -416,7 +419,7 @@ runReloadMetadata :: ( QErrM m, UserInfoM m, CacheRWM m , MonadTx m, MonadIO m, HasHttpManager m, HasSQLGenCtx m ) - => ReloadMetadata -> m RespBody + => ReloadMetadata -> m EncJSON runReloadMetadata _ = do adminOnly DT.buildSchemaCache @@ -433,7 +436,7 @@ $(deriveToJSON defaultOptions ''DumpInternalState) runDumpInternalState :: (QErrM m, UserInfoM m, CacheRM m) - => DumpInternalState -> m RespBody + => DumpInternalState -> m EncJSON runDumpInternalState _ = do adminOnly - encode <$> askSchemaCache + encJFromJValue <$> askSchemaCache diff --git a/server/src-lib/Hasura/RQL/DDL/Permission.hs b/server/src-lib/Hasura/RQL/DDL/Permission.hs index eccb7c7fa5972..5f3bc31466d7f 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission.hs @@ -46,6 +46,7 @@ module Hasura.RQL.DDL.Permission , runSetPermComment ) where +import Hasura.EncJSON import Hasura.Prelude import Hasura.RQL.DDL.Permission.Internal import Hasura.RQL.DDL.Permission.Triggers @@ -400,14 +401,14 @@ setPermCommentP1 (SetPermComment qt rn pt _) = do PTUpdate -> assertPermDefined rn PAUpdate tabInfo PTDelete -> assertPermDefined rn PADelete tabInfo -setPermCommentP2 :: (QErrM m, MonadTx m) => SetPermComment -> m RespBody +setPermCommentP2 :: (QErrM m, MonadTx m) => SetPermComment -> m EncJSON setPermCommentP2 apc = do liftTx $ setPermCommentTx apc return successMsg runSetPermComment :: (QErrM m, CacheRM m, MonadTx m, UserInfoM m) - => SetPermComment -> m RespBody + => SetPermComment -> m EncJSON runSetPermComment defn = do setPermCommentP1 defn setPermCommentP2 defn diff --git a/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs b/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs index 9e7f01cc92f3f..6f2774bd77331 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs @@ -16,6 +16,7 @@ import Language.Haskell.TH.Syntax (Lift) import qualified Data.HashMap.Strict as M import qualified Data.Text.Extended as T +import Hasura.EncJSON import Hasura.Prelude import Hasura.RQL.GBoolExp import Hasura.RQL.Types @@ -322,7 +323,7 @@ runCreatePerm :: ( UserInfoM m , CacheRWM m, IsPerm a, MonadTx m ) - => CreatePerm a -> m RespBody + => CreatePerm a -> m EncJSON runCreatePerm defn@(WithTable tn pd) = do permInfo <- createPermP1 defn addPermP2 tn pd permInfo @@ -349,7 +350,7 @@ dropPermP2 dp@(DropPerm tn rn) p1Res = do runDropPerm :: (IsPerm a, UserInfoM m, CacheRWM m, MonadTx m) - => DropPerm a -> m RespBody + => DropPerm a -> m EncJSON runDropPerm defn = do permInfo <- buildDropPermP1Res defn dropPermP2 defn permInfo diff --git a/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs b/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs index 9f483f9def0e4..abd16856f45fa 100644 --- a/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs +++ b/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs @@ -14,6 +14,7 @@ module Hasura.RQL.DDL.QueryTemplate , runSetQueryTemplateComment ) where +import Hasura.EncJSON import Hasura.Prelude import Hasura.RQL.GBoolExp (txtRHSBuilder) import Hasura.RQL.Types @@ -149,7 +150,7 @@ createQueryTemplateP2 :: (QErrM m, CacheRWM m, MonadTx m) => CreateQueryTemplate -> WithDeps QueryTemplateInfo - -> m RespBody + -> m EncJSON createQueryTemplateP2 cqt (qti, deps) = do addQTemplateToCache qti deps liftTx $ addQTemplateToCatalog cqt @@ -157,7 +158,7 @@ createQueryTemplateP2 cqt (qti, deps) = do runCreateQueryTemplate :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, HasSQLGenCtx m) - => CreateQueryTemplate -> m RespBody + => CreateQueryTemplate -> m EncJSON runCreateQueryTemplate q = createQueryTemplateP1 q >>= createQueryTemplateP2 q @@ -180,7 +181,7 @@ delQTemplateFromCatalog qtn = runDropQueryTemplate :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m) - => DropQueryTemplate -> m RespBody + => DropQueryTemplate -> m EncJSON runDropQueryTemplate q = do withPathK "name" $ void $ askQTemplateInfo qtn delQTemplateFromCache qtn @@ -205,7 +206,7 @@ setQueryTemplateCommentP1 (SetQueryTemplateComment qtn _) = do void $ askQTemplateInfo qtn setQueryTemplateCommentP2 - :: (QErrM m, MonadTx m) => SetQueryTemplateComment -> m RespBody + :: (QErrM m, MonadTx m) => SetQueryTemplateComment -> m EncJSON setQueryTemplateCommentP2 apc = do liftTx $ setQueryTemplateCommentTx apc return successMsg @@ -223,7 +224,7 @@ setQueryTemplateCommentTx (SetQueryTemplateComment qtn comment) = runSetQueryTemplateComment :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m) - => SetQueryTemplateComment -> m RespBody + => SetQueryTemplateComment -> m EncJSON runSetQueryTemplateComment q = do setQueryTemplateCommentP1 q setQueryTemplateCommentP2 q diff --git a/server/src-lib/Hasura/RQL/DDL/Relationship.hs b/server/src-lib/Hasura/RQL/DDL/Relationship.hs index 645ee6109bbef..499db8f191dac 100644 --- a/server/src-lib/Hasura/RQL/DDL/Relationship.hs +++ b/server/src-lib/Hasura/RQL/DDL/Relationship.hs @@ -14,6 +14,8 @@ module Hasura.RQL.DDL.Relationship where import qualified Database.PG.Query as Q + +import Hasura.EncJSON import Hasura.Prelude import Hasura.RQL.DDL.Deps import Hasura.RQL.DDL.Permission (purgePerm) @@ -156,14 +158,14 @@ objRelP2 qt rd@(RelDef rn ru comment) = do liftTx $ persistRel qt rn ObjRel (toJSON ru) comment createObjRelP2 - :: (QErrM m, CacheRWM m, MonadTx m) => CreateObjRel -> m RespBody + :: (QErrM m, CacheRWM m, MonadTx m) => CreateObjRel -> m EncJSON createObjRelP2 (WithTable qt rd) = do objRelP2 qt rd return successMsg runCreateObjRel :: (QErrM m, CacheRWM m, MonadTx m , UserInfoM m) - => CreateObjRel -> m RespBody + => CreateObjRel -> m EncJSON runCreateObjRel defn = do createObjRelP1 defn createObjRelP2 defn @@ -243,14 +245,14 @@ arrRelP2 qt rd@(RelDef rn u comment) = do liftTx $ persistRel qt rn ArrRel (toJSON u) comment createArrRelP2 - :: (QErrM m, CacheRWM m, MonadTx m) => CreateArrRel -> m RespBody + :: (QErrM m, CacheRWM m, MonadTx m) => CreateArrRel -> m EncJSON createArrRelP2 (WithTable qt rd) = do arrRelP2 qt rd return successMsg runCreateArrRel :: (QErrM m, CacheRWM m, MonadTx m , UserInfoM m) - => CreateArrRel -> m RespBody + => CreateArrRel -> m EncJSON runCreateArrRel defn = do createArrRelP1 defn createArrRelP2 defn @@ -276,7 +278,7 @@ purgeRelDep d = throw500 $ "unexpected dependency of relationship : " dropRelP2 :: (QErrM m, CacheRWM m, MonadTx m) - => DropRel -> [SchemaObjId] -> m RespBody + => DropRel -> [SchemaObjId] -> m EncJSON dropRelP2 (DropRel qt rn _) depObjs = do mapM_ purgeRelDep depObjs delRelFromCache rn qt @@ -285,7 +287,7 @@ dropRelP2 (DropRel qt rn _) depObjs = do runDropRel :: (QErrM m, CacheRWM m, MonadTx m , UserInfoM m) - => DropRel -> m RespBody + => DropRel -> m EncJSON runDropRel defn = do depObjs <- dropRelP1 defn dropRelP2 defn depObjs @@ -313,14 +315,14 @@ validateRelP1 qt rn = do setRelCommentP2 :: (QErrM m, MonadTx m) - => SetRelComment -> m RespBody + => SetRelComment -> m EncJSON setRelCommentP2 arc = do liftTx $ setRelComment arc return successMsg runSetRelComment :: (QErrM m, CacheRWM m, MonadTx m , UserInfoM m) - => SetRelComment -> m RespBody + => SetRelComment -> m EncJSON runSetRelComment defn = do void $ validateRelP1 qt rn setRelCommentP2 defn diff --git a/server/src-lib/Hasura/RQL/DDL/Relationship/Rename.hs b/server/src-lib/Hasura/RQL/DDL/Relationship/Rename.hs index 16cf86a82b089..69f3c648e511e 100644 --- a/server/src-lib/Hasura/RQL/DDL/Relationship/Rename.hs +++ b/server/src-lib/Hasura/RQL/DDL/Relationship/Rename.hs @@ -3,6 +3,7 @@ module Hasura.RQL.DDL.Relationship.Rename where import Hasura.Prelude +import Hasura.EncJSON import Hasura.RQL.DDL.Relationship (validateRelP1) import Hasura.RQL.DDL.Relationship.Types import Hasura.RQL.DDL.Schema.Rename (renameRelInCatalog) @@ -46,7 +47,7 @@ runRenameRel , HasHttpManager m , HasSQLGenCtx m ) - => RenameRel -> m RespBody + => RenameRel -> m EncJSON runRenameRel defn = do ri <- validateRelP1 qt rn renameRelP2 qt newRN ri diff --git a/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs b/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs index 8e0fa0b9c9888..4e8b47e71e61c 100644 --- a/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs +++ b/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs @@ -7,10 +7,10 @@ module Hasura.RQL.DDL.RemoteSchema , addRemoteSchemaP2 ) where +import Hasura.EncJSON import Hasura.Prelude import qualified Data.Aeson as J -import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as Map import qualified Database.PG.Query as Q @@ -24,7 +24,7 @@ runAddRemoteSchema , MonadIO m , HasHttpManager m ) - => AddRemoteSchemaQuery -> m RespBody + => AddRemoteSchemaQuery -> m EncJSON runAddRemoteSchema q = do adminOnly addRemoteSchemaP2 q @@ -37,7 +37,7 @@ addRemoteSchemaP2 , HasHttpManager m ) => AddRemoteSchemaQuery - -> m BL.ByteString + -> m EncJSON addRemoteSchemaP2 q@(AddRemoteSchemaQuery name def _) = do rsi <- validateRemoteSchemaDef def manager <- askHttpManager @@ -89,7 +89,7 @@ refreshGCtxMapInSchema = do runRemoveRemoteSchema :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m) - => RemoveRemoteSchemaQuery -> m RespBody + => RemoveRemoteSchemaQuery -> m EncJSON runRemoveRemoteSchema q = removeRemoteSchemaP1 q >>= removeRemoteSchemaP2 @@ -106,7 +106,7 @@ removeRemoteSchemaP2 , HasHttpManager m ) => RemoveRemoteSchemaQuery - -> m BL.ByteString + -> m EncJSON removeRemoteSchemaP2 (RemoveRemoteSchemaQuery name) = do mSchema <- liftTx $ fetchRemoteSchemaDef name _ <- liftMaybe (err400 NotExists "no such remote schema") mSchema diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Function.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Function.hs index 0ad8f8bff6e31..4fac4e26c0ecf 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Function.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Function.hs @@ -2,6 +2,7 @@ module Hasura.RQL.DDL.Schema.Function where import Hasura.GraphQL.Utils (isValidName, showNames) import Hasura.Prelude +import Hasura.EncJSON import Hasura.RQL.Types import Hasura.SQL.Types @@ -140,7 +141,7 @@ trackFunctionP2Setup qf = do addFunctionToCache fi trackFunctionP2 :: (QErrM m, CacheRWM m, MonadTx m) - => QualifiedFunction -> m RespBody + => QualifiedFunction -> m EncJSON trackFunctionP2 qf = do sc <- askSchemaCache let defGCtx = scDefaultRemoteGCtx sc @@ -158,7 +159,7 @@ runTrackFunc :: ( QErrM m, CacheRWM m, MonadTx m , UserInfoM m ) - => TrackFunction -> m RespBody + => TrackFunction -> m EncJSON runTrackFunc q = do trackFunctionP1 q trackFunctionP2 $ tfName q @@ -172,7 +173,7 @@ runUntrackFunc :: ( QErrM m, CacheRWM m, MonadTx m , UserInfoM m ) - => UnTrackFunction -> m RespBody + => UnTrackFunction -> m EncJSON runUntrackFunc (UnTrackFunction qf) = do adminOnly void $ askFunctionInfo qf diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs index eb4bf36200e68..6bd5b31119c68 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE TypeApplications #-} + module Hasura.RQL.DDL.Schema.Table where import Hasura.GraphQL.RemoteServer import Hasura.Prelude +import Hasura.EncJSON import Hasura.RQL.DDL.Deps import Hasura.RQL.DDL.Permission import Hasura.RQL.DDL.Permission.Internal @@ -78,7 +81,7 @@ trackExistingTableOrViewP2Setup tn isSystemDefined = do trackExistingTableOrViewP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m) - => QualifiedTable -> Bool -> m RespBody + => QualifiedTable -> Bool -> m EncJSON trackExistingTableOrViewP2 vn isSystemDefined = do sc <- askSchemaCache let defGCtx = scDefaultRemoteGCtx sc @@ -98,7 +101,7 @@ runTrackTableQ :: ( QErrM m, CacheRWM m, MonadTx m , MonadIO m, HasHttpManager m, UserInfoM m ) - => TrackTable -> m RespBody + => TrackTable -> m EncJSON runTrackTableQ q = do trackExistingTableOrViewP1 q trackExistingTableOrViewP2 (tName q) False @@ -248,7 +251,7 @@ unTrackExistingTableOrViewP1 (UntrackTable vn _) = do unTrackExistingTableOrViewP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m) - => UntrackTable -> m RespBody + => UntrackTable -> m EncJSON unTrackExistingTableOrViewP2 (UntrackTable qtn cascade) = do sc <- askSchemaCache @@ -278,7 +281,7 @@ runUntrackTableQ :: ( QErrM m, CacheRWM m, MonadTx m , MonadIO m, HasHttpManager m, UserInfoM m ) - => UntrackTable -> m RespBody + => UntrackTable -> m EncJSON runUntrackTableQ q = do unTrackExistingTableOrViewP1 q unTrackExistingTableOrViewP2 q @@ -419,8 +422,16 @@ data RunSQLRes $(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''RunSQLRes) -execRawSQL :: (MonadTx m) => T.Text -> m RunSQLRes +instance Q.FromRes RunSQLRes where + fromRes (Q.ResultOkEmpty _) = + return $ RunSQLRes "CommandOk" Null + fromRes (Q.ResultOkData res) = do + csvRows <- resToCSV res + return $ RunSQLRes "TuplesOk" $ toJSON csvRows + +execRawSQL :: (MonadTx m) => T.Text -> m EncJSON execRawSQL = + fmap (encJFromJValue @RunSQLRes) . liftTx . Q.multiQE rawSqlErrHandler . Q.fromText where rawSqlErrHandler txe = @@ -429,7 +440,7 @@ execRawSQL = execWithMDCheck :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m, HasSQLGenCtx m) - => RunSQL -> m RunSQLRes + => RunSQL -> m EncJSON execWithMDCheck (RunSQL t cascade _) = do -- Drop hdb_views so no interference is caused to the sql query @@ -523,11 +534,11 @@ isAltrDropReplace = either throwErr return . matchRegex regex False runRunSQL :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m, HasSQLGenCtx m) - => RunSQL -> m RespBody + => RunSQL -> m EncJSON runRunSQL q@(RunSQL t _ mChkMDCnstcy) = do adminOnly isMDChkNeeded <- maybe (isAltrDropReplace t) return mChkMDCnstcy - encode <$> bool (execRawSQL t) (execWithMDCheck q) isMDChkNeeded + bool (execRawSQL t) (execWithMDCheck q) isMDChkNeeded -- Should be used only after checking the status resToCSV :: PQ.Result -> ExceptT T.Text IO [[T.Text]] @@ -548,10 +559,3 @@ resToCSV r = do where decodeBS = either (throwError . T.pack . show) return . TE.decodeUtf8' - -instance Q.FromRes RunSQLRes where - fromRes (Q.ResultOkEmpty _) = - return $ RunSQLRes "CommandOk" Null - fromRes (Q.ResultOkData res) = do - csvRows <- resToCSV res - return $ RunSQLRes "TuplesOk" $ toJSON csvRows diff --git a/server/src-lib/Hasura/RQL/DDL/Subscribe.hs b/server/src-lib/Hasura/RQL/DDL/Subscribe.hs index 1e9bd9e9c2bd3..08f03e5200947 100644 --- a/server/src-lib/Hasura/RQL/DDL/Subscribe.hs +++ b/server/src-lib/Hasura/RQL/DDL/Subscribe.hs @@ -17,6 +17,7 @@ module Hasura.RQL.DDL.Subscribe import Data.Aeson import Hasura.Prelude +import Hasura.EncJSON import Hasura.RQL.DDL.Headers import Hasura.RQL.DML.Internal import Hasura.RQL.Types @@ -288,7 +289,7 @@ subTableP2 qt replace etc = do runCreateEventTriggerQuery :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, MonadIO m, HasSQLGenCtx m) - => CreateEventTriggerQuery -> m RespBody + => CreateEventTriggerQuery -> m EncJSON runCreateEventTriggerQuery q = do (qt, replace, etc) <- subTableP1 q subTableP2 qt replace etc @@ -304,7 +305,7 @@ unsubTableP1 (DeleteEventTriggerQuery name) = do unsubTableP2 :: (QErrM m, CacheRWM m, MonadTx m) - => DeleteEventTriggerQuery -> QualifiedTable -> m RespBody + => DeleteEventTriggerQuery -> QualifiedTable -> m EncJSON unsubTableP2 (DeleteEventTriggerQuery name) qt = do delEventTriggerFromCache qt name liftTx $ delEventTriggerFromCatalog name @@ -312,13 +313,13 @@ unsubTableP2 (DeleteEventTriggerQuery name) qt = do runDeleteEventTriggerQuery :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m) - => DeleteEventTriggerQuery -> m RespBody + => DeleteEventTriggerQuery -> m EncJSON runDeleteEventTriggerQuery q = unsubTableP1 q >>= unsubTableP2 q deliverEvent :: (QErrM m, MonadTx m) - => DeliverEventQuery -> m RespBody + => DeliverEventQuery -> m EncJSON deliverEvent (DeliverEventQuery eventId) = do _ <- liftTx $ fetchEvent eventId liftTx $ markForDelivery eventId @@ -326,7 +327,7 @@ deliverEvent (DeliverEventQuery eventId) = do runDeliverEvent :: (QErrM m, UserInfoM m, MonadTx m) - => DeliverEventQuery -> m RespBody + => DeliverEventQuery -> m EncJSON runDeliverEvent q = adminOnly >> deliverEvent q diff --git a/server/src-lib/Hasura/RQL/DML/Count.hs b/server/src-lib/Hasura/RQL/DML/Count.hs index 119accc3e169d..ab1e08444a19d 100644 --- a/server/src-lib/Hasura/RQL/DML/Count.hs +++ b/server/src-lib/Hasura/RQL/DML/Count.hs @@ -14,6 +14,7 @@ import qualified Data.ByteString.Builder as BB import qualified Data.Sequence as DS import Hasura.Prelude +import Hasura.EncJSON import Hasura.RQL.DML.Internal import Hasura.RQL.GBoolExp import Hasura.RQL.Types @@ -113,11 +114,11 @@ validateCountQ = countQToTx :: (QErrM m, MonadTx m) - => (CountQueryP1, DS.Seq Q.PrepArg) -> m RespBody + => (CountQueryP1, DS.Seq Q.PrepArg) -> m EncJSON countQToTx (u, p) = do qRes <- liftTx $ Q.rawQE dmlTxErrorHandler (Q.fromBuilder countSQL) (toList p) True - return $ BB.toLazyByteString $ encodeCount qRes + return $ encJFromBuilder $ encodeCount qRes where countSQL = toSQL $ mkSQLCount u encodeCount (Q.SingleRow (Identity c)) = @@ -125,6 +126,6 @@ countQToTx (u, p) = do runCount :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, HasSQLGenCtx m) - => CountQuery -> m RespBody + => CountQuery -> m EncJSON runCount q = validateCountQ q >>= countQToTx diff --git a/server/src-lib/Hasura/RQL/DML/Delete.hs b/server/src-lib/Hasura/RQL/DML/Delete.hs index 4bd9f1645d360..0e777b6c2bb85 100644 --- a/server/src-lib/Hasura/RQL/DML/Delete.hs +++ b/server/src-lib/Hasura/RQL/DML/Delete.hs @@ -12,6 +12,7 @@ import Instances.TH.Lift () import qualified Data.Sequence as DS +import Hasura.EncJSON import Hasura.Prelude import Hasura.RQL.DML.Internal import Hasura.RQL.DML.Mutation @@ -101,7 +102,7 @@ validateDeleteQ validateDeleteQ = liftDMLP1 . validateDeleteQWith binRHSBuilder -deleteQueryToTx :: Bool -> (DeleteQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody +deleteQueryToTx :: Bool -> (DeleteQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr EncJSON deleteQueryToTx strfyNum (u, p) = runMutation $ Mutation (dqp1Table u) (deleteCTE, p) (dqp1MutFlds u) (dqp1UniqCols u) strfyNum @@ -110,7 +111,7 @@ deleteQueryToTx strfyNum (u, p) = runDelete :: (QErrM m, UserInfoM m, CacheRM m, MonadTx m, HasSQLGenCtx m) - => DeleteQuery -> m RespBody + => DeleteQuery -> m EncJSON runDelete q = do strfyNum <- stringifyNum <$> askSQLGenCtx validateDeleteQ q >>= liftTx . deleteQueryToTx strfyNum diff --git a/server/src-lib/Hasura/RQL/DML/Insert.hs b/server/src-lib/Hasura/RQL/DML/Insert.hs index 58610536bd9ef..b5a14fe4c57cb 100644 --- a/server/src-lib/Hasura/RQL/DML/Insert.hs +++ b/server/src-lib/Hasura/RQL/DML/Insert.hs @@ -10,6 +10,7 @@ import qualified Data.Sequence as DS import qualified Data.Text.Lazy as LT import Hasura.Prelude +import Hasura.EncJSON import Hasura.RQL.DML.Internal import Hasura.RQL.DML.Mutation import Hasura.RQL.DML.Returning @@ -240,7 +241,7 @@ convInsQ = liftDMLP1 . convInsertQuery (withPathK "objects" . decodeInsObjs) binRHSBuilder -insertP2 :: Bool -> (InsertQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody +insertP2 :: Bool -> (InsertQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr EncJSON insertP2 strfyNum (u, p) = runMutation $ Mutation (iqp1Table u) (insertCTE, p) (iqp1MutFlds u) (iqp1UniqCols u) strfyNum @@ -252,7 +253,7 @@ data ConflictCtx | CCDoNothing !(Maybe ConstraintName) deriving (Show, Eq) -nonAdminInsert :: Bool -> (InsertQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody +nonAdminInsert :: Bool -> (InsertQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr EncJSON nonAdminInsert strfyNum (insQueryP1, args) = do conflictCtxM <- mapM extractConflictCtx conflictClauseP1 setConflictCtx conflictCtxM @@ -295,7 +296,7 @@ setConflictCtx conflictCtxM = do runInsert :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, HasSQLGenCtx m) => InsertQuery - -> m RespBody + -> m EncJSON runInsert q = do res <- convInsQ q role <- userRole <$> askUserInfo diff --git a/server/src-lib/Hasura/RQL/DML/Mutation.hs b/server/src-lib/Hasura/RQL/DML/Mutation.hs index d5af695623a1b..4c3fb33647280 100644 --- a/server/src-lib/Hasura/RQL/DML/Mutation.hs +++ b/server/src-lib/Hasura/RQL/DML/Mutation.hs @@ -8,6 +8,7 @@ where import qualified Data.Sequence as DS import Hasura.Prelude +import Hasura.EncJSON import Hasura.RQL.DML.Internal import Hasura.RQL.DML.Returning import Hasura.RQL.DML.Select @@ -29,20 +30,20 @@ data Mutation , _mStrfyNum :: !Bool } deriving (Show, Eq) -runMutation :: Mutation -> Q.TxE QErr RespBody +runMutation :: Mutation -> Q.TxE QErr EncJSON runMutation mut = bool (mutateAndReturn mut) (mutateAndSel mut) $ hasNestedFld $ _mFields mut -mutateAndReturn :: Mutation -> Q.TxE QErr RespBody +mutateAndReturn :: Mutation -> Q.TxE QErr EncJSON mutateAndReturn (Mutation qt (cte, p) mutFlds _ strfyNum) = - runIdentity . Q.getRow + encJFromBS . runIdentity . Q.getRow <$> Q.rawQE dmlTxErrorHandler (Q.fromBuilder $ toSQL selWith) (toList p) True where selWith = mkSelWith qt cte mutFlds False strfyNum -mutateAndSel :: Mutation -> Q.TxE QErr RespBody +mutateAndSel :: Mutation -> Q.TxE QErr EncJSON mutateAndSel (Mutation qt q mutFlds mUniqCols strfyNum) = do uniqCols <- onNothing mUniqCols $ throw500 "uniqCols not found in mutateAndSel" @@ -60,7 +61,7 @@ mutateAndSel (Mutation qt q mutFlds mUniqCols strfyNum) = do } selWith = mkSelWith qt selCTE mutFlds False strfyNum -- Perform select query and fetch returning fields - runIdentity . Q.getRow + encJFromBS . runIdentity . Q.getRow <$> Q.rawQE dmlTxErrorHandler (Q.fromBuilder $ toSQL selWith) [] True where colValToColExp colMap colVal = diff --git a/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs b/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs index 3ba5667159bf9..8d1cb5f7d5471 100644 --- a/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs +++ b/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs @@ -3,10 +3,10 @@ module Hasura.RQL.DML.QueryTemplate , runExecQueryTemplate ) where +import Hasura.EncJSON import Hasura.Prelude import Hasura.RQL.DDL.QueryTemplate import Hasura.RQL.DML.Internal -import Hasura.RQL.DML.Returning (encodeJSONVector) import Hasura.RQL.GBoolExp (txtRHSBuilder) import Hasura.RQL.Instances () import Hasura.RQL.Types @@ -26,10 +26,8 @@ import Data.Aeson.Types import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift) -import qualified Data.ByteString.Builder as BB import qualified Data.HashMap.Strict as M import qualified Data.Sequence as DS -import qualified Data.Vector as V type TemplateArgs = M.HashMap TemplateParam Value @@ -122,7 +120,7 @@ execQueryTemplateP1 (ExecQueryTemplate qtn args) = do execQueryTP2 :: (QErrM m, CacheRM m, MonadTx m, HasSQLGenCtx m) - => QueryTProc -> m RespBody + => QueryTProc -> m EncJSON execQueryTP2 qtProc = do strfyNum <- stringifyNum <$> askSQLGenCtx case qtProc of @@ -131,15 +129,12 @@ execQueryTP2 qtProc = do QTPUpdate qp -> liftTx $ R.updateQueryToTx strfyNum qp QTPDelete qp -> liftTx $ R.deleteQueryToTx strfyNum qp QTPCount qp -> RC.countQToTx qp - QTPBulk qps -> do - respList <- mapM execQueryTP2 qps - let bsVector = V.fromList respList - return $ BB.toLazyByteString $ encodeJSONVector BB.lazyByteString bsVector + QTPBulk qps -> encJFromList <$> mapM execQueryTP2 qps runExecQueryTemplate :: ( QErrM m, UserInfoM m, CacheRM m , MonadTx m, HasSQLGenCtx m ) - => ExecQueryTemplate -> m RespBody + => ExecQueryTemplate -> m EncJSON runExecQueryTemplate q = execQueryTemplateP1 q >>= execQueryTP2 diff --git a/server/src-lib/Hasura/RQL/DML/Returning.hs b/server/src-lib/Hasura/RQL/DML/Returning.hs index fef9787f1405c..3b5fd16452d27 100644 --- a/server/src-lib/Hasura/RQL/DML/Returning.hs +++ b/server/src-lib/Hasura/RQL/DML/Returning.hs @@ -6,9 +6,7 @@ import Hasura.RQL.DML.Select import Hasura.RQL.Types import Hasura.SQL.Types -import qualified Data.ByteString.Builder as BB import qualified Data.Text as T -import qualified Data.Vector as V import qualified Hasura.SQL.DML as S data MutFld @@ -89,13 +87,6 @@ mkSelWith qt cte mutFlds singleObj strfyNum = flip concatMap mutFlds $ \(k, mutFld) -> [S.SELit k, mkMutFldExp qt singleObj strfyNum mutFld] -encodeJSONVector :: (a -> BB.Builder) -> V.Vector a -> BB.Builder -encodeJSONVector builder xs - | V.null xs = BB.char7 '[' <> BB.char7 ']' - | otherwise = BB.char7 '[' <> builder (V.unsafeHead xs) <> - V.foldr go (BB.char7 ']') (V.unsafeTail xs) - where go v b = BB.char7 ',' <> builder v <> b - checkRetCols :: (UserInfoM m, QErrM m) => FieldInfoMap diff --git a/server/src-lib/Hasura/RQL/DML/Select.hs b/server/src-lib/Hasura/RQL/DML/Select.hs index e41ec2ea32422..a529946d9b5a8 100644 --- a/server/src-lib/Hasura/RQL/DML/Select.hs +++ b/server/src-lib/Hasura/RQL/DML/Select.hs @@ -23,6 +23,7 @@ import Hasura.RQL.DML.Select.Internal import Hasura.RQL.GBoolExp import Hasura.RQL.Types import Hasura.SQL.Types +import Hasura.EncJSON import qualified Database.PG.Query as Q import qualified Hasura.SQL.DML as S @@ -293,25 +294,24 @@ funcQueryTx :: S.FromItem -> QualifiedFunction -> QualifiedTable -> TablePerm -> TableArgs -> Bool -> (Either TableAggFlds AnnFlds, DS.Seq Q.PrepArg) - -> Q.TxE QErr RespBody + -> Q.TxE QErr EncJSON funcQueryTx frmItem fn tn tabPerm tabArgs strfyNum (eSelFlds, p) = - runIdentity . Q.getRow + encJFromBS . runIdentity . Q.getRow <$> Q.rawQE dmlTxErrorHandler (Q.fromBuilder sqlBuilder) (toList p) True where sqlBuilder = toSQL $ mkFuncSelectWith fn tn tabPerm tabArgs strfyNum eSelFlds frmItem -selectAggP2 :: (AnnAggSel, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody +selectAggP2 :: (AnnAggSel, DS.Seq Q.PrepArg) -> Q.TxE QErr EncJSON selectAggP2 (sel, p) = - runIdentity . Q.getRow + encJFromBS . runIdentity . Q.getRow <$> Q.rawQE dmlTxErrorHandler (Q.fromBuilder selectSQL) (toList p) True where selectSQL = toSQL $ mkAggSelect sel --- selectP2 :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m) => (SelectQueryP1, DS.Seq Q.PrepArg) -> m RespBody -selectP2 :: Bool -> (AnnSel, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody +selectP2 :: Bool -> (AnnSel, DS.Seq Q.PrepArg) -> Q.TxE QErr EncJSON selectP2 asSingleObject (sel, p) = - runIdentity . Q.getRow + encJFromBS . runIdentity . Q.getRow <$> Q.rawQE dmlTxErrorHandler (Q.fromBuilder selectSQL) (toList p) True where selectSQL = toSQL $ mkSQLSelect asSingleObject sel @@ -322,12 +322,12 @@ phaseOne phaseOne = liftDMLP1 . convSelectQuery binRHSBuilder -phaseTwo :: (MonadTx m) => (AnnSel, DS.Seq Q.PrepArg) -> m RespBody +phaseTwo :: (MonadTx m) => (AnnSel, DS.Seq Q.PrepArg) -> m EncJSON phaseTwo = liftTx . selectP2 False runSelect :: (QErrM m, UserInfoM m, CacheRWM m, HasSQLGenCtx m, MonadTx m) - => SelectQuery -> m RespBody + => SelectQuery -> m EncJSON runSelect q = phaseOne q >>= phaseTwo diff --git a/server/src-lib/Hasura/RQL/DML/Update.hs b/server/src-lib/Hasura/RQL/DML/Update.hs index 63a4fc77f2c5a..0ca3cfee15c4a 100644 --- a/server/src-lib/Hasura/RQL/DML/Update.hs +++ b/server/src-lib/Hasura/RQL/DML/Update.hs @@ -13,6 +13,7 @@ import Instances.TH.Lift () import qualified Data.HashMap.Strict as M import qualified Data.Sequence as DS +import Hasura.EncJSON import Hasura.Prelude import Hasura.RQL.DML.Internal import Hasura.RQL.DML.Mutation @@ -194,7 +195,7 @@ validateUpdateQuery = liftDMLP1 . validateUpdateQueryWith binRHSBuilder updateQueryToTx - :: Bool -> (UpdateQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody + :: Bool -> (UpdateQueryP1, DS.Seq Q.PrepArg) -> Q.TxE QErr EncJSON updateQueryToTx strfyNum (u, p) = runMutation $ Mutation (uqp1Table u) (updateCTE, p) (uqp1MutFlds u) (uqp1UniqCols u) strfyNum @@ -203,7 +204,7 @@ updateQueryToTx strfyNum (u, p) = runUpdate :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, HasSQLGenCtx m) - => UpdateQuery -> m RespBody + => UpdateQuery -> m EncJSON runUpdate q = do strfyNum <- stringifyNum <$> askSQLGenCtx validateUpdateQuery q >>= liftTx . updateQueryToTx strfyNum diff --git a/server/src-lib/Hasura/RQL/Types.hs b/server/src-lib/Hasura/RQL/Types.hs index a8d488363b998..e96c7e8806514 100644 --- a/server/src-lib/Hasura/RQL/Types.hs +++ b/server/src-lib/Hasura/RQL/Types.hs @@ -11,7 +11,6 @@ module Hasura.RQL.Types , withUserInfo , UserInfoM(..) - , RespBody , successMsg , HasHttpManager (..) @@ -45,6 +44,7 @@ module Hasura.RQL.Types , module R ) where +import Hasura.EncJSON import Hasura.Prelude import Hasura.RQL.Types.BoolExp as R import Hasura.RQL.Types.Common as R @@ -64,7 +64,6 @@ import qualified Database.PG.Query as Q import Data.Aeson import qualified Data.Aeson.Text as AT -import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as M import qualified Data.Text as T import qualified Data.Text.Lazy as LT @@ -76,8 +75,6 @@ getFieldInfoMap getFieldInfoMap tn = fmap tiFieldInfoMap . M.lookup tn . scTables -type RespBody = BL.ByteString - data QCtx = QCtx { qcUserInfo :: !UserInfo @@ -355,7 +352,7 @@ defaultTxErrorHandler txe = let e = err500 PostgresError "postgres query error" in e {qeInternal = Just $ toJSON txe} -successMsg :: BL.ByteString +successMsg :: EncJSON successMsg = "{\"message\":\"success\"}" type HeaderObj = M.HashMap T.Text T.Text diff --git a/server/src-lib/Hasura/RQL/Types/Error.hs b/server/src-lib/Hasura/RQL/Types/Error.hs index 766390d0feaf3..4289d5f68fb23 100644 --- a/server/src-lib/Hasura/RQL/Types/Error.hs +++ b/server/src-lib/Hasura/RQL/Types/Error.hs @@ -20,7 +20,6 @@ module Hasura.RQL.Types.Error -- Aeson helpers , runAesonParser , decodeValue - , decodeFromBS -- Modify error messages , modifyErr @@ -43,7 +42,6 @@ import qualified Database.PG.Query as Q import Hasura.Prelude import Text.Show (Show (..)) -import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Network.HTTP.Types as N @@ -302,6 +300,3 @@ runAesonParser p = decodeValue :: (FromJSON a, QErrM m) => Value -> m a decodeValue = liftIResult . ifromJSON - -decodeFromBS :: (FromJSON a, QErrM m) => BL.ByteString -> m a -decodeFromBS = either (throw500 . T.pack) decodeValue . eitherDecode diff --git a/server/src-lib/Hasura/Server/App.hs b/server/src-lib/Hasura/Server/App.hs index b93073a01ed9c..6e714cac22c05 100644 --- a/server/src-lib/Hasura/Server/App.hs +++ b/server/src-lib/Hasura/Server/App.hs @@ -37,6 +37,7 @@ import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH import qualified Hasura.GraphQL.Transport.WebSocket as WS import qualified Hasura.Logging as L +import Hasura.EncJSON import Hasura.GraphQL.RemoteServer import Hasura.Prelude hiding (get, put) import Hasura.RQL.DDL.Schema.Table @@ -182,7 +183,7 @@ mkSpockAction :: (MonadIO m) => (Bool -> QErr -> Value) -> ServerCtx - -> Handler BL.ByteString + -> Handler EncJSON -> ActionT m () mkSpockAction qErrEncoder serverCtx handler = do req <- request @@ -200,9 +201,11 @@ mkSpockAction qErrEncoder serverCtx handler = do result <- liftIO $ runReaderT (runExceptT handler) handlerState t2 <- liftIO getCurrentTime -- for measuring response time purposes + let resLBS = fmap encJToLBS result + -- log result - logResult (Just userInfo) req reqBody serverCtx result $ Just (t1, t2) - either (qErrToResp $ userRole userInfo == adminRole) resToResp result + logResult (Just userInfo) req reqBody serverCtx resLBS $ Just (t1, t2) + either (qErrToResp $ userRole userInfo == adminRole) resToResp resLBS where logger = scLogger serverCtx @@ -220,7 +223,7 @@ mkSpockAction qErrEncoder serverCtx handler = do uncurry setHeader jsonHeader lazyBytes resp -v1QueryHandler :: RQLQuery -> Handler BL.ByteString +v1QueryHandler :: RQLQuery -> Handler EncJSON v1QueryHandler query = do scRef <- scCacheRef . hcServerCtx <$> ask bool (fst <$> dbAction) (withSCUpdate scRef dbActionReload) $ @@ -250,7 +253,7 @@ v1QueryHandler query = do newSc { scGCtxMap = mergedGCtxMap, scDefaultRemoteGCtx = defGCtx } return (resp, newSc') -v1Alpha1GQHandler :: GH.GraphQLRequest -> Handler BL.ByteString +v1Alpha1GQHandler :: GH.GraphQLRequest -> Handler EncJSON v1Alpha1GQHandler query = do userInfo <- asks hcUser reqBody <- asks hcReqBody @@ -263,7 +266,7 @@ v1Alpha1GQHandler query = do strfyNum <- scStringifyNum . hcServerCtx <$> ask GH.runGQ pool isoL userInfo (SQLGenCtx strfyNum) sc manager reqHeaders query reqBody -gqlExplainHandler :: GE.GQLExplain -> Handler BL.ByteString +gqlExplainHandler :: GE.GQLExplain -> Handler EncJSON gqlExplainHandler query = do onlyAdmin scRef <- scCacheRef . hcServerCtx <$> ask @@ -293,7 +296,7 @@ queryParsers = q <- decodeValue val return $ f q -legacyQueryHandler :: TableName -> T.Text -> Handler BL.ByteString +legacyQueryHandler :: TableName -> T.Text -> Handler EncJSON legacyQueryHandler tn queryType = case M.lookup queryType queryParsers of Just queryParser -> getQueryParser queryParser qt >>= v1QueryHandler diff --git a/server/src-lib/Hasura/Server/Query.hs b/server/src-lib/Hasura/Server/Query.hs index 66b22b7f12fb9..15b7c58398a45 100644 --- a/server/src-lib/Hasura/Server/Query.hs +++ b/server/src-lib/Hasura/Server/Query.hs @@ -5,13 +5,9 @@ import Data.Aeson.Casing import Data.Aeson.TH import Data.Time (UTCTime) import Language.Haskell.TH.Syntax (Lift) - -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Lazy as BL -import qualified Data.Vector as V import qualified Network.HTTP.Client as HTTP - +import Hasura.EncJSON import Hasura.Prelude import Hasura.RQL.DDL.Metadata import Hasura.RQL.DDL.Permission @@ -26,7 +22,6 @@ import Hasura.RQL.DML.Count import Hasura.RQL.DML.Delete import Hasura.RQL.DML.Insert import Hasura.RQL.DML.QueryTemplate -import Hasura.RQL.DML.Returning (encodeJSONVector) import Hasura.RQL.DML.Select import Hasura.RQL.DML.Update import Hasura.RQL.Types @@ -159,7 +154,7 @@ runQuery :: (MonadIO m, MonadError QErr m) => Q.PGPool -> Q.TxIsolation -> InstanceId -> UserInfo -> SchemaCache -> HTTP.Manager - -> Bool -> RQLQuery -> m (BL.ByteString, SchemaCache) + -> Bool -> RQLQuery -> m (EncJSON, SchemaCache) runQuery pool isoL instanceId userInfo sc hMgr strfyNum query = do resE <- liftIO $ runExceptT $ peelRun sc userInfo hMgr strfyNum pool isoL $ runQueryM query @@ -231,14 +226,14 @@ runQueryM , MonadIO m, HasHttpManager m, HasSQLGenCtx m ) => RQLQuery - -> m RespBody + -> m EncJSON runQueryM rq = withPathK "args" $ case rq of - RQAddExistingTableOrView q -> runTrackTableQ q - RQTrackTable q -> runTrackTableQ q - RQUntrackTable q -> runUntrackTableQ q + RQAddExistingTableOrView q -> runTrackTableQ q + RQTrackTable q -> runTrackTableQ q + RQUntrackTable q -> runUntrackTableQ q - RQTrackFunction q -> runTrackFunc q - RQUntrackFunction q -> runUntrackFunc q + RQTrackFunction q -> runTrackFunc q + RQUntrackFunction q -> runUntrackFunc q RQCreateObjectRelationship q -> runCreateObjRel q RQCreateArrayRelationship q -> runCreateArrRel q @@ -246,44 +241,42 @@ runQueryM rq = withPathK "args" $ case rq of RQSetRelationshipComment q -> runSetRelComment q RQRenameRelationship q -> runRenameRel q - RQCreateInsertPermission q -> runCreatePerm q - RQCreateSelectPermission q -> runCreatePerm q - RQCreateUpdatePermission q -> runCreatePerm q - RQCreateDeletePermission q -> runCreatePerm q + RQCreateInsertPermission q -> runCreatePerm q + RQCreateSelectPermission q -> runCreatePerm q + RQCreateUpdatePermission q -> runCreatePerm q + RQCreateDeletePermission q -> runCreatePerm q - RQDropInsertPermission q -> runDropPerm q - RQDropSelectPermission q -> runDropPerm q - RQDropUpdatePermission q -> runDropPerm q - RQDropDeletePermission q -> runDropPerm q - RQSetPermissionComment q -> runSetPermComment q + RQDropInsertPermission q -> runDropPerm q + RQDropSelectPermission q -> runDropPerm q + RQDropUpdatePermission q -> runDropPerm q + RQDropDeletePermission q -> runDropPerm q + RQSetPermissionComment q -> runSetPermComment q - RQInsert q -> runInsert q - RQSelect q -> runSelect q - RQUpdate q -> runUpdate q - RQDelete q -> runDelete q - RQCount q -> runCount q + RQInsert q -> runInsert q + RQSelect q -> runSelect q + RQUpdate q -> runUpdate q + RQDelete q -> runDelete q + RQCount q -> runCount q - RQAddRemoteSchema q -> runAddRemoteSchema q - RQRemoveRemoteSchema q -> runRemoveRemoteSchema q + RQAddRemoteSchema q -> runAddRemoteSchema q + RQRemoveRemoteSchema q -> runRemoveRemoteSchema q - RQCreateEventTrigger q -> runCreateEventTriggerQuery q - RQDeleteEventTrigger q -> runDeleteEventTriggerQuery q - RQDeliverEvent q -> runDeliverEvent q + RQCreateEventTrigger q -> runCreateEventTriggerQuery q + RQDeleteEventTrigger q -> runDeleteEventTriggerQuery q + RQDeliverEvent q -> runDeliverEvent q - RQCreateQueryTemplate q -> runCreateQueryTemplate q - RQDropQueryTemplate q -> runDropQueryTemplate q - RQExecuteQueryTemplate q -> runExecQueryTemplate q - RQSetQueryTemplateComment q -> runSetQueryTemplateComment q + RQCreateQueryTemplate q -> runCreateQueryTemplate q + RQDropQueryTemplate q -> runDropQueryTemplate q + RQExecuteQueryTemplate q -> runExecQueryTemplate q + RQSetQueryTemplateComment q -> runSetQueryTemplateComment q - RQReplaceMetadata q -> runReplaceMetadata q - RQClearMetadata q -> runClearMetadata q - RQExportMetadata q -> runExportMetadata q - RQReloadMetadata q -> runReloadMetadata q + RQReplaceMetadata q -> runReplaceMetadata q + RQClearMetadata q -> runClearMetadata q + RQExportMetadata q -> runExportMetadata q + RQReloadMetadata q -> runReloadMetadata q - RQDumpInternalState q -> runDumpInternalState q + RQDumpInternalState q -> runDumpInternalState q - RQRunSql q -> runRunSQL q + RQRunSql q -> runRunSQL q - RQBulk qs -> do - respVector <- V.fromList <$> indexedMapM runQueryM qs - return $ BB.toLazyByteString $ encodeJSONVector BB.lazyByteString respVector + RQBulk qs -> encJFromList <$> indexedMapM runQueryM qs