module Hasura.GraphQL.RemoteServer where import Control.Exception (try) import Control.Lens ((^.)) import Data.Aeson ((.:), (.:?)) import Data.FileEmbed (embedStringFile) import Data.Foldable (foldlM) import Hasura.Prelude import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as BL import qualified Data.CaseInsensitive as CI import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Language.GraphQL.Draft.Syntax as G import qualified Language.GraphQL.Draft.Parser as G import qualified Network.HTTP.Client as HTTP import qualified Network.Wreq as Wreq import Hasura.HTTP (wreqOptions) import Hasura.RQL.DDL.Headers (getHeadersFromConf) import Hasura.RQL.Types import qualified Hasura.GraphQL.Schema as GS import qualified Hasura.GraphQL.Validate.Types as VT introspectionQuery :: BL.ByteString introspectionQuery = $(embedStringFile "src-rsr/introspection.json") fetchRemoteSchema :: (MonadIO m, MonadError QErr m) => HTTP.Manager -> RemoteSchemaName -> RemoteSchemaInfo -> m GS.RemoteGCtx fetchRemoteSchema manager name def@(RemoteSchemaInfo url headerConf _) = do headers <- getHeadersFromConf headerConf let hdrs = map (\(hn, hv) -> (CI.mk . T.encodeUtf8 $ hn, T.encodeUtf8 hv)) headers options = wreqOptions manager hdrs res <- liftIO $ try $ Wreq.postWith options (show url) introspectionQuery resp <- either throwHttpErr return res let respData = resp ^. Wreq.responseBody statusCode = resp ^. Wreq.responseStatus . Wreq.statusCode when (statusCode /= 200) $ schemaErr respData introspectRes :: (FromIntrospection IntrospectionResult) <- either schemaErr return $ J.eitherDecode respData let (sDoc, qRootN, mRootN, sRootN) = fromIntrospection introspectRes typMap <- either remoteSchemaErr return $ VT.fromSchemaDoc sDoc $ VT.RemoteType name def let mQrTyp = Map.lookup qRootN typMap mMrTyp = maybe Nothing (\mr -> Map.lookup mr typMap) mRootN mSrTyp = maybe Nothing (\sr -> Map.lookup sr typMap) sRootN qrTyp <- liftMaybe noQueryRoot mQrTyp let mRmQR = VT.getObjTyM qrTyp mRmMR = join $ VT.getObjTyM <$> mMrTyp mRmSR = join $ VT.getObjTyM <$> mSrTyp rmQR <- liftMaybe (err400 Unexpected "query root has to be an object type") mRmQR return $ GS.RemoteGCtx typMap rmQR mRmMR mRmSR where noQueryRoot = err400 Unexpected "query root not found in remote schema" remoteSchemaErr :: (MonadError QErr m) => T.Text -> m a remoteSchemaErr = throw400 RemoteSchemaError schemaErr err = remoteSchemaErr (T.pack $ show err) throwHttpErr :: (MonadError QErr m) => HTTP.HttpException -> m a throwHttpErr = schemaErr mergeSchemas :: (MonadIO m, MonadError QErr m) => RemoteSchemaMap -> GS.GCtxMap -> HTTP.Manager -> m (GS.GCtxMap, GS.GCtx) -- the merged GCtxMap and the default GCtx without roles mergeSchemas rmSchemaMap gCtxMap httpManager = do remoteSchemas <- forM (Map.toList rmSchemaMap) $ \(name, def) -> fetchRemoteSchema httpManager name def def <- mkDefaultRemoteGCtx remoteSchemas merged <- mergeRemoteSchema gCtxMap def return (merged, def) mkDefaultRemoteGCtx :: (MonadError QErr m) => [GS.RemoteGCtx] -> m GS.GCtx mkDefaultRemoteGCtx = foldlM (\combG -> mergeGCtx combG . convRemoteGCtx) GS.emptyGCtx -- merge a remote schema `gCtx` into current `gCtxMap` mergeRemoteSchema :: (MonadError QErr m) => GS.GCtxMap -> GS.GCtx -> m GS.GCtxMap mergeRemoteSchema ctxMap mergedRemoteGCtx = do res <- forM (Map.toList ctxMap) $ \(role, gCtx) -> do updatedGCtx <- mergeGCtx gCtx mergedRemoteGCtx return (role, updatedGCtx) return $ Map.fromList res mergeGCtx :: (MonadError QErr m) => GS.GCtx -> GS.GCtx -> m GS.GCtx mergeGCtx gCtx rmMergedGCtx = do let rmTypes = GS._gTypes rmMergedGCtx hsraTyMap = GS._gTypes gCtx GS.checkSchemaConflicts gCtx rmMergedGCtx let newQR = mergeQueryRoot gCtx rmMergedGCtx newMR = mergeMutRoot gCtx rmMergedGCtx newSR = mergeSubRoot gCtx rmMergedGCtx newTyMap = mergeTyMaps hsraTyMap rmTypes newQR newMR updatedGCtx = gCtx { GS._gTypes = newTyMap , GS._gQueryRoot = newQR , GS._gMutRoot = newMR , GS._gSubRoot = newSR } return updatedGCtx convRemoteGCtx :: GS.RemoteGCtx -> GS.GCtx convRemoteGCtx rmGCtx = GS.emptyGCtx { GS._gTypes = GS._rgTypes rmGCtx , GS._gQueryRoot = GS._rgQueryRoot rmGCtx , GS._gMutRoot = GS._rgMutationRoot rmGCtx , GS._gSubRoot = GS._rgSubscriptionRoot rmGCtx } mergeQueryRoot :: GS.GCtx -> GS.GCtx -> VT.ObjTyInfo mergeQueryRoot a b = GS._gQueryRoot a <> GS._gQueryRoot b mergeMutRoot :: GS.GCtx -> GS.GCtx -> Maybe VT.ObjTyInfo mergeMutRoot a b = let objA' = fromMaybe mempty $ GS._gMutRoot a objB = fromMaybe mempty $ GS._gMutRoot b objA = newRootOrEmpty objA' objB merged = objA <> objB in bool (Just merged) Nothing $ merged == mempty where newRootOrEmpty x y = if x == mempty && y /= mempty then mkNewEmptyMutRoot else x mkNewEmptyMutRoot :: VT.ObjTyInfo mkNewEmptyMutRoot = VT.ObjTyInfo (Just "mutation root") (G.NamedType "mutation_root") Set.empty Map.empty mkNewMutRoot :: VT.ObjFieldMap -> VT.ObjTyInfo mkNewMutRoot flds = VT.ObjTyInfo (Just "mutation root") (G.NamedType "mutation_root") Set.empty flds mergeSubRoot :: GS.GCtx -> GS.GCtx -> Maybe VT.ObjTyInfo mergeSubRoot a b = let objA' = fromMaybe mempty $ GS._gSubRoot a objB = fromMaybe mempty $ GS._gSubRoot b objA = newRootOrEmpty objA' objB merged = objA <> objB in bool (Just merged) Nothing $ merged == mempty where newRootOrEmpty x y = if x == mempty && y /= mempty then mkNewEmptySubRoot else x mkNewEmptySubRoot :: VT.ObjTyInfo mkNewEmptySubRoot = VT.ObjTyInfo (Just "subscription root") (G.NamedType "subscription_root") Set.empty Map.empty mergeTyMaps :: VT.TypeMap -> VT.TypeMap -> VT.ObjTyInfo -> Maybe VT.ObjTyInfo -> VT.TypeMap mergeTyMaps hTyMap rmTyMap newQR newMR = let newTyMap = hTyMap <> rmTyMap newTyMap' = Map.insert (G.NamedType "query_root") (VT.TIObj newQR) $ newTyMap in maybe newTyMap' (\mr -> Map.insert (G.NamedType "mutation_root") (VT.TIObj mr) newTyMap') newMR -- parsing the introspection query result newtype FromIntrospection a = FromIntrospection { fromIntrospection :: a } deriving (Show, Eq, Generic) pErr :: (Monad m) => Text -> m a pErr = fail . T.unpack kindErr :: (Monad m) => Text -> Text -> m a kindErr gKind eKind = pErr $ "Invalid `kind: " <> gKind <> "` in " <> eKind instance J.FromJSON (FromIntrospection G.Description) where parseJSON = fmap (FromIntrospection . G.Description) . J.parseJSON instance J.FromJSON (FromIntrospection G.ScalarTypeDefinition) where parseJSON = J.withObject "ScalarTypeDefinition" $ \o -> do kind <- o .: "kind" name <- o .: "name" desc <- o .:? "description" when (kind /= "SCALAR") $ kindErr kind "scalar" let desc' = fmap fromIntrospection desc r = G.ScalarTypeDefinition desc' name [] return $ FromIntrospection r instance J.FromJSON (FromIntrospection G.ObjectTypeDefinition) where parseJSON = J.withObject "ObjectTypeDefinition" $ \o -> do kind <- o .: "kind" name <- o .: "name" desc <- o .:? "description" fields <- o .:? "fields" interfaces <- o .:? "interfaces" when (kind /= "OBJECT") $ kindErr kind "object" let implIfaces = map (G.NamedType . G._itdName) $ maybe [] (fmap fromIntrospection) interfaces flds = maybe [] (fmap fromIntrospection) fields desc' = fmap fromIntrospection desc r = G.ObjectTypeDefinition desc' name implIfaces [] flds return $ FromIntrospection r instance J.FromJSON (FromIntrospection G.FieldDefinition) where parseJSON = J.withObject "FieldDefinition" $ \o -> do name <- o .: "name" desc <- o .:? "description" args <- o .: "args" _type <- o .: "type" let desc' = fmap fromIntrospection desc r = G.FieldDefinition desc' name (fmap fromIntrospection args) (fromIntrospection _type) [] return $ FromIntrospection r instance J.FromJSON (FromIntrospection G.GType) where parseJSON = J.withObject "GType" $ \o -> do kind <- o .: "kind" mName <- o .:? "name" mType <- o .:? "ofType" r <- case (kind, mName, mType) of ("NON_NULL", _, Just typ) -> return $ mkNotNull (fromIntrospection typ) ("NON_NULL", _, Nothing) -> pErr "NON_NULL should have `ofType`" ("LIST", _, Just typ) -> return $ G.TypeList (G.Nullability True) (G.ListType $ fromIntrospection typ) ("LIST", _, Nothing) -> pErr "LIST should have `ofType`" (_, Just name, _) -> return $ G.TypeNamed (G.Nullability True) name _ -> pErr $ "kind: " <> kind <> " should have name" return $ FromIntrospection r where mkNotNull typ = case typ of G.TypeList _ ty -> G.TypeList (G.Nullability False) ty G.TypeNamed _ n -> G.TypeNamed (G.Nullability False) n instance J.FromJSON (FromIntrospection G.InputValueDefinition) where parseJSON = J.withObject "InputValueDefinition" $ \o -> do name <- o .: "name" desc <- o .:? "description" _type <- o .: "type" defVal <- o .:? "defaultValue" let desc' = fmap fromIntrospection desc let defVal' = fmap fromIntrospection defVal r = G.InputValueDefinition desc' name (fromIntrospection _type) defVal' return $ FromIntrospection r instance J.FromJSON (FromIntrospection G.ValueConst) where parseJSON = J.withText "defaultValue" $ \t -> fmap FromIntrospection $ either (fail . T.unpack) return $ G.parseValueConst t -- instance J.FromJSON (FromIntrospection G.ListType) where -- parseJSON = parseJSON -- instance (J.FromJSON (G.ObjectFieldG a)) => -- J.FromJSON (FromIntrospection (G.ObjectValueG a)) where -- parseJSON = fmap (FromIntrospection . G.ObjectValueG) . J.parseJSON -- instance (J.FromJSON a) => J.FromJSON (FromIntrospection (G.ObjectFieldG a)) where -- parseJSON = J.withObject "ObjectValueG a" $ \o -> do -- name <- o .: "name" -- ofVal <- o .: "value" -- return $ FromIntrospection $ G.ObjectFieldG name ofVal -- instance J.FromJSON (FromIntrospection G.Value) where -- parseJSON = -- fmap FromIntrospection . -- $(J.mkParseJSON J.defaultOptions{J.sumEncoding=J.UntaggedValue} ''G.Value) -- $(J.deriveFromJSON J.defaultOptions{J.sumEncoding=J.UntaggedValue} ''G.Value) instance J.FromJSON (FromIntrospection G.InterfaceTypeDefinition) where parseJSON = J.withObject "InterfaceTypeDefinition" $ \o -> do kind <- o .: "kind" name <- o .: "name" desc <- o .:? "description" fields <- o .:? "fields" let flds = maybe [] (fmap fromIntrospection) fields desc' = fmap fromIntrospection desc when (kind /= "INTERFACE") $ kindErr kind "interface" let r = G.InterfaceTypeDefinition desc' name [] flds return $ FromIntrospection r instance J.FromJSON (FromIntrospection G.UnionTypeDefinition) where parseJSON = J.withObject "UnionTypeDefinition" $ \o -> do kind <- o .: "kind" name <- o .: "name" desc <- o .:? "description" possibleTypes <- o .: "possibleTypes" let memberTys = map (G.NamedType . G._otdName) $ fmap fromIntrospection possibleTypes desc' = fmap fromIntrospection desc when (kind /= "UNION") $ kindErr kind "union" let r = G.UnionTypeDefinition desc' name [] memberTys return $ FromIntrospection r instance J.FromJSON (FromIntrospection G.EnumTypeDefinition) where parseJSON = J.withObject "EnumTypeDefinition" $ \o -> do kind <- o .: "kind" name <- o .: "name" desc <- o .:? "description" vals <- o .: "enumValues" when (kind /= "ENUM") $ kindErr kind "enum" let desc' = fmap fromIntrospection desc let r = G.EnumTypeDefinition desc' name [] (fmap fromIntrospection vals) return $ FromIntrospection r instance J.FromJSON (FromIntrospection G.EnumValueDefinition) where parseJSON = J.withObject "EnumValueDefinition" $ \o -> do name <- o .: "name" desc <- o .:? "description" let desc' = fmap fromIntrospection desc let r = G.EnumValueDefinition desc' name [] return $ FromIntrospection r instance J.FromJSON (FromIntrospection G.InputObjectTypeDefinition) where parseJSON = J.withObject "InputObjectTypeDefinition" $ \o -> do kind <- o .: "kind" name <- o .: "name" desc <- o .:? "description" mInputFields <- o .:? "inputFields" let inputFields = maybe [] (fmap fromIntrospection) mInputFields let desc' = fmap fromIntrospection desc when (kind /= "INPUT_OBJECT") $ kindErr kind "input_object" let r = G.InputObjectTypeDefinition desc' name [] inputFields return $ FromIntrospection r instance J.FromJSON (FromIntrospection G.TypeDefinition) where parseJSON = J.withObject "TypeDefinition" $ \o -> do kind :: Text <- o .: "kind" r <- case kind of "SCALAR" -> G.TypeDefinitionScalar . fromIntrospection <$> J.parseJSON (J.Object o) "OBJECT" -> G.TypeDefinitionObject . fromIntrospection <$> J.parseJSON (J.Object o) "INTERFACE" -> G.TypeDefinitionInterface . fromIntrospection <$> J.parseJSON (J.Object o) "UNION" -> G.TypeDefinitionUnion . fromIntrospection <$> J.parseJSON (J.Object o) "ENUM" -> G.TypeDefinitionEnum . fromIntrospection <$> J.parseJSON (J.Object o) "INPUT_OBJECT" -> G.TypeDefinitionInputObject . fromIntrospection <$> J.parseJSON (J.Object o) _ -> pErr $ "unknown kind: " <> kind return $ FromIntrospection r type IntrospectionResult = ( G.SchemaDocument , G.NamedType , Maybe G.NamedType , Maybe G.NamedType ) instance J.FromJSON (FromIntrospection IntrospectionResult) where parseJSON = J.withObject "SchemaDocument" $ \o -> do _data <- o .: "data" schema <- _data .: "__schema" -- the list of types types <- schema .: "types" -- query root queryType <- schema .: "queryType" queryRoot <- queryType .: "name" -- mutation root mMutationType <- schema .:? "mutationType" mutationRoot <- case mMutationType of Nothing -> return Nothing Just mutType -> do mutRoot <- mutType .: "name" return $ Just mutRoot -- subscription root mSubsType <- schema .:? "subscriptionType" subsRoot <- case mSubsType of Nothing -> return Nothing Just subsType -> do subRoot <- subsType .: "name" return $ Just subRoot let r = ( G.SchemaDocument (fmap fromIntrospection types) , queryRoot , mutationRoot , subsRoot ) return $ FromIntrospection r getNamedTyp :: G.TypeDefinition -> G.Name getNamedTyp ty = case ty of G.TypeDefinitionScalar t -> G._stdName t G.TypeDefinitionObject t -> G._otdName t G.TypeDefinitionInterface t -> G._itdName t G.TypeDefinitionUnion t -> G._utdName t G.TypeDefinitionEnum t -> G._etdName t G.TypeDefinitionInputObject t -> G._iotdName t