hasura · 0x777 · Jun 4, 2019 · Feb 25, 2019 · Feb 25, 2019 · Feb 26, 2019
@@ -169,6 +169,13 @@ will selected.
    ``x-hasura-admin-secret`` is sent, then all ``x-hasura-*`` values from the
    client are respected, otherwise they are ignored.
 
+Cookie header from your remote GraphQL servers
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+``Set-Cookie`` headers from your remote schema servers are sent back to the
+client over HTTP transport. **Over websocket transport there exists no means 
+to send headers after a query/mutation and hence ``Set-Cookie`` headers are 
+not sent to the client.** Use HTTP transport if your remote servers set cookies. 
+
 
 Bypassing Hasura's authorization system for remote schema queries
 -----------------------------------------------------------------

@@ -155,6 +155,7 @@ library
                      , Hasura.Server.Auth
                      , Hasura.Server.Auth.JWT
                      , Hasura.Server.Init
+                     , Hasura.Server.Context
                      , Hasura.Server.Middleware
                      , Hasura.Server.Logging
                      , Hasura.Server.Query

@@ -41,7 +41,9 @@ import           Hasura.HTTP
 import           Hasura.Prelude
 import           Hasura.RQL.DDL.Headers
 import           Hasura.RQL.Types
-import           Hasura.Server.Utils                    (bsToTxt, commonClientHeadersIgnored)
+import           Hasura.Server.Context
+import           Hasura.Server.Utils                    (bsToTxt,
+                                                         filterRequestHeaders)
 
 import qualified Hasura.GraphQL.Execute.LiveQuery       as EL
 import qualified Hasura.GraphQL.Execute.Plan            as EP
@@ -333,7 +335,7 @@ execRemoteGQ
   -- ^ the raw request string
   -> RemoteSchemaInfo
   -> G.TypedOperationDefinition
-  -> m EncJSON
+  -> m (HttpResponse EncJSON)
 execRemoteGQ manager userInfo reqHdrs q rsi opDef = do
   let opTy = G._todType opDef
   when (opTy == G.OperationTypeSubscription) $
@@ -352,7 +354,9 @@ execRemoteGQ manager userInfo reqHdrs q rsi opDef = do
 
   res  <- liftIO $ try $ Wreq.postWith options (show url) q
   resp <- either httpThrow return res
-  return $ encJFromLBS $ resp ^. Wreq.responseBody
+  let cookieHdr = getCookieHdr (resp ^? Wreq.responseHeader "Set-Cookie")
+      respHdrs  = Just $ mkRespHeaders cookieHdr
+  return $ HttpResponse (encJFromLBS $ resp ^. Wreq.responseBody) respHdrs
 
   where
     RemoteSchemaInfo url hdrConf fwdClientHdrs = rsi
@@ -361,10 +365,14 @@ execRemoteGQ manager userInfo reqHdrs q rsi opDef = do
 
     userInfoToHdrs = map (\(k, v) -> (CI.mk $ CS.cs k, CS.cs v)) $
                      userInfoToList userInfo
-    filteredHeaders = filterUserVars $ flip filter reqHdrs $ \(n, _) ->
-      n `notElem` commonClientHeadersIgnored
+    filteredHeaders = filterUserVars $ filterRequestHeaders reqHdrs
 
     filterUserVars hdrs =
       let txHdrs = map (\(n, v) -> (bsToTxt $ CI.original n, bsToTxt v)) hdrs
       in map (\(k, v) -> (CI.mk $ CS.cs k, CS.cs v)) $
          filter (not . isUserVar . fst) txHdrs
+
+    getCookieHdr = maybe [] (\h -> [("Set-Cookie", h)])
+
+    mkRespHeaders hdrs =
+      map (\(k, v) -> Header (bsToTxt $ CI.original k, bsToTxt v)) hdrs
@@ -10,6 +10,7 @@ import           Hasura.EncJSON
 import           Hasura.GraphQL.Transport.HTTP.Protocol
 import           Hasura.Prelude
 import           Hasura.RQL.Types
+import           Hasura.Server.Context
 
 import qualified Hasura.GraphQL.Execute                 as E
 
@@ -26,14 +27,14 @@ runGQ
   -> [N.Header]
   -> GQLReqUnparsed
   -> BL.ByteString -- this can be removed when we have a pretty-printer
-  -> m EncJSON
+  -> m (HttpResponse EncJSON)
 runGQ pgExecCtx userInfo sqlGenCtx enableAL planCache sc scVer
   manager reqHdrs req rawReq = do
   execPlan <- E.getResolvedExecPlan pgExecCtx planCache
               userInfo sqlGenCtx enableAL sc scVer req
   case execPlan of
     E.GExPHasura resolvedOp ->
-      runHasuraGQ pgExecCtx userInfo resolvedOp
+      flip HttpResponse Nothing <$> runHasuraGQ pgExecCtx userInfo resolvedOp
     E.GExPRemote rsi opDef  ->
       E.execRemoteGQ manager userInfo reqHdrs rawReq rsi opDef
 

@@ -11,6 +11,7 @@ import qualified Control.Concurrent.STM                      as STM
 import qualified Data.Aeson                                  as J
 import qualified Data.Aeson.Casing                           as J
 import qualified Data.Aeson.TH                               as J
+import qualified Data.ByteString                             as B
 import qualified Data.ByteString.Lazy                        as BL
 import qualified Data.CaseInsensitive                        as CI
 import qualified Data.HashMap.Strict                         as Map
@@ -26,7 +27,6 @@ import qualified Network.WebSockets                          as WS
 import qualified StmContainers.Map                           as STMMap
 
 import           Control.Concurrent                          (threadDelay)
-import           Data.ByteString                             (ByteString)
 
 import           Hasura.EncJSON
 import qualified Hasura.GraphQL.Execute                      as E
@@ -39,6 +39,7 @@ import           Hasura.Prelude
 import           Hasura.RQL.Types
 import           Hasura.RQL.Types.Error                      (Code (StartFailed))
 import           Hasura.Server.Auth                          (AuthMode, getUserInfoWithExpTime)
+import           Hasura.Server.Context
 import           Hasura.Server.Cors
 import           Hasura.Server.Utils                         (bsToTxt,
                                                               diffTimeToMicro)
@@ -187,7 +188,7 @@ onConn (L.Logger logger) corsPolicy wsId requestHead = do
     getOrigin =
       find ((==) "Origin" . fst) (WS.requestHeaders requestHead)
 
-    enforceCors :: ByteString -> [H.Header] -> ExceptT QErr IO [H.Header]
+    enforceCors :: B.ByteString -> [H.Header] -> ExceptT QErr IO [H.Header]
     enforceCors origin reqHdrs = case cpConfig corsPolicy of
       CCAllowAll -> return reqHdrs
       CCDisabled readCookie ->
@@ -285,7 +286,7 @@ onStart serverEnv wsConn (StartMsg opId q) msgRaw = catchAndIgnore $ do
       let payload = J.encode $ _wpPayload sockPayload
       resp <- runExceptT $ E.execRemoteGQ httpMgr userInfo reqHdrs
               payload rsi opDef
-      either postExecErr sendRemoteResp resp
+      either postExecErr (sendRemoteResp . _hrBody) resp
       sendCompleted
 
     sendRemoteResp resp =

@@ -49,6 +49,7 @@ import           Hasura.RQL.DML.QueryTemplate
 import           Hasura.RQL.Types
 import           Hasura.Server.Auth                     (AuthMode (..),
                                                          getUserInfo)
+import           Hasura.Server.Context
 import           Hasura.Server.Cors
 import           Hasura.Server.Init
 import           Hasura.Server.Logging
@@ -132,15 +133,15 @@ data HandlerCtx
 type Handler = ExceptT QErr (ReaderT HandlerCtx IO)
 
 data APIResp
-  = JSONResp !EncJSON
-  | RawResp ![(Text,Text)] !BL.ByteString -- headers, body
+  = JSONResp !(HttpResponse EncJSON)
+  | RawResp !(HttpResponse BL.ByteString) -- headers, body
 
 apiRespToLBS :: APIResp -> BL.ByteString
 apiRespToLBS = \case
-  JSONResp j  -> encJToLBS j
-  RawResp _ b -> b
+  JSONResp (HttpResponse j _) -> encJToLBS j
+  RawResp (HttpResponse b _)  -> b
 
-mkAPIRespHandler :: Handler EncJSON -> Handler APIResp
+mkAPIRespHandler :: Handler (HttpResponse EncJSON) -> Handler APIResp
 mkAPIRespHandler = fmap JSONResp
 
 isMetadataEnabled :: ServerCtx -> Bool
@@ -192,6 +193,7 @@ logError
 logError userInfoM req reqBody logger qErr =
   logResult userInfoM req reqBody logger (Left qErr) Nothing
 
+
 mkSpockAction
   :: (MonadIO m)
   => (Bool -> QErr -> Value)
@@ -219,7 +221,8 @@ mkSpockAction qErrEncoder qErrModifier serverCtx handler = do
   let modResult = fmapL qErrModifier result
 
   -- log result
-  logResult (Just userInfo) req reqBody logger (apiRespToLBS <$> modResult) $ Just (t1, t2)
+  logResult (Just userInfo) req reqBody logger (apiRespToLBS <$> modResult) $
+    Just (t1, t2)
   either (qErrToResp $ userRole userInfo == adminRole) resToResp modResult
 
   where
@@ -235,19 +238,21 @@ mkSpockAction qErrEncoder qErrModifier serverCtx handler = do
       qErrToResp includeInternal qErr
 
     resToResp = \case
-      JSONResp j -> do
+      JSONResp (HttpResponse j h) -> do
         uncurry setHeader jsonHeader
+        mapM_ (mapM_ (uncurry setHeader . unHeader)) h
         lazyBytes $ encJToLBS j
-      RawResp h b -> do
-        mapM_ (uncurry setHeader) h
+      RawResp (HttpResponse b h) -> do
+        mapM_ (mapM_ (uncurry setHeader . unHeader)) h
         lazyBytes b
 
-v1QueryHandler :: RQLQuery -> Handler EncJSON
+v1QueryHandler :: RQLQuery -> Handler (HttpResponse EncJSON)
 v1QueryHandler query = do
   scRef <- scCacheRef . hcServerCtx <$> ask
   logger <- scLogger . hcServerCtx <$> ask
-  bool (fst <$> dbAction) (withSCUpdate scRef logger dbActionReload) $
-    queryNeedsReload query
+  res <- bool (fst <$> dbAction) (withSCUpdate scRef logger dbActionReload) $
+         queryNeedsReload query
+  return $ HttpResponse res Nothing
   where
     -- Hit postgres
     dbAction = do
@@ -268,7 +273,7 @@ v1QueryHandler query = do
       newSc' <- GS.updateSCWithGCtx newSc >>= flip resolveRemoteSchemas httpMgr
       return (resp, newSc')
 
-v1Alpha1GQHandler :: GH.GQLReqUnparsed -> Handler EncJSON
+v1Alpha1GQHandler :: GH.GQLReqUnparsed -> Handler (HttpResponse EncJSON)
 v1Alpha1GQHandler query = do
   userInfo <- asks hcUser
   reqBody <- asks hcReqBody
@@ -283,25 +288,26 @@ v1Alpha1GQHandler query = do
   GH.runGQ pgExecCtx userInfo sqlGenCtx enableAL planCache
     sc scVer manager reqHeaders query reqBody
 
-v1GQHandler :: GH.GQLReqUnparsed -> Handler EncJSON
+v1GQHandler :: GH.GQLReqUnparsed -> Handler (HttpResponse EncJSON)
 v1GQHandler = v1Alpha1GQHandler
 
-gqlExplainHandler :: GE.GQLExplain -> Handler EncJSON
+gqlExplainHandler :: GE.GQLExplain -> Handler (HttpResponse EncJSON)
 gqlExplainHandler query = do
   onlyAdmin
   scRef <- scCacheRef . hcServerCtx <$> ask
   sc <- fmap fst $ liftIO $ readIORef $ _scrCache scRef
   pgExecCtx <- scPGExecCtx . hcServerCtx <$> ask
   sqlGenCtx <- scSQLGenCtx . hcServerCtx <$> ask
   enableAL <- scEnableAllowlist . hcServerCtx <$> ask
-  GE.explainGQLQuery pgExecCtx sc sqlGenCtx enableAL query
+  res <- GE.explainGQLQuery pgExecCtx sc sqlGenCtx enableAL query
+  return $ HttpResponse res Nothing
 
 v1Alpha1PGDumpHandler :: PGD.PGDumpReqBody -> Handler APIResp
 v1Alpha1PGDumpHandler b = do
   onlyAdmin
   ci <- scConnInfo . hcServerCtx <$> ask
   output <- PGD.execPGDump b ci
-  return $ RawResp [sqlHeader] output
+  return $ RawResp $ HttpResponse output (Just [Header sqlHeader])
 
 consoleAssetsHandler :: L.Logger -> Text -> FilePath -> ActionT IO ()
 consoleAssetsHandler logger dir path = do
@@ -361,7 +367,7 @@ queryParsers =
       q <- decodeValue val
       return $ f q
 
-legacyQueryHandler :: TableName -> T.Text -> Handler EncJSON
+legacyQueryHandler :: TableName -> T.Text -> Handler (HttpResponse EncJSON)
 legacyQueryHandler tn queryType =
   case M.lookup queryType queryParsers of
     Just queryParser -> getQueryParser queryParser qt >>= v1QueryHandler
@@ -493,17 +499,17 @@ httpApp corsCfg serverCtx enableConsole consoleAssetsDir enableTelemetry = do
         mkAPIRespHandler $ do
           onlyAdmin
           respJ <- liftIO $ E.dumpPlanCache $ scPlanCache serverCtx
-          return $ encJFromJValue respJ
+          return $ HttpResponse (encJFromJValue respJ) Nothing
       get "dev/subscriptions" $ mkSpockAction encodeQErr id serverCtx $
         mkAPIRespHandler $ do
           onlyAdmin
           respJ <- liftIO $ EL.dumpLiveQueriesState False $ scLQState serverCtx
-          return $ encJFromJValue respJ
+          return $ HttpResponse (encJFromJValue respJ) Nothing
       get "dev/subscriptions/extended" $ mkSpockAction encodeQErr id serverCtx $
         mkAPIRespHandler $ do
           onlyAdmin
           respJ <- liftIO $ EL.dumpLiveQueriesState True $ scLQState serverCtx
-          return $ encJFromJValue respJ
+          return $ HttpResponse (encJFromJValue respJ) Nothing
 
     forM_ [GET,POST] $ \m -> hookAny m $ \_ -> do
       let qErr = err404 NotFound "resource does not exist"

@@ -0,0 +1,20 @@
+module Hasura.Server.Context
+  ( HttpResponse(..)
+  , Header (..)
+  , Headers
+  )
+  where
+
+import           Hasura.Prelude
+
+newtype Header
+  = Header { unHeader :: (Text, Text) }
+  deriving (Show, Eq)
+
+type Headers = [Header]
+
+data HttpResponse a
+  = HttpResponse
+  { _hrBody    :: !a
+  , _hrHeaders :: !(Maybe Headers)
+  }
@@ -11,11 +11,13 @@ import           System.Exit
 import           System.Process
 
 import qualified Data.ByteString              as B
+import qualified Data.HashSet                 as Set
 import qualified Data.Text                    as T
 import qualified Data.Text.Encoding           as TE
 import qualified Data.Text.Encoding.Error     as TE
 import qualified Data.Text.IO                 as TI
 import qualified Language.Haskell.TH.Syntax   as TH
+import qualified Network.HTTP.Types           as HTTP
 import qualified Text.Ginger                  as TG
 import qualified Text.Regex.TDFA              as TDFA
 import qualified Text.Regex.TDFA.ByteString   as TDFA
@@ -49,14 +51,6 @@ userIdHeader = "x-hasura-user-id"
 bsToTxt :: B.ByteString -> T.Text
 bsToTxt = TE.decodeUtf8With TE.lenientDecode
 
-commonClientHeadersIgnored :: (IsString a) => [a]
-commonClientHeadersIgnored =
-  [ "Content-Length", "Content-MD5", "User-Agent", "Host"
-  , "Origin", "Referer" , "Accept", "Accept-Encoding"
-  , "Accept-Language", "Accept-Datetime"
-  , "Cache-Control", "Connection", "DNT", "Content-Type"
-  ]
-
 txtToBs :: T.Text -> B.ByteString
 txtToBs = TE.encodeUtf8
 
@@ -171,3 +165,35 @@ diffTimeToMicro diff =
   (floor (realToFrac diff :: Double) - 10) * aSecond
   where
     aSecond = 1000 * 1000
+
+-- ignore the following request headers from the client
+
+commonClientHeadersIgnored :: (IsString a) => [a]
+commonClientHeadersIgnored =
+  [ "Content-Length", "Content-MD5", "User-Agent", "Host"
+  , "Origin", "Referer" , "Accept", "Accept-Encoding"
+  , "Accept-Language", "Accept-Datetime"
+  , "Cache-Control", "Connection", "DNT", "Content-Type"
+  ]
+
+commonResponseHeadersIgnored :: (IsString a) => [a]
+commonResponseHeadersIgnored =
+  [ "Server", "Transfer-Encoding", "Cache-Control"
+  , "Access-Control-Allow-Credentials"
+  , "Access-Control-Allow-Methods"
+  , "Access-Control-Allow-Origin"
+  , "Content-Type", "Content-Length"
+  ]
+
+
+filterRequestHeaders :: [HTTP.Header] -> [HTTP.Header]
+filterRequestHeaders =
+  filterHeaders $ Set.fromList commonClientHeadersIgnored
+
+-- ignore the following response headers from remote
+filterResponseHeaders :: [HTTP.Header] -> [HTTP.Header]
+filterResponseHeaders =
+  filterHeaders $ Set.fromList commonResponseHeadersIgnored
+
+filterHeaders :: Set.HashSet HTTP.HeaderName -> [HTTP.Header] -> [HTTP.Header]
+filterHeaders list = filter (\(n, _) -> not $ n `Set.member` list)