hasura · 0x777 · Mar 18, 2019 · Jan 9, 2019
@@ -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

@@ -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

@@ -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
@@ -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

@@ -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)
@@ -34,14 +34,14 @@ 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
 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

@@ -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
 

@@ -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