diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright © 2019-2020 47 Degrees. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -0,0 +1,103 @@ +{-# language CPP #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TemplateHaskell #-} +{-# language TupleSections #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Main where + +import Data.Conduit +import Data.Conduit.Combinators (yieldMany) +import Data.List (find) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Proxy +import qualified Data.Text as T +import Text.Regex.TDFA ((=~)) +import Text.Regex.TDFA.Common (fst3, snd3, thd3) + +import Network.Wai.Handler.Warp (run) +import Network.Wai.Middleware.AddHeaders (addHeaders) + +import Mu.GraphQL.Quasi +import Mu.GraphQL.Server +import Mu.Schema +import Mu.Server + +#if __GHCIDE__ +graphql "ServiceDefinition" "graphql/exe/schema.graphql" +#else +graphql "ServiceDefinition" "exe/schema.graphql" +#endif + +-- GraphQL App + +main :: IO () +main = do + putStrLn "starting GraphQL server on port 8000" + let hm = addHeaders [ + ("Access-Control-Allow-Origin", "*") + , ("Access-Control-Allow-Headers", "Content-Type") + ] + run 8000 $ hm $ graphQLApp libraryServer + (Proxy @('Just "Query")) + (Proxy @'Nothing) + (Proxy @('Just "Subscription")) + +type ServiceMapping = '[ + "Book" ':-> (Integer, Integer) + , "Author" ':-> Integer + ] + +library :: [(Integer, T.Text, [(Integer, T.Text)])] +library + = [ (1, "Robert Louis Stevenson", [(1, "Treasure Island"), (2, "Strange Case of Dr Jekyll and Mr Hyde")]) + , (2, "Immanuel Kant", [(3, "Critique of Pure Reason")]) + , (3, "Michael Ende", [(4, "The Neverending Story"), (5, "Momo")]) + ] + +libraryServer :: forall m. (MonadServer m) => ServerT ServiceMapping ServiceDefinition m _ +libraryServer + = resolver ( object @"Book" ( field @"id" bookId + , field @"title" bookTitle + , field @"author" bookAuthor ) + , object @"Author" ( field @"id" authorId + , field @"name" authorName + , field @"books" authorBooks ) + , object @"Query" ( method @"author" findAuthor + , method @"book" findBookTitle + , method @"authors" allAuthors + , method @"books" allBooks' ) + , object @"Subscription" ( method @"books" allBooksConduit ) + ) + where + findBook i = find ((==i) . fst3) library + + bookId (_, bid) = pure bid + bookTitle (aid, bid) = pure $ maybe "" (fromMaybe "" . lookup bid . thd3) (findBook aid) + bookAuthor (aid, _) = pure aid + + authorId = pure + authorName aid = pure $ maybe "" snd3 (findBook aid) + authorBooks aid = pure $ maybe [] (map ((aid,) . fst) . thd3) (findBook aid) + + findAuthor rx = pure $ listToMaybe + [aid | (aid, name, _) <- library, name =~ rx] + + findBookTitle rx = pure $ listToMaybe + [(aid, bid) | (aid, _, books) <- library + , (bid, title) <- books + , title =~ rx] + + allAuthors = pure $ fst3 <$> library + allBooks = [(aid, bid) | (aid, _, books) <- library, (bid, _) <- books] + allBooks' = pure allBooks + + allBooksConduit :: ConduitM (Integer, Integer) Void m () -> m () + allBooksConduit sink = runConduit $ yieldMany allBooks .| sink diff --git a/exe/schema.graphql b/exe/schema.graphql new file mode 100644 --- /dev/null +++ b/exe/schema.graphql @@ -0,0 +1,27 @@ +type Book { + id: Int! + title: String! + author: Author! +} + +type Author { + id: Int! + name: String! + books: [Book!]! +} + +type Query { + author(name: String! = ".*"): Author + book(title: String! = ".*"): Book + authors: [Author!]! + books: [Book!]! +} + +type Subscription { + books: Book! +} + +schema { + query: Query + subscription: Subscription +} diff --git a/mu-graphql.cabal b/mu-graphql.cabal new file mode 100644 --- /dev/null +++ b/mu-graphql.cabal @@ -0,0 +1,80 @@ +name: mu-graphql +version: 0.3.0.0 +synopsis: GraphQL support for Mu +description: GraphQL servers and clients for Mu-Haskell +cabal-version: >=1.10 +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2020 +category: Network +build-type: Simple +homepage: https://higherkindness.io/mu-haskell/ +bug-reports: https://github.com/higherkindness/mu-haskell/issues +data-files: exe/*.graphql + +library + exposed-modules: + Mu.GraphQL.Annotations + Mu.GraphQL.Quasi + Mu.GraphQL.Server + + other-modules: + Mu.GraphQL.Quasi.LostParser + Mu.GraphQL.Query.Definition + Mu.GraphQL.Query.Introspection + Mu.GraphQL.Query.Parse + Mu.GraphQL.Query.Run + Mu.GraphQL.Subscription.Protocol + + -- other-extensions: + build-depends: + aeson + , async + , attoparsec + , base >=4.12 && <5 + , bytestring + , conduit + , graphql-parser + , http-types + , list-t + , mtl + , mu-rpc + , mu-schema + , parsers + , scientific + , sop-core + , stm + , stm-chans + , stm-conduit + , stm-containers + , template-haskell + , text + , unordered-containers + , uuid + , wai + , wai-websockets + , warp + , warp-tls + , websockets + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances + +executable library-graphql + main-is: Main.hs + hs-source-dirs: exe + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.12 && <5 + , conduit + , mu-graphql + , mu-rpc + , mu-schema + , regex-tdfa >=1.3.1.0 + , text + , wai-extra + , warp diff --git a/src/Mu/GraphQL/Annotations.hs b/src/Mu/GraphQL/Annotations.hs new file mode 100644 --- /dev/null +++ b/src/Mu/GraphQL/Annotations.hs @@ -0,0 +1,116 @@ +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TupleSections #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language ViewPatterns #-} +{-| +Description : Annotations for GraphQL services + +GraphQL schemas may contain some information which +cannot be directly represented in a Mu schema or +service definition. The types in this module +can be used with the annotation mechanism in Mu +to provide this additional information. +-} +module Mu.GraphQL.Annotations ( + ValueConst(..) +, DefaultValue +, ReflectValueConst(..) +, fromGQLValueConst +) where + +import Control.Applicative (Alternative (..)) +import Data.Coerce +import Data.Proxy +import qualified Data.Text as T +import GHC.TypeLits +import qualified Language.GraphQL.Draft.Syntax as GQL + +-- | Specifies the default value of an argument. +-- To be used as an annotation. +data DefaultValue (v :: ValueConst Nat Symbol) + +-- | Type-level GraphQL constant values. +-- Due to limitations in type-level literal values +-- floating point constants cannot be represented. +data ValueConst nat symbol + = VCInt nat -- ^ Integer. + | VCString symbol -- ^ String. + | VCBoolean Bool -- ^ Boolean. + | VCNull -- ^ Null. + | VCEnum symbol -- ^ Enumeration value. + | VCList [ValueConst nat symbol] -- ^ List of constant values. + | VCObject [(symbol, ValueConst nat symbol)] + -- ^ Object represented by (key, value) tuples. + +-- | Turn a 'GQL.ValueConst' coming from parsing +-- in the annotation data type. Mostly used +-- internally to generate Mu schemas from GraphQL schemas. +fromGQLValueConst :: forall f. Alternative f + => GQL.ValueConst -> f (ValueConst Integer String) +fromGQLValueConst (GQL.VCInt n) + = pure $ VCInt (fromIntegral n) +fromGQLValueConst (GQL.VCString (coerce -> s)) + = pure $ VCString $ T.unpack s +fromGQLValueConst (GQL.VCBoolean b) + = pure $ VCBoolean b +fromGQLValueConst GQL.VCNull + = pure VCNull +fromGQLValueConst (GQL.VCEnum (coerce -> s)) + = pure $ VCEnum $ T.unpack s +fromGQLValueConst (GQL.VCList (coerce -> xs)) + = VCList <$> traverse fromGQLValueConst xs +fromGQLValueConst (GQL.VCObject (coerce -> o)) + = VCObject <$> traverse fromGQLField o + where fromGQLField :: GQL.ObjectFieldG GQL.ValueConst + -> f (String, ValueConst Integer String) + fromGQLField (GQL.ObjectFieldG (coerce -> n) v) + = (T.unpack n,) <$> fromGQLValueConst v +fromGQLValueConst _ = empty + +-- | Obtain the GraphQL constant corresponding +-- to a type-level constant. Inhabited by any +-- 'ValueConst', but still required to please +-- the type checker. +class ReflectValueConst (v :: ValueConst nat symbol) where + -- | Obtain the GraphQL constant corresponding + -- to a type-level constant. + reflectValueConst :: proxy v -> GQL.ValueConst +instance KnownNat n => ReflectValueConst ('VCInt n) where + reflectValueConst _ = GQL.VCInt $ fromInteger $ natVal (Proxy @n) +instance KnownSymbol s => ReflectValueConst ('VCString s) where + reflectValueConst _ = GQL.VCString $ coerce $ T.pack $ symbolVal (Proxy @s) +instance ReflectValueConst ('VCBoolean 'True) where + reflectValueConst _ = GQL.VCBoolean True +instance ReflectValueConst ('VCBoolean 'False) where + reflectValueConst _ = GQL.VCBoolean False +instance ReflectValueConst 'VCNull where + reflectValueConst _ = GQL.VCNull +instance KnownSymbol e => ReflectValueConst ('VCEnum e) where + reflectValueConst _ = GQL.VCString $ coerce $ T.pack $ symbolVal (Proxy @e) +instance ReflectValueConstList xs => ReflectValueConst ('VCList xs) where + reflectValueConst _ = GQL.VCList $ coerce $ reflectValueConstList (Proxy @xs) +instance ReflectValueConstObject xs => ReflectValueConst ('VCObject xs) where + reflectValueConst _ = GQL.VCObject $ coerce $ reflectValueConstObject (Proxy @xs) + +class ReflectValueConstList xs where + reflectValueConstList :: proxy xs -> [GQL.ValueConst] +instance ReflectValueConstList '[] where + reflectValueConstList _ = [] +instance (ReflectValueConst x, ReflectValueConstList xs) + => ReflectValueConstList (x ': xs) where + reflectValueConstList _ + = reflectValueConst (Proxy @x) : reflectValueConstList (Proxy @xs) + +class ReflectValueConstObject xs where + reflectValueConstObject :: proxy xs -> [GQL.ObjectFieldG GQL.ValueConst] +instance ReflectValueConstObject '[] where + reflectValueConstObject _ = [] +instance (KnownSymbol a, ReflectValueConst x, ReflectValueConstObject xs) + => ReflectValueConstObject ( '(a, x) ': xs) where + reflectValueConstObject _ + = GQL.ObjectFieldG (coerce $ T.pack $ symbolVal (Proxy @a)) (reflectValueConst (Proxy @x)) + : reflectValueConstObject (Proxy @xs) diff --git a/src/Mu/GraphQL/Quasi.hs b/src/Mu/GraphQL/Quasi.hs new file mode 100644 --- /dev/null +++ b/src/Mu/GraphQL/Quasi.hs @@ -0,0 +1,202 @@ +{-# language DataKinds #-} +{-# language OverloadedStrings #-} +{-# language TemplateHaskell #-} +{-# language ViewPatterns #-} +{-| +Description : Quasi-quoters for GraphQL schemas + +Read @.graphql@ files as a 'Mu.Schema.Definition.Schema' +and 'Package' with one 'Service' per object in the schema. +-} +module Mu.GraphQL.Quasi ( + graphql +, graphql' +) where + +import Control.Monad.IO.Class (liftIO) +import Data.Coerce (coerce) +import qualified Data.HashMap.Strict as HM +import Data.List (foldl') +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.UUID (UUID) +import qualified Language.GraphQL.Draft.Syntax as GQL +import Language.Haskell.TH + +import Mu.GraphQL.Annotations +import Mu.GraphQL.Quasi.LostParser (parseTypeSysDefinition) +import Mu.Rpc +import Mu.Schema.Definition + +-- | Imports an GraphQL schema definition from a file. +graphql :: String -- ^ Name for the 'Package' type, the 'Schema' is derived from it + -> FilePath -- ^ Route to the file + -> Q [Dec] +graphql name = graphql' (name <> "Schema") name + +-- | Imports an GraphQL schema definition from a file. +graphql' :: String -- ^ Name for the 'Schema' type + -> String -- ^ Name for the 'Package' type + -> FilePath -- ^ Route to the file + -> Q [Dec] +graphql' scName svName file = do + schema <- liftIO $ TIO.readFile file + case parseTypeSysDefinition schema of + Left e -> fail ("could not parse graphql spec: " ++ show e) + Right p -> graphqlToDecls scName svName p + +type TypeMap = HM.HashMap T.Text GQLType +type SchemaMap = HM.HashMap T.Text GQL.OperationType + +data Result = + GQLScalar + | GQLSchema Type + | GQLService Type + +data GQLType = + Enum + | Object + | Scalar + | InputObject + | Other + +classifySchema :: [GQL.SchemaDefinition] -> SchemaMap +classifySchema = foldl' schemaToMap HM.empty + where + schemaToMap :: SchemaMap -> GQL.SchemaDefinition -> SchemaMap + schemaToMap mp (GQL.SchemaDefinition _ ops) = foldl' operationToKeyValue mp ops + operationToKeyValue :: SchemaMap -> GQL.RootOperationTypeDefinition -> SchemaMap + operationToKeyValue mp (GQL.RootOperationTypeDefinition opType (coerce -> name)) = HM.insert name opType mp + +classify :: [GQL.TypeDefinition] -> TypeMap +classify = HM.fromList . (typeToKeyValue <$>) + where + typeToKeyValue :: GQL.TypeDefinition -> (T.Text, GQLType) + typeToKeyValue (GQL.TypeDefinitionScalar (GQL.ScalarTypeDefinition _ (coerce -> name) _)) = (name, Scalar) + typeToKeyValue (GQL.TypeDefinitionObject (GQL.ObjectTypeDefinition _ (coerce -> name) _ _ _)) = (name, Object) + typeToKeyValue (GQL.TypeDefinitionInterface (GQL.InterfaceTypeDefinition _ (coerce -> name) _ _)) = (name, Other) + typeToKeyValue (GQL.TypeDefinitionUnion (GQL.UnionTypeDefinition _ (coerce -> name) _ _)) = (name, Other) + typeToKeyValue (GQL.TypeDefinitionEnum (GQL.EnumTypeDefinition _ (coerce -> name) _ _)) = (name, Enum) + typeToKeyValue (GQL.TypeDefinitionInputObject (GQL.InputObjectTypeDefinition _ (coerce -> name) _ _)) = (name, InputObject) + +-- | Constructs the GraphQL tree splitting between Schemas and Services. +graphqlToDecls :: String -> String -> [GQL.TypeSystemDefinition] -> Q [Dec] +graphqlToDecls schemaName serviceName allTypes = do + let schemaName' = mkName schemaName + serviceName' = mkName serviceName + types = [t | GQL.TypeSystemDefinitionType t <- allTypes] + schTypes = [t | GQL.TypeSystemDefinitionSchema t <- allTypes] + typeMap = classify types + schMap = classifySchema schTypes + rs <- traverse (typeToDec schemaName' typeMap schMap) types + let schemaTypes = [x | GQLSchema x <- rs] + serviceTypes = [x | GQLService x <- rs] + schemaDec <- tySynD schemaName' [] (pure $ typesToList schemaTypes) + serviceDec <- tySynD serviceName' [] + [t| 'Package ('Just $(textToStrLit $ T.pack serviceName)) + $(pure $ typesToList serviceTypes) |] + pure [schemaDec, serviceDec] + +-- | Reads a GraphQL 'TypeDefinition' and returns a 'Result'. +typeToDec :: Name -> TypeMap -> SchemaMap -> GQL.TypeDefinition -> Q Result +typeToDec schemaName tm _ (GQL.TypeDefinitionScalar (GQL.ScalarTypeDefinition _ s _)) = + GQLScalar <$ gqlTypeToType s tm schemaName +typeToDec schemaName tm sm (GQL.TypeDefinitionObject objs) = objToDec objs + where + objToDec :: GQL.ObjectTypeDefinition -> Q Result + objToDec (GQL.ObjectTypeDefinition _ (coerce -> nm) _ _ flds) = + GQLService <$> [t| 'Service $(textToStrLit nm) '[] + $(typesToList <$> traverse (gqlFieldToType nm) flds) |] + gqlFieldToType :: T.Text -> GQL.FieldDefinition -> Q Type + gqlFieldToType sn (GQL.FieldDefinition _ (coerce -> fnm) args ftyp _) = + [t| 'Method $(textToStrLit fnm) '[] + $(typesToList <$> traverse argToType args) + $(returnType sn ftyp)|] + returnType :: T.Text -> GQL.GType -> Q Type + returnType serviceName typ = + case HM.lookup serviceName sm of + Just GQL.OperationTypeSubscription -> [t|'RetStream $(retToType typ)|] + _ -> [t|'RetSingle $(retToType typ)|] + argToType :: GQL.InputValueDefinition -> Q Type + argToType (GQL.InputValueDefinition _ (coerce -> aname) atype Nothing) = + [t| 'ArgSingle ('Just $(textToStrLit aname)) '[] $(retToType atype) |] + argToType (GQL.InputValueDefinition _ (coerce -> aname) atype (Just defs)) = + [t| 'ArgSingle ('Just $(textToStrLit aname)) + '[DefaultValue $( defToVConst defs )] $(retToType atype) |] + defToVConst :: GQL.DefaultValue -> Q Type + defToVConst (GQL.VCInt _) = [t| 'VCInt |] + defToVConst (GQL.VCFloat _) = fail "floats as default arguments are not supported" + defToVConst (GQL.VCString (coerce -> s)) = [t| 'VCString $(textToStrLit s) |] + defToVConst (GQL.VCBoolean _) = [t| 'VCBoolean|] + defToVConst GQL.VCNull = [t| 'VCNull |] + defToVConst (GQL.VCEnum (coerce -> e)) = [t| 'VCEnum $(textToStrLit e) |] + defToVConst (GQL.VCList (GQL.ListValueG xs)) = [t| 'VCList $(typesToList <$> traverse defToVConst xs) |] + defToVConst (GQL.VCObject (GQL.ObjectValueG obj)) = [t| 'VCObject $(typesToList <$> traverse fromGQLField obj) |] + fromGQLField :: GQL.ObjectFieldG GQL.ValueConst -> Q Type + fromGQLField (GQL.ObjectFieldG (coerce -> n) v) = [t| ($(textToStrLit n), $(defToVConst v)) |] + retToType :: GQL.GType -> Q Type + retToType (GQL.TypeNamed (coerce -> False) (coerce -> a)) = + [t| $(gqlTypeToType a tm schemaName) |] + retToType (GQL.TypeNamed (coerce -> True) (coerce -> a)) = + [t| 'OptionalRef $(gqlTypeToType a tm schemaName) |] + retToType (GQL.TypeList (coerce -> False) (coerce -> a)) = + [t| 'ListRef $(retToType a) |] + retToType (GQL.TypeList (coerce -> True) (coerce -> a)) = + [t| 'OptionalRef ('ListRef $(retToType a)) |] + retToType _ = fail "this should not happen, please, file an issue" +typeToDec _ _ _ (GQL.TypeDefinitionInterface _) = fail "interface types are not supported" +typeToDec _ _ _ (GQL.TypeDefinitionUnion _) = fail "union types are not supported" +typeToDec _ _ _ (GQL.TypeDefinitionEnum enums) = enumToDecl enums + where + enumToDecl :: GQL.EnumTypeDefinition -> Q Result + enumToDecl (GQL.EnumTypeDefinition _ (coerce -> name) _ symbols) = + GQLSchema <$> [t|'DEnum $(textToStrLit name) + $(typesToList <$> traverse gqlChoiceToType symbols)|] + gqlChoiceToType :: GQL.EnumValueDefinition -> Q Type + gqlChoiceToType (GQL.EnumValueDefinition _ (coerce -> c) _) = + [t|'ChoiceDef $(textToStrLit c)|] +typeToDec _ _ _ (GQL.TypeDefinitionInputObject inpts) = inputObjToDec inpts + where + inputObjToDec :: GQL.InputObjectTypeDefinition -> Q Result + inputObjToDec (GQL.InputObjectTypeDefinition _ (coerce -> name) _ fields) = + GQLSchema <$> [t|'DRecord $(textToStrLit name) + $(typesToList <$> traverse gqlFieldToType fields)|] + gqlFieldToType :: GQL.InputValueDefinition -> Q Type + gqlFieldToType (GQL.InputValueDefinition _ (coerce -> fname) ftype _) = + [t|'FieldDef $(textToStrLit fname) $(ginputTypeToType ftype)|] + ginputTypeToType :: GQL.GType -> Q Type + ginputTypeToType (GQL.TypeNamed (coerce -> False) (coerce -> a)) = + [t| $(typeToPrimType a) |] + ginputTypeToType (GQL.TypeNamed (coerce -> True) (coerce -> a)) = + [t| 'OptionalRef $(typeToPrimType a) |] + ginputTypeToType (GQL.TypeList (coerce -> False) (coerce -> a)) = + [t| 'ListRef $(ginputTypeToType a) |] + ginputTypeToType (GQL.TypeList (coerce -> True) (coerce -> a)) = + [t| 'OptionalRef ('ListRef $(ginputTypeToType a)) |] + ginputTypeToType _ = fail "this should not happen, please, file an issue" + typeToPrimType :: GQL.Name -> Q Type + typeToPrimType (GQL.unName -> "Int") = [t|'TPrimitive Integer|] + typeToPrimType (GQL.unName -> "Float") = [t|'TPrimitive Double|] + typeToPrimType (GQL.unName -> "String") = [t|'TPrimitive T.Text|] + typeToPrimType (GQL.unName -> "Boolean") = [t|'TPrimitive Bool|] + typeToPrimType (GQL.unName -> "ID") = [t|'TPrimitive UUID|] + typeToPrimType (coerce -> name) = [t|'TSchematic $(textToStrLit name)|] + +gqlTypeToType :: GQL.Name -> TypeMap -> Name -> Q Type +gqlTypeToType (GQL.unName -> "Int") _ _ = [t|'PrimitiveRef Integer|] +gqlTypeToType (GQL.unName -> "Float") _ _ = [t|'PrimitiveRef Double|] +gqlTypeToType (GQL.unName -> "String") _ _ = [t|'PrimitiveRef T.Text|] +gqlTypeToType (GQL.unName -> "Boolean") _ _ = [t|'PrimitiveRef Bool|] +gqlTypeToType (GQL.unName -> "ID") _ _ = [t|'PrimitiveRef UUID|] +gqlTypeToType (coerce -> name) tm schemaName = + let schemaRef = [t|'SchemaRef $(conT schemaName) $(textToStrLit name)|] + in case HM.lookup name tm of + Just Enum -> schemaRef + Just InputObject -> schemaRef + _ -> [t|'ObjectRef $(textToStrLit name)|] + +typesToList :: [Type] -> Type +typesToList = foldr (AppT . AppT PromotedConsT) PromotedNilT + +textToStrLit :: T.Text -> Q Type +textToStrLit = litT . strTyLit . T.unpack diff --git a/src/Mu/GraphQL/Quasi/LostParser.hs b/src/Mu/GraphQL/Quasi/LostParser.hs new file mode 100644 --- /dev/null +++ b/src/Mu/GraphQL/Quasi/LostParser.hs @@ -0,0 +1,38 @@ +module Mu.GraphQL.Quasi.LostParser ( + -- * The Lost 'Parser'™️ + parseTypeSysDefinition +) where + +import Control.Applicative ((<|>)) +import Data.Attoparsec.Text (Parser, many1) +import qualified Data.Text as T +import Language.GraphQL.Draft.Parser (nameParser, runParser, schemaDocument) +import qualified Language.GraphQL.Draft.Syntax as GQL +import Text.Parser.Token (braces, symbol, whiteSpace) + +schemaDefinition :: Parser GQL.SchemaDefinition +schemaDefinition = symbol "schema" *> braces ( + GQL.SchemaDefinition + <$> pure Nothing -- ignore [Directive] + <*> many1 rootOperationParser + ) + +rootOperationParser :: Parser GQL.RootOperationTypeDefinition +rootOperationParser = + GQL.RootOperationTypeDefinition + <$> (operationTypeParser <* symbol ":") + <*> (GQL.NamedType <$> nameParser) + +operationTypeParser :: Parser GQL.OperationType +operationTypeParser = + GQL.OperationTypeQuery <$ symbol "query" + <|> GQL.OperationTypeMutation <$ symbol "mutation" + <|> GQL.OperationTypeSubscription <$ symbol "subscription" + +typeSystemDefinition :: Parser [GQL.TypeSystemDefinition] +typeSystemDefinition = whiteSpace *> (concat <$> many1 ( + (\(GQL.SchemaDocument d) -> GQL.TypeSystemDefinitionType <$> d) <$> schemaDocument + <|> (: []) . GQL.TypeSystemDefinitionSchema <$> schemaDefinition )) + +parseTypeSysDefinition :: T.Text -> Either T.Text [GQL.TypeSystemDefinition] +parseTypeSysDefinition = runParser typeSystemDefinition diff --git a/src/Mu/GraphQL/Query/Definition.hs b/src/Mu/GraphQL/Query/Definition.hs new file mode 100644 --- /dev/null +++ b/src/Mu/GraphQL/Query/Definition.hs @@ -0,0 +1,114 @@ +{-# language DataKinds #-} +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeOperators #-} +module Mu.GraphQL.Query.Definition where + +import Data.SOP.NP +import Data.SOP.NS +import Data.Text +import qualified Language.GraphQL.Draft.Syntax as GQL +import Mu.Rpc +import Mu.Schema + +data Document (p :: Package snm mnm anm) + (qr :: Maybe snm) (mut :: Maybe snm) (sub :: Maybe snm) where + QueryDoc + :: LookupService ss qr ~ 'Service qr qanns qms + => ServiceQuery ('Package pname ss) (LookupService ss qr) + -> Document ('Package pname ss) ('Just qr) mut sub + MutationDoc + :: LookupService ss mut ~ 'Service mut manns mms + => ServiceQuery ('Package pname ss) (LookupService ss mut) + -> Document ('Package pname ss) qr ('Just mut) sub + SubscriptionDoc + :: LookupService ss sub ~ 'Service sub manns mms + => OneMethodQuery ('Package pname ss) (LookupService ss sub) + -> Document ('Package pname ss) qr mut ('Just sub) + +type ServiceQuery (p :: Package snm mnm anm) (s :: Service snm mnm anm) + = [OneMethodQuery p s] + +data OneMethodQuery (p :: Package snm mnm anm) (s :: Service snm mnm anm) where + OneMethodQuery + :: Maybe Text + -> NS (ChosenMethodQuery p) ms + -> OneMethodQuery p ('Service nm anns ms) + -- the special '__typename' field + TypeNameQuery + :: Maybe Text + -> OneMethodQuery p ('Service nm anns ms) + -- introspection fields + SchemaQuery + :: Maybe Text + -> GQL.SelectionSet + -> OneMethodQuery p ('Service nm anns ms) + TypeQuery + :: Maybe Text + -> Text + -> GQL.SelectionSet + -> OneMethodQuery p ('Service nm anns ms) + +data ChosenMethodQuery (p :: Package snm mnm anm) (m :: Method snm mnm anm) where + ChosenMethodQuery + :: NP (ArgumentValue p) args + -> ReturnQuery p r + -> ChosenMethodQuery p ('Method mname anns args r) + +data ArgumentValue (p :: Package snm mnm anm) (a :: Argument snm anm) where + ArgumentValue :: ArgumentValue' p r + -> ArgumentValue p ('ArgSingle aname anns r) + ArgumentStream :: ArgumentValue' p ('ListRef r) + -> ArgumentValue p ('ArgStream aname anns r) + +data ArgumentValue' (p :: Package snm mnm anm) (r :: TypeRef snm) where + ArgPrimitive :: t -> ArgumentValue' p ('PrimitiveRef t) + ArgSchema :: Term sch (sch :/: sty) + -> ArgumentValue' p ('SchemaRef sch sty) + ArgList :: [ArgumentValue' p r] + -> ArgumentValue' p ('ListRef r) + ArgOptional :: Maybe (ArgumentValue' p r) + -> ArgumentValue' p ('OptionalRef r) + +data ReturnQuery (p :: Package snm mnm anm) (r :: Return snm) where + RNothing :: ReturnQuery p 'RetNothing + RSingle :: ReturnQuery' p r -> ReturnQuery p ('RetSingle r) + RStream :: ReturnQuery' p r -> ReturnQuery p ('RetStream r) + +data ReturnQuery' (p :: Package snm mnm anm) (r :: TypeRef snm) where + RetPrimitive :: ReturnQuery' p ('PrimitiveRef t) + RetSchema :: SchemaQuery sch (sch :/: sty) + -> ReturnQuery' p ('SchemaRef sch sty) + RetList :: ReturnQuery' p r -> ReturnQuery' p ('ListRef r) + RetOptional :: ReturnQuery' p r -> ReturnQuery' p ('OptionalRef r) + RetObject :: ServiceQuery ('Package pname ss) (LookupService ss s) + -> ReturnQuery' ('Package pname ss) ('ObjectRef s) + +data SchemaQuery (sch :: Schema tn fn) (t :: TypeDef tn fn) where + QueryEnum :: SchemaQuery sch ('DEnum nm choices) + QueryRecord :: [OneFieldQuery sch fs] + -> SchemaQuery sch ('DRecord ty fs) + +data OneFieldQuery (sch :: Schema tn fn) (fs :: [FieldDef tn fn]) where + OneFieldQuery + :: Maybe Text + -> NS (ChosenFieldQuery sch) fs + -> OneFieldQuery sch fs + TypeNameFieldQuery + :: Maybe Text + -> OneFieldQuery sch fs + +data ChosenFieldQuery (sch :: Schema tn fn) (f :: FieldDef tn fn) where + ChosenFieldQuery + :: ReturnSchemaQuery sch r + -> ChosenFieldQuery sch ('FieldDef name r) + +data ReturnSchemaQuery (sch :: Schema tn fn) (r :: FieldType tn) where + RetSchPrimitive :: ReturnSchemaQuery sch ('TPrimitive t) + RetSchSchema :: SchemaQuery sch (sch :/: sty) + -> ReturnSchemaQuery sch ('TSchematic sty) + RetSchList :: ReturnSchemaQuery sch r + -> ReturnSchemaQuery sch ('TList r) + RetSchOptional :: ReturnSchemaQuery sch r + -> ReturnSchemaQuery sch ('TOption r) diff --git a/src/Mu/GraphQL/Query/Introspection.hs b/src/Mu/GraphQL/Query/Introspection.hs new file mode 100644 --- /dev/null +++ b/src/Mu/GraphQL/Query/Introspection.hs @@ -0,0 +1,356 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +module Mu.GraphQL.Query.Introspection where + +import Control.Monad.Writer +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as S +import Data.Int (Int32) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Proxy +import qualified Data.Text as T +import GHC.TypeLits +import Mu.Rpc +import qualified Mu.Schema as Mu + +type TypeMap = HM.HashMap T.Text Type + +data Schema + = Schema { queryType :: Maybe T.Text + , mutationType :: Maybe T.Text + , subscriptionType :: Maybe T.Text + , types :: TypeMap } + deriving Show + +data Type + = Type + { kind :: TypeKind + , typeName :: Maybe T.Text + , fields :: [Field] + , enumValues :: [EnumValue] + , ofType :: Maybe Type + } + | TypeRef { to :: T.Text } + deriving Show + +data Field + = Field + { fieldName :: T.Text + , args :: [Input] + , fieldType :: Type + } + deriving Show + +data Input + = Input + { inputName :: T.Text + , inputDefaultValue :: Maybe T.Text + , inputType :: Type + } + deriving Show + +newtype EnumValue + = EnumValue { enumValueName :: T.Text } + deriving Show + +data TypeKind + = SCALAR + | OBJECT + | INTERFACE + | UNION + | ENUM + | INPUT_OBJECT + | LIST + | NON_NULL + deriving Show + +tSimple :: T.Text -> Type +tSimple t = Type SCALAR (Just t) [] [] Nothing + +tList :: Type -> Type +tList = Type LIST Nothing [] [] . Just + +tNonNull :: Type -> Type +tNonNull = Type NON_NULL Nothing [] [] . Just + +unwrapNonNull :: Type -> Maybe Type +unwrapNonNull (Type NON_NULL _ _ _ x) = x +unwrapNonNull _ = Nothing + +-- BUILD INTROSPECTION DATA +-- ======================== + +class Introspect (p :: Package') + (qr :: Maybe Symbol) + (mut :: Maybe Symbol) + (sub :: Maybe Symbol) where + introspect + :: Proxy p -> Proxy qr -> Proxy mut -> Proxy sub -> Schema + +instance ( IntrospectServices ss sub + , KnownMaybeSymbol qr + , KnownMaybeSymbol mut + , KnownMaybeSymbol sub) + => Introspect ('Package nm ss) qr mut sub where + introspect _ _ _ _ + = let (_, ts) = runWriter $ + introspectServices (Proxy @ss) (Proxy @sub) >> + tell (HM.fromList ( + (\i -> (i, tSimple i)) <$> ["Null", "Int", "Float", "String", "Boolean", "ID"])) + -- return only reachable types + qrS = maybeSymbolVal (Proxy @qr) + mutS = maybeSymbolVal (Proxy @mut) + subS = maybeSymbolVal (Proxy @sub) + initials = S.fromList $ catMaybes [qrS, mutS, subS] + reach = reachableFrom ts initials + -- + finalTs = HM.filterWithKey (\k _ -> k `S.member` reach) ts + in Schema qrS mutS subS finalTs + +reachableFrom :: TypeMap -> S.HashSet T.Text -> S.HashSet T.Text +reachableFrom mp tys + = let tys' = S.toList tys + fromThis = S.fromList . reachableFromOne <$> tys' + allReachable = S.unions fromThis + in if tys == allReachable + then tys + else reachableFrom mp allReachable + where + reachableFromOne :: T.Text -> [T.Text] + reachableFromOne t + = case HM.lookup t mp of + Just ty@Type {} + -> t : concatMap reachableFromField (fields ty) + _ -> error "this should never happen" + + reachableFromField :: Field -> [T.Text] + reachableFromField f + = reachableFromType (fieldType f) ++ concatMap reachableFromInput (args f) + + reachableFromInput :: Input -> [T.Text] + reachableFromInput i = reachableFromType (inputType i) + + reachableFromType :: Type -> [T.Text] + reachableFromType (TypeRef t) = [t] + reachableFromType t@Type {} + = case ofType t of + Just t' -> reachableFromType t' + Nothing -> case typeName t of + Just tn -> [tn] + Nothing -> [] + +class KnownMaybeSymbol (s :: Maybe Symbol) where + maybeSymbolVal :: Proxy s -> Maybe T.Text +instance KnownSymbol s => KnownMaybeSymbol ('Just s) where + maybeSymbolVal _ = Just $ T.pack $ symbolVal (Proxy @s) +instance KnownMaybeSymbol 'Nothing where + maybeSymbolVal _ = Nothing + +type family IsSub (sname :: Symbol) (sub :: Maybe Symbol) :: Bool where + IsSub sname 'Nothing = 'False + IsSub sname ('Just sname) = 'True + IsSub sname ('Just other) = 'False + +class IntrospectServices (ss :: [Service']) (sub :: Maybe Symbol) where + introspectServices + :: Proxy ss -> Proxy sub -> Writer TypeMap () +instance IntrospectServices '[] sub where + introspectServices _ _ = pure () +instance ( KnownSymbol sname + , IntrospectFields smethods (IsSub sname sub) + , IntrospectServices ss sub ) + => IntrospectServices ('Service sname sanns smethods ': ss) sub where + introspectServices _ psub = do + let name = T.pack $ symbolVal (Proxy @sname) + fs <- introspectFields (Proxy @smethods) (Proxy @(IsSub sname sub)) + let t = Type OBJECT (Just name) fs [] Nothing + -- add this one to the mix + tell (HM.singleton name t) + -- continue with the rest + introspectServices (Proxy @ss) psub + +class IntrospectFields (fs :: [Method']) (isSub :: Bool) where + introspectFields + :: Proxy fs -> Proxy isSub -> Writer TypeMap [Field] +instance IntrospectFields '[] isSub where + introspectFields _ _ = pure [] +instance ( KnownSymbol mname + , IntrospectInputs margs + , IntrospectReturn mret isSub + , IntrospectFields fs isSub) + => IntrospectFields ('Method mname manns margs mret ': fs) isSub where + introspectFields _ pIsSub = do + let name = T.pack $ symbolVal (Proxy @mname) + inputs <- introspectInputs (Proxy @margs) + ret <- introspectReturn (Proxy @mret) pIsSub + let this = Field name inputs ret + (this :) <$> introspectFields (Proxy @fs) pIsSub + +class IntrospectInputs (args :: [Argument']) where + introspectInputs + :: Proxy args -> Writer TypeMap [Input] +instance IntrospectInputs '[] where + introspectInputs _ = pure [] +instance ( KnownMaybeSymbol nm + , IntrospectTypeRef r + , IntrospectInputs args ) + => IntrospectInputs ('ArgSingle nm anns r ': args) where + introspectInputs _ = do + let nm = maybeSymbolVal (Proxy @nm) + t <- introspectTypeRef (Proxy @r) False + -- TODO: Find default value + let this = Input (fromMaybe "arg" nm) Nothing t + (this :) <$> introspectInputs (Proxy @args) +instance ( KnownMaybeSymbol nm + , IntrospectTypeRef r + , IntrospectInputs args ) + => IntrospectInputs ('ArgStream nm anns r ': args) where + introspectInputs _ = do + let nm = maybeSymbolVal (Proxy @nm) + t <- tList <$> introspectTypeRef (Proxy @r) False + -- TODO: Find default value + let this = Input (fromMaybe "arg" nm) Nothing t + (this :) <$> introspectInputs (Proxy @args) + +class IntrospectReturn (r :: Return Symbol) (isSub :: Bool) where + introspectReturn + :: Proxy r -> Proxy isSub -> Writer TypeMap Type + +instance IntrospectReturn 'RetNothing isSub where + introspectReturn _ _ = pure $ tSimple "Null" +instance IntrospectTypeRef t + => IntrospectReturn ('RetSingle t) isSub where + introspectReturn _ _ = introspectTypeRef (Proxy @t) True +instance IntrospectTypeRef t + => IntrospectReturn ('RetStream t) 'False where + introspectReturn _ _ = tList <$> introspectTypeRef (Proxy @t) True +instance IntrospectTypeRef t + => IntrospectReturn ('RetStream t) 'True where + introspectReturn _ _ = introspectTypeRef (Proxy @t) True + +class IntrospectTypeRef (tr :: TypeRef Symbol) where + introspectTypeRef + :: Proxy tr -> Bool -> Writer TypeMap Type + +instance IntrospectTypeRef ('PrimitiveRef Bool) where + introspectTypeRef _ _ = pure $ tNonNull $ tSimple "Boolean" +instance IntrospectTypeRef ('PrimitiveRef Int32) where + introspectTypeRef _ _ = pure $ tNonNull $ tSimple "Int" +instance IntrospectTypeRef ('PrimitiveRef Integer) where + introspectTypeRef _ _ = pure $ tNonNull $ tSimple "Int" +instance IntrospectTypeRef ('PrimitiveRef Double) where + introspectTypeRef _ _ = pure $ tNonNull $ tSimple "Float" +instance IntrospectTypeRef ('PrimitiveRef String) where + introspectTypeRef _ _ = pure $ tNonNull $ tSimple "String" +instance IntrospectTypeRef ('PrimitiveRef T.Text) where + introspectTypeRef _ _ = pure $ tNonNull $ tSimple "String" + +instance (IntrospectTypeRef r) + => IntrospectTypeRef ('ListRef r) where + introspectTypeRef _ isRet = tList <$> introspectTypeRef (Proxy @r) isRet +instance (IntrospectTypeRef r) + => IntrospectTypeRef ('OptionalRef r) where + introspectTypeRef _ isRet = do + r <- introspectTypeRef (Proxy @r) isRet + pure $ fromMaybe r (unwrapNonNull r) + +instance (KnownSymbol o) + => IntrospectTypeRef ('ObjectRef o) where + introspectTypeRef _ _ + = pure $ TypeRef $ T.pack $ symbolVal (Proxy @o) + +instance (IntrospectSchema sch, KnownSymbol t) + => IntrospectTypeRef ('SchemaRef sch t) where + introspectTypeRef _ isRet = do + let (k, suffix) = if isRet then (OBJECT, "R") else (INPUT_OBJECT, "") + introspectSchema k suffix (Proxy @sch) + pure $ TypeRef $ T.pack (symbolVal (Proxy @t)) <> suffix + +class IntrospectSchema (ts :: [Mu.TypeDef Symbol Symbol]) where + introspectSchema + :: TypeKind -> T.Text -> Proxy ts -> Writer TypeMap () +instance IntrospectSchema '[] where + introspectSchema _ _ _ = pure () +instance (KnownSymbol name, IntrospectSchemaFields fields, IntrospectSchema ts) + => IntrospectSchema ('Mu.DRecord name fields ': ts) where + introspectSchema k suffix _ = do + let name = T.pack (symbolVal (Proxy @name)) <> suffix + fs = introspectSchemaFields suffix (Proxy @fields) + t = Type k (Just name) fs [] Nothing + -- add this one to the mix + tell (HM.singleton name t) + -- continue with the rest + introspectSchema k suffix (Proxy @ts) +instance (KnownSymbol name, IntrospectSchemaEnum choices, IntrospectSchema ts) + => IntrospectSchema ('Mu.DEnum name choices ': ts) where + introspectSchema k suffix _ = do + let name = T.pack (symbolVal (Proxy @name)) <> suffix + cs = introspectSchemaEnum (Proxy @choices) + t = Type ENUM (Just name) [] cs Nothing + -- add this one to the mix + tell (HM.singleton name t) + -- continue with the rest + introspectSchema k suffix (Proxy @ts) + +class IntrospectSchemaFields (fs :: [Mu.FieldDef Symbol Symbol]) where + introspectSchemaFields + :: T.Text -> Proxy fs -> [Field] +instance IntrospectSchemaFields '[] where + introspectSchemaFields _ _ = [] +instance (KnownSymbol fname,IntrospectSchemaFieldType r, IntrospectSchemaFields fs) + => IntrospectSchemaFields ('Mu.FieldDef fname r ': fs) where + introspectSchemaFields suffix _ + = let name = T.pack $ symbolVal (Proxy @fname) + ret = introspectSchemaFieldType suffix (Proxy @r) + this = Field name [] ret + in this : introspectSchemaFields suffix (Proxy @fs) + +class IntrospectSchemaFieldType (t :: Mu.FieldType Symbol) where + introspectSchemaFieldType + :: T.Text -> Proxy t -> Type + +instance IntrospectSchemaFieldType ('Mu.TPrimitive Bool) where + introspectSchemaFieldType _ _ = tNonNull $ tSimple "Boolean" +instance IntrospectSchemaFieldType ('Mu.TPrimitive Int32) where + introspectSchemaFieldType _ _ = tNonNull $ tSimple "Int" +instance IntrospectSchemaFieldType ('Mu.TPrimitive Integer) where + introspectSchemaFieldType _ _ = tNonNull $ tSimple "Int" +instance IntrospectSchemaFieldType ('Mu.TPrimitive Double) where + introspectSchemaFieldType _ _ = tNonNull $ tSimple "Float" +instance IntrospectSchemaFieldType ('Mu.TPrimitive String) where + introspectSchemaFieldType _ _ = tNonNull $ tSimple "String" +instance IntrospectSchemaFieldType ('Mu.TPrimitive T.Text) where + introspectSchemaFieldType _ _ = tNonNull $ tSimple "String" + +instance (IntrospectSchemaFieldType r) + => IntrospectSchemaFieldType ('Mu.TList r) where + introspectSchemaFieldType suffix _ + = tList $ introspectSchemaFieldType suffix (Proxy @r) +instance (IntrospectSchemaFieldType r) + => IntrospectSchemaFieldType ('Mu.TOption r) where + introspectSchemaFieldType suffix _ + = let r = introspectSchemaFieldType suffix (Proxy @r) + in fromMaybe r (unwrapNonNull r) + +instance (KnownSymbol nm) + => IntrospectSchemaFieldType ('Mu.TSchematic nm) where + introspectSchemaFieldType suffix _ + = TypeRef $ T.pack (symbolVal (Proxy @nm)) <> suffix + +class IntrospectSchemaEnum (c :: [Mu.ChoiceDef Symbol]) where + introspectSchemaEnum :: Proxy c -> [EnumValue] +instance IntrospectSchemaEnum '[] where + introspectSchemaEnum _ = [] +instance (KnownSymbol nm, IntrospectSchemaEnum cs) + => IntrospectSchemaEnum ('Mu.ChoiceDef nm ': cs) where + introspectSchemaEnum _ + = let this = EnumValue $ T.pack $ symbolVal (Proxy @nm) + in this : introspectSchemaEnum (Proxy @cs) diff --git a/src/Mu/GraphQL/Query/Parse.hs b/src/Mu/GraphQL/Query/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Mu/GraphQL/Query/Parse.hs @@ -0,0 +1,768 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-# language ViewPatterns #-} +{-# OPTIONS_GHC -Wincomplete-patterns -fno-warn-orphans #-} + +module Mu.GraphQL.Query.Parse where + +import Control.Monad.Except +import qualified Data.Aeson as A +import Data.Coerce (coerce) +import qualified Data.Foldable as F +import qualified Data.HashMap.Strict as HM +import Data.Int (Int32) +import Data.Kind +import Data.List (find) +import Data.Maybe +import Data.Proxy +import Data.Scientific (floatingOrInteger) +import Data.SOP.NS +import qualified Data.Text as T +import GHC.TypeLits +import qualified Language.GraphQL.Draft.Syntax as GQL + +import Mu.GraphQL.Annotations +import Mu.GraphQL.Query.Definition +import Mu.Rpc +import Mu.Schema + +type VariableMapC = HM.HashMap T.Text GQL.ValueConst +type VariableMap = HM.HashMap T.Text GQL.Value +type FragmentMap = HM.HashMap T.Text GQL.FragmentDefinition + +instance A.FromJSON GQL.ValueConst where + parseJSON A.Null = pure GQL.VCNull + parseJSON (A.Bool b) = pure $ GQL.VCBoolean b + parseJSON (A.String s) = pure $ GQL.VCString $ coerce s + parseJSON (A.Number n) = pure $ either GQL.VCFloat GQL.VCInt $ floatingOrInteger n + parseJSON (A.Array xs) = GQL.VCList . GQL.ListValueG . F.toList <$> traverse A.parseJSON xs + parseJSON (A.Object o) = GQL.VCObject . GQL.ObjectValueG . fmap toObjFld . HM.toList <$> traverse A.parseJSON o + where + toObjFld :: (T.Text, GQL.ValueConst) -> GQL.ObjectFieldG GQL.ValueConst + toObjFld (k, v) = GQL.ObjectFieldG (coerce k) v + +parseDoc :: + forall qr mut sub p f. + ( MonadError T.Text f, ParseTypedDoc p qr mut sub ) => + Maybe T.Text -> VariableMapC -> + GQL.ExecutableDocument -> + f (Document p qr mut sub) +-- If there's no operation name, there must be only one query +parseDoc Nothing vmap (GQL.ExecutableDocument defns) + = case GQL.partitionExDefs defns of + ([unnamed], [], frs) + -> parseTypedDocQuery HM.empty (fragmentsToMap frs) unnamed + ([], [named], frs) + -> parseTypedDoc vmap (fragmentsToMap frs) named + ([], [], _) -> throwError "no operation to execute" + (_, [], _) -> throwError "more than one unnamed query" + ([], _, _) -> throwError "more than one named operation but no 'operationName' given" + (_, _, _) -> throwError "both named and unnamed queries, but no 'operationName' given" +-- If there's an operation name, look in the named queries +parseDoc (Just operationName) vmap (GQL.ExecutableDocument defns) + = case GQL.partitionExDefs defns of + (_, named, frs) -> maybe notFound (parseTypedDoc vmap (fragmentsToMap frs)) (find isThis named) + where isThis (GQL._todName -> Just nm) + = GQL.unName nm == operationName + isThis _ = False + notFound :: MonadError T.Text f => f a + notFound = throwError $ "operation '" <> operationName <> "' was not found" + +fragmentsToMap :: [GQL.FragmentDefinition] -> FragmentMap +fragmentsToMap = HM.fromList . map fragmentToThingy + where fragmentToThingy :: GQL.FragmentDefinition -> (T.Text, GQL.FragmentDefinition) + fragmentToThingy f = (GQL.unName $ GQL._fdName f, f) + +parseTypedDoc :: + (MonadError T.Text f, ParseTypedDoc p qr mut sub) => + VariableMapC -> FragmentMap -> + GQL.TypedOperationDefinition -> + f (Document p qr mut sub) +parseTypedDoc vmap frmap tod + = let defVmap = parseVariableMap (GQL._todVariableDefinitions tod) + finalVmap = constToValue <$> HM.union vmap defVmap -- first one takes precedence + in case GQL._todType tod of + GQL.OperationTypeQuery + -> parseTypedDocQuery finalVmap frmap (GQL._todSelectionSet tod) + GQL.OperationTypeMutation + -> parseTypedDocMutation finalVmap frmap (GQL._todSelectionSet tod) + GQL.OperationTypeSubscription + -> parseTypedDocSubscription finalVmap frmap (GQL._todSelectionSet tod) + +class ParseTypedDoc (p :: Package') + (qr :: Maybe Symbol) (mut :: Maybe Symbol) (sub :: Maybe Symbol) where + parseTypedDocQuery :: + MonadError T.Text f => + VariableMap -> FragmentMap -> + GQL.SelectionSet -> + f (Document p qr mut sub) + parseTypedDocMutation :: + MonadError T.Text f => + VariableMap -> FragmentMap -> + GQL.SelectionSet -> + f (Document p qr mut sub) + parseTypedDocSubscription :: + MonadError T.Text f => + VariableMap -> FragmentMap -> + GQL.SelectionSet -> + f (Document p qr mut sub) + +instance + ( p ~ 'Package pname ss, + LookupService ss qr ~ 'Service qr qanns qmethods, + KnownName qr, ParseMethod p qmethods, + LookupService ss mut ~ 'Service mut manns mmethods, + KnownName mut, ParseMethod p mmethods, + LookupService ss sub ~ 'Service sub sanns smethods, + KnownName sub, ParseMethod p smethods + ) => ParseTypedDoc p ('Just qr) ('Just mut) ('Just sub) where + parseTypedDocQuery vmap frmap sset + = QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset + parseTypedDocMutation vmap frmap sset + = MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset + parseTypedDocSubscription vmap frmap sset + = do q <- parseQuery Proxy Proxy vmap frmap sset + case q of + [one] -> pure $ SubscriptionDoc one + _ -> throwError "subscriptions may only have one field" + +instance + ( p ~ 'Package pname ss, + LookupService ss qr ~ 'Service qr qanns qmethods, + KnownName qr, ParseMethod p qmethods, + LookupService ss mut ~ 'Service mut manns mmethods, + KnownName mut, ParseMethod p mmethods + ) => ParseTypedDoc p ('Just qr) ('Just mut) 'Nothing where + parseTypedDocQuery vmap frmap sset + = QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset + parseTypedDocMutation vmap frmap sset + = MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset + parseTypedDocSubscription _ _ _ + = throwError "no subscriptions are defined in the schema" + +instance + ( p ~ 'Package pname ss, + LookupService ss qr ~ 'Service qr qanns qmethods, + KnownName qr, ParseMethod p qmethods, + LookupService ss sub ~ 'Service sub sanns smethods, + KnownName sub, ParseMethod p smethods + ) => ParseTypedDoc p ('Just qr) 'Nothing ('Just sub) where + parseTypedDocQuery vmap frmap sset + = QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset + parseTypedDocMutation _ _ _ + = throwError "no mutations are defined in the schema" + parseTypedDocSubscription vmap frmap sset + = do q <- parseQuery Proxy Proxy vmap frmap sset + case q of + [one] -> pure $ SubscriptionDoc one + _ -> throwError "subscriptions may only have one field" + +instance + ( p ~ 'Package pname ss, + LookupService ss qr ~ 'Service qr qanns qmethods, + KnownName qr, ParseMethod p qmethods + ) => ParseTypedDoc p ('Just qr) 'Nothing 'Nothing where + parseTypedDocQuery vmap frmap sset + = QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset + parseTypedDocMutation _ _ _ + = throwError "no mutations are defined in the schema" + parseTypedDocSubscription _ _ _ + = throwError "no subscriptions are defined in the schema" + +instance + ( p ~ 'Package pname ss, + LookupService ss mut ~ 'Service mut manns mmethods, + KnownName mut, ParseMethod p mmethods, + LookupService ss sub ~ 'Service sub sanns smethods, + KnownName sub, ParseMethod p smethods + ) => ParseTypedDoc p 'Nothing ('Just mut) ('Just sub) where + parseTypedDocQuery _ _ _ + = throwError "no queries are defined in the schema" + parseTypedDocMutation vmap frmap sset + = MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset + parseTypedDocSubscription vmap frmap sset + = do q <- parseQuery Proxy Proxy vmap frmap sset + case q of + [one] -> pure $ SubscriptionDoc one + _ -> throwError "subscriptions may only have one field" + +instance + ( p ~ 'Package pname ss, + LookupService ss mut ~ 'Service mut manns mmethods, + KnownName mut, ParseMethod p mmethods + ) => ParseTypedDoc p 'Nothing ('Just mut) 'Nothing where + parseTypedDocQuery _ _ _ + = throwError "no queries are defined in the schema" + parseTypedDocMutation vmap frmap sset + = MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset + parseTypedDocSubscription _ _ _ + = throwError "no subscriptions are defined in the schema" + +instance + ( p ~ 'Package pname ss, + LookupService ss sub ~ 'Service sub sanns smethods, + KnownName sub, ParseMethod p smethods + ) => ParseTypedDoc p 'Nothing 'Nothing ('Just sub) where + parseTypedDocQuery _ _ _ + = throwError "no queries are defined in the schema" + parseTypedDocMutation _ _ _ + = throwError "no mutations are defined in the schema" + parseTypedDocSubscription vmap frmap sset + = do q <- parseQuery Proxy Proxy vmap frmap sset + case q of + [one] -> pure $ SubscriptionDoc one + _ -> throwError "subscriptions may only have one field" + +instance + ParseTypedDoc p 'Nothing 'Nothing 'Nothing where + parseTypedDocQuery _ _ _ + = throwError "no queries are defined in the schema" + parseTypedDocMutation _ _ _ + = throwError "no mutations are defined in the schema" + parseTypedDocSubscription _ _ _ + = throwError "no subscriptions are defined in the schema" + +parseVariableMap :: [GQL.VariableDefinition] -> VariableMapC +parseVariableMap vmap + = HM.fromList [(GQL.unName (GQL.unVariable v), def) + | GQL.VariableDefinition v _ (Just def) <- vmap] + +constToValue :: GQL.ValueConst -> GQL.Value +constToValue (GQL.VCInt n) = GQL.VInt n +constToValue (GQL.VCFloat n) = GQL.VFloat n +constToValue (GQL.VCString n) = GQL.VString n +constToValue (GQL.VCBoolean n) = GQL.VBoolean n +constToValue GQL.VCNull = GQL.VNull +constToValue (GQL.VCEnum n) = GQL.VEnum n +constToValue (GQL.VCList (GQL.ListValueG n)) + = GQL.VList $ GQL.ListValueG $ constToValue <$> n +constToValue (GQL.VCObject (GQL.ObjectValueG n)) + = GQL.VObject $ GQL.ObjectValueG + [ GQL.ObjectFieldG a (constToValue v) | GQL.ObjectFieldG a v <- n ] + +parseQuery :: + forall (p :: Package') (s :: Symbol) pname ss sanns methods f. + ( MonadError T.Text f, p ~ 'Package pname ss, + LookupService ss s ~ 'Service s sanns methods, + KnownName s, ParseMethod p methods + ) => + Proxy p -> + Proxy s -> + VariableMap -> FragmentMap -> GQL.SelectionSet -> + f (ServiceQuery p (LookupService ss s)) +parseQuery _ _ _ _ [] = pure [] +parseQuery pp ps vmap frmap (GQL.SelectionField fld : ss) + = (++) <$> (maybeToList <$> fieldToMethod fld) + <*> parseQuery pp ps vmap frmap ss + where + fieldToMethod :: GQL.Field -> f (Maybe (OneMethodQuery p ('Service sname sanns methods))) + fieldToMethod (GQL.Field alias name args dirs sels) + | any (shouldSkip vmap) dirs + = pure Nothing + | GQL.unName name == "__typename" + = case (args, sels) of + ([], []) -> pure $ Just $ TypeNameQuery $ GQL.unName . GQL.unAlias <$> alias + _ -> throwError "__typename does not admit arguments nor selection of subfields" + | GQL.unName name == "__schema" + = case args of + [] -> Just . SchemaQuery (GQL.unName . GQL.unAlias <$> alias) <$> unFragment frmap sels + _ -> throwError "__schema does not admit selection of subfields" + | GQL.unName name == "__type" + = let alias' = GQL.unName . GQL.unAlias <$> alias + getString (GQL.VString s) = Just $ coerce s + getString (GQL.VVariable v) = HM.lookup (coerce v) vmap >>= getString + getString _ = Nothing + in case args of + [GQL.Argument _ val] + -> case getString val of + Just s -> Just . TypeQuery alias' s <$> unFragment frmap sels + _ -> throwError "__type requires a string argument" + _ -> throwError "__type requires one single argument" + | otherwise + = Just . OneMethodQuery (GQL.unName . GQL.unAlias <$> alias) + <$> selectMethod (T.pack $ nameVal (Proxy @s)) vmap frmap name args sels +parseQuery pp ps vmap frmap (GQL.SelectionFragmentSpread (GQL.FragmentSpread nm dirs) : ss) + | Just fr <- HM.lookup (GQL.unName nm) frmap + = if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ GQL._fdDirectives fr) + then (++) <$> parseQuery pp ps vmap frmap (GQL._fdSelectionSet fr) + <*> parseQuery pp ps vmap frmap ss + else parseQuery pp ps vmap frmap ss + | otherwise -- the fragment definition was not found + = throwError $ "fragment '" <> GQL.unName nm <> "' was not found" +parseQuery _ _ _ _ (_ : _) -- Inline fragments are not yet supported + = throwError "inline fragments are not (yet) supported" + +shouldSkip :: VariableMap -> GQL.Directive -> Bool +shouldSkip vmap (GQL.Directive (GQL.unName -> nm) [GQL.Argument (GQL.unName -> ifn) v]) + | nm == "skip", ifn == "if" + = case valueParser' @'[] @('TPrimitive Bool) vmap "" v of + Right (FPrimitive b) -> b + _ -> False + | nm == "include", ifn == "if" + = case valueParser' @'[] @('TPrimitive Bool) vmap "" v of + Right (FPrimitive b) -> not b + _ -> False +shouldSkip _ _ = False + +unFragment :: MonadError T.Text f + => FragmentMap -> GQL.SelectionSet -> f GQL.SelectionSet +unFragment _ [] = pure [] +unFragment frmap (GQL.SelectionFragmentSpread (GQL.FragmentSpread nm _) : ss) + | Just fr <- HM.lookup (GQL.unName nm) frmap + = (++) <$> unFragment frmap (GQL._fdSelectionSet fr) + <*> unFragment frmap ss + | otherwise -- the fragment definition was not found + = throwError $ "fragment '" <> GQL.unName nm <> "' was not found" +unFragment frmap (GQL.SelectionField (GQL.Field al nm args dir innerss) : ss) + = (:) <$> (GQL.SelectionField . GQL.Field al nm args dir <$> unFragment frmap innerss) + <*> unFragment frmap ss +unFragment _ _ + = throwError "inline fragments are not (yet) supported" + +class ParseMethod (p :: Package') (ms :: [Method']) where + selectMethod :: + MonadError T.Text f => + T.Text -> + VariableMap -> + FragmentMap -> + GQL.Name -> + [GQL.Argument] -> + GQL.SelectionSet -> + f (NS (ChosenMethodQuery p) ms) + +instance ParseMethod p '[] where + selectMethod tyName _ _ (GQL.unName -> wanted) _ _ + = throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'" +instance + (KnownSymbol mname, ParseMethod p ms, ParseArgs p args, ParseDifferentReturn p r) => + ParseMethod p ('Method mname manns args r ': ms) + where + selectMethod tyName vmap frmap w@(GQL.unName -> wanted) args sels + | wanted == mname + = Z <$> (ChosenMethodQuery <$> parseArgs vmap args + <*> parseDiffReturn vmap frmap wanted sels) + | otherwise + = S <$> selectMethod tyName vmap frmap w args sels + where + mname = T.pack $ nameVal (Proxy @mname) + +class ParseArgs (p :: Package') (args :: [Argument']) where + parseArgs :: MonadError T.Text f + => VariableMap + -> [GQL.Argument] + -> f (NP (ArgumentValue p) args) + +instance ParseArgs p '[] where + parseArgs _ _ = pure Nil +-- one single argument without name +instance ParseArg p a + => ParseArgs p '[ 'ArgSingle 'Nothing anns a ] where + parseArgs vmap [GQL.Argument _ x] + = (\v -> ArgumentValue v :* Nil) <$> parseArg' vmap "arg" x + parseArgs _ _ + = throwError "this field receives one single argument" +instance ParseArg p a + => ParseArgs p '[ 'ArgStream 'Nothing anns a ] where + parseArgs vmap [GQL.Argument _ x] + = (\v -> ArgumentStream v :* Nil) <$> parseArg' vmap "arg" x + parseArgs _ _ + = throwError "this field receives one single argument" +-- more than one argument +instance (KnownName aname, ParseArg p a, ParseArgs p as, FindDefaultArgValue aanns) + => ParseArgs p ('ArgSingle ('Just aname) aanns a ': as) where + parseArgs vmap args + = let aname = T.pack $ nameVal (Proxy @aname) + in case find ((== nameVal (Proxy @aname)) . T.unpack . GQL.unName . GQL._aName) args of + Just (GQL.Argument _ x) + -> (:*) <$> (ArgumentValue <$> parseArg' vmap aname x) + <*> parseArgs vmap args + Nothing + -> do x <- findDefaultArgValue (Proxy @aanns) aname + (:*) <$> (ArgumentValue <$> parseArg' vmap aname (constToValue x)) + <*> parseArgs vmap args +instance (KnownName aname, ParseArg p a, ParseArgs p as, FindDefaultArgValue aanns) + => ParseArgs p ('ArgStream ('Just aname) aanns a ': as) where + parseArgs vmap args + = let aname = T.pack $ nameVal (Proxy @aname) + in case find ((== nameVal (Proxy @aname)) . T.unpack . GQL.unName . GQL._aName) args of + Just (GQL.Argument _ x) + -> (:*) <$> (ArgumentStream <$> parseArg' vmap aname x) + <*> parseArgs vmap args + Nothing + -> do x <- findDefaultArgValue (Proxy @aanns) aname + (:*) <$> (ArgumentStream <$> parseArg' vmap aname (constToValue x)) + <*> parseArgs vmap args + +class FindDefaultArgValue (vs :: [Type]) where + findDefaultArgValue :: MonadError T.Text f + => Proxy vs + -> T.Text + -> f GQL.ValueConst +instance FindDefaultArgValue '[] where + findDefaultArgValue _ aname + = throwError $ "argument '" <> aname <> "' was not given a value, and has no default one" +instance {-# OVERLAPPABLE #-} FindDefaultArgValue xs + => FindDefaultArgValue (x ': xs) where + findDefaultArgValue _ = findDefaultArgValue (Proxy @xs) +instance {-# OVERLAPS #-} ReflectValueConst v + => FindDefaultArgValue (DefaultValue v ': xs) where + findDefaultArgValue _ _ = pure $ reflectValueConst (Proxy @v) + +parseArg' :: (ParseArg p a, MonadError T.Text f) + => VariableMap + -> T.Text + -> GQL.Value + -> f (ArgumentValue' p a) +parseArg' vmap aname (GQL.VVariable (GQL.unName . GQL.unVariable -> x)) + = case HM.lookup x vmap of + Nothing -> throwError $ "variable '" <> x <> "' was not found" + Just v -> parseArg vmap aname v +parseArg' vmap aname v = parseArg vmap aname v + +class ParseArg (p :: Package') (a :: TypeRef Symbol) where + parseArg :: MonadError T.Text f + => VariableMap + -> T.Text + -> GQL.Value + -> f (ArgumentValue' p a) + +instance (ParseArg p r) => ParseArg p ('ListRef r) where + parseArg vmap aname (GQL.VList (GQL.ListValueG xs)) + = ArgList <$> traverse (parseArg' vmap aname) xs + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef Bool) where + parseArg _ _ (GQL.VBoolean b) + = pure (ArgPrimitive b) + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef Int32) where + parseArg _ _ (GQL.VInt b) + = pure (ArgPrimitive b) + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef Integer) where + parseArg _ _ (GQL.VInt b) + = pure $ ArgPrimitive $ fromIntegral b + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef Double) where + parseArg _ _ (GQL.VFloat b) + = pure (ArgPrimitive b) + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef T.Text) where + parseArg _ _ (GQL.VString (GQL.StringValue b)) + = pure $ ArgPrimitive b + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef String) where + parseArg _ _ (GQL.VString (GQL.StringValue b)) + = pure $ ArgPrimitive $ T.unpack b + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef ()) where + parseArg _ _ GQL.VNull = pure $ ArgPrimitive () + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance (ObjectOrEnumParser sch (sch :/: sty)) + => ParseArg p ('SchemaRef sch sty) where + parseArg vmap aname v + = ArgSchema <$> parseObjectOrEnum' vmap aname v + +parseObjectOrEnum' :: (ObjectOrEnumParser sch t, MonadError T.Text f) + => VariableMap + -> T.Text + -> GQL.Value + -> f (Term sch t) +parseObjectOrEnum' vmap aname (GQL.VVariable (GQL.unName . GQL.unVariable -> x)) + = case HM.lookup x vmap of + Nothing -> throwError $ "variable '" <> x <> "' was not found" + Just v -> parseObjectOrEnum vmap aname v +parseObjectOrEnum' vmap aname v + = parseObjectOrEnum vmap aname v + +class ObjectOrEnumParser (sch :: Schema') (t :: TypeDef Symbol Symbol) where + parseObjectOrEnum :: MonadError T.Text f + => VariableMap + -> T.Text + -> GQL.Value + -> f (Term sch t) + +instance (ObjectParser sch args, KnownName name) + => ObjectOrEnumParser sch ('DRecord name args) where + parseObjectOrEnum vmap _ (GQL.VObject (GQL.ObjectValueG vs)) + = TRecord <$> objectParser vmap (T.pack $ nameVal (Proxy @name)) vs + parseObjectOrEnum _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance (EnumParser choices, KnownName name) + => ObjectOrEnumParser sch ('DEnum name choices) where + parseObjectOrEnum _ _ (GQL.VEnum (GQL.EnumValue nm)) + = TEnum <$> enumParser (T.pack $ nameVal (Proxy @name)) nm + parseObjectOrEnum _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" + +class ObjectParser (sch :: Schema') (args :: [FieldDef Symbol Symbol]) where + objectParser :: MonadError T.Text f + => VariableMap + -> T.Text + -> [GQL.ObjectFieldG GQL.Value] + -> f (NP (Field sch) args) + +instance ObjectParser sch '[] where + objectParser _ _ _ = pure Nil +instance + (ObjectParser sch args, ValueParser sch v, KnownName nm) => + ObjectParser sch ('FieldDef nm v ': args) + where + objectParser vmap tyName args + = let wanted = T.pack $ nameVal (Proxy @nm) + in case find ((== wanted) . GQL.unName . GQL._ofName) args of + Just (GQL.ObjectFieldG _ v) + -> (:*) <$> (Field <$> valueParser' vmap wanted v) <*> objectParser vmap tyName args + Nothing -> throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'" + +class EnumParser (choices :: [ChoiceDef Symbol]) where + enumParser :: MonadError T.Text f + => T.Text -> GQL.Name + -> f (NS Proxy choices) + +instance EnumParser '[] where + enumParser tyName (GQL.unName -> wanted) + = throwError $ "value '" <> wanted <> "' was not found on enum '" <> tyName <> "'" +instance (KnownName name, EnumParser choices) + => EnumParser ('ChoiceDef name ': choices) where + enumParser tyName w@(GQL.unName -> wanted) + | wanted == mname = pure (Z Proxy) + | otherwise = S <$> enumParser tyName w + where + mname = T.pack $ nameVal (Proxy @name) + +valueParser' :: (ValueParser sch v, MonadError T.Text f) + => VariableMap + -> T.Text + -> GQL.Value + -> f (FieldValue sch v) +valueParser' vmap aname (GQL.VVariable (GQL.unName . GQL.unVariable -> x)) + = case HM.lookup x vmap of + Nothing -> throwError $ "variable '" <> x <> "' was not found" + Just v -> valueParser vmap aname v +valueParser' vmap aname v = valueParser vmap aname v + +class ValueParser (sch :: Schema') (v :: FieldType Symbol) where + valueParser :: MonadError T.Text f + => VariableMap + -> T.Text + -> GQL.Value + -> f (FieldValue sch v) + +instance ValueParser sch 'TNull where + valueParser _ _ GQL.VNull = pure FNull + valueParser _ fname _ + = throwError $ "field '" <> fname <> "' was not of right type" +instance ValueParser sch ('TPrimitive Bool) where + valueParser _ _ (GQL.VBoolean b) = pure (FPrimitive b) + valueParser _ fname _ + = throwError $ "field '" <> fname <> "' was not of right type" +instance ValueParser sch ('TPrimitive Int32) where + valueParser _ _ (GQL.VInt b) = pure (FPrimitive b) + valueParser _ fname _ + = throwError $ "field '" <> fname <> "' was not of right type" +instance ValueParser sch ('TPrimitive Integer) where + valueParser _ _ (GQL.VInt b) = pure $ FPrimitive $ fromIntegral b + valueParser _ fname _ + = throwError $ "field '" <> fname <> "' was not of right type" +instance ValueParser sch ('TPrimitive Double) where + valueParser _ _ (GQL.VFloat b) = pure (FPrimitive b) + valueParser _ fname _ + = throwError $ "field '" <> fname <> "' was not of right type" +instance ValueParser sch ('TPrimitive T.Text) where + valueParser _ _ (GQL.VString (GQL.StringValue b)) + = pure $ FPrimitive b + valueParser _ fname _ + = throwError $ "field '" <> fname <> "' was not of right type" +instance ValueParser sch ('TPrimitive String) where + valueParser _ _ (GQL.VString (GQL.StringValue b)) + = pure $ FPrimitive $ T.unpack b + valueParser _ fname _ + = throwError $ "field '" <> fname <> "' was not of right type" +instance (ValueParser sch r) => ValueParser sch ('TList r) where + valueParser vmap fname (GQL.VList (GQL.ListValueG xs)) + = FList <$> traverse (valueParser' vmap fname) xs + valueParser _ fname _ + = throwError $ "field '" <> fname <> "' was not of right type" +instance (ValueParser sch r) => ValueParser sch ('TOption r) where + valueParser _ _ GQL.VNull + = pure $ FOption Nothing + valueParser vmap fname v + = FOption . Just <$> valueParser' vmap fname v +instance (ObjectOrEnumParser sch (sch :/: sty), KnownName sty) + => ValueParser sch ('TSchematic sty) where + valueParser vmap _ v + = FSchematic <$> parseObjectOrEnum' vmap (T.pack $ nameVal (Proxy @sty)) v + +class ParseDifferentReturn (p :: Package') (r :: Return Symbol) where + parseDiffReturn :: MonadError T.Text f + => VariableMap + -> FragmentMap + -> T.Text + -> GQL.SelectionSet + -> f (ReturnQuery p r) +instance ParseDifferentReturn p 'RetNothing where + parseDiffReturn _ _ _ [] = pure RNothing + parseDiffReturn _ _ fname _ + = throwError $ "field '" <> fname <> "' should not have a selection of subfields" +instance ParseReturn p r => ParseDifferentReturn p ('RetSingle r) where + parseDiffReturn vmap frmap fname s + = RSingle <$> parseReturn vmap frmap fname s +instance ParseReturn p r => ParseDifferentReturn p ('RetStream r) where + parseDiffReturn vmap frmap fname s + = RStream <$> parseReturn vmap frmap fname s + +class ParseReturn (p :: Package') (r :: TypeRef Symbol) where + parseReturn :: MonadError T.Text f + => VariableMap + -> FragmentMap + -> T.Text + -> GQL.SelectionSet + -> f (ReturnQuery' p r) + +instance ParseReturn p ('PrimitiveRef t) where + parseReturn _ _ _ [] + = pure RetPrimitive + parseReturn _ _ fname _ + = throwError $ "field '" <> fname <> "' should not have a selection of subfields" +instance (ParseSchema sch (sch :/: sty)) + => ParseReturn p ('SchemaRef sch sty) where + parseReturn vmap frmap fname s + = RetSchema <$> parseSchema vmap frmap fname s +instance ParseReturn p r + => ParseReturn p ('ListRef r) where + parseReturn vmap frmap fname s + = RetList <$> parseReturn vmap frmap fname s +instance ParseReturn p r + => ParseReturn p ('OptionalRef r) where + parseReturn vmap frmap fname s + = RetOptional <$> parseReturn vmap frmap fname s +instance ( p ~ 'Package pname ss, + LookupService ss s ~ 'Service s sanns methods, + KnownName s, ParseMethod p methods + ) => ParseReturn p ('ObjectRef s) where + parseReturn vmap frmap _ s + = RetObject <$> parseQuery (Proxy @p) (Proxy @s) vmap frmap s + +class ParseSchema (s :: Schema') (t :: TypeDef Symbol Symbol) where + parseSchema :: MonadError T.Text f + => VariableMap + -> FragmentMap + -> T.Text + -> GQL.SelectionSet + -> f (SchemaQuery s t) +instance ParseSchema sch ('DEnum name choices) where + parseSchema _ _ _ [] + = pure QueryEnum + parseSchema _ _ fname _ + = throwError $ "field '" <> fname <> "' should not have a selection of subfields" +instance (KnownSymbol name, ParseField sch fields) + => ParseSchema sch ('DRecord name fields) where + parseSchema vmap frmap _ s + = QueryRecord <$> parseSchemaQuery (Proxy @sch) (Proxy @('DRecord name fields)) vmap frmap s + +parseSchemaQuery :: + forall (sch :: Schema') t (rname :: Symbol) fields f. + ( MonadError T.Text f + , t ~  'DRecord rname fields + , KnownSymbol rname + , ParseField sch fields ) => + Proxy sch -> + Proxy t -> + VariableMap -> FragmentMap -> GQL.SelectionSet -> + f [OneFieldQuery sch fields] +parseSchemaQuery _ _ _ _ [] = pure [] +parseSchemaQuery pp ps vmap frmap (GQL.SelectionField fld : ss) + = (++) <$> (maybeToList <$> fieldToMethod fld) + <*> parseSchemaQuery pp ps vmap frmap ss + where + fieldToMethod :: GQL.Field -> f (Maybe (OneFieldQuery sch fields)) + fieldToMethod (GQL.Field alias name args dirs sels) + | any (shouldSkip vmap) dirs + = pure Nothing + | GQL.unName name == "__typename" + = case (args, sels) of + ([], []) -> pure $ Just $ TypeNameFieldQuery $ GQL.unName . GQL.unAlias <$> alias + _ -> throwError "__typename does not admit arguments nor selection of subfields" + | _:_ <- args + = throwError "this field does not support arguments" + | otherwise + = Just . OneFieldQuery (GQL.unName . GQL.unAlias <$> alias) + <$> selectField (T.pack $ nameVal (Proxy @rname)) vmap frmap name sels +parseSchemaQuery pp ps vmap frmap (GQL.SelectionFragmentSpread (GQL.FragmentSpread nm dirs) : ss) + | Just fr <- HM.lookup (GQL.unName nm) frmap + = if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ GQL._fdDirectives fr) + then (++) <$> parseSchemaQuery pp ps vmap frmap (GQL._fdSelectionSet fr) + <*> parseSchemaQuery pp ps vmap frmap ss + else parseSchemaQuery pp ps vmap frmap ss + | otherwise -- the fragment definition was not found + = throwError $ "fragment '" <> GQL.unName nm <> "' was not found" +parseSchemaQuery _ _ _ _ (_ : _) -- Inline fragments are not yet supported + = throwError "inline fragments are not (yet) supported" + +class ParseField (sch :: Schema') (fs :: [FieldDef Symbol Symbol]) where + selectField :: + MonadError T.Text f => + T.Text -> + VariableMap -> + FragmentMap -> + GQL.Name -> + GQL.SelectionSet -> + f (NS (ChosenFieldQuery sch) fs) + +instance ParseField sch '[] where + selectField tyName _ _ (GQL.unName -> wanted) _ + = throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'" +instance + (KnownSymbol fname, ParseField sch fs, ParseSchemaReturn sch r) => + ParseField sch ('FieldDef fname r ': fs) + where + selectField tyName vmap frmap w@(GQL.unName -> wanted) sels + | wanted == mname + = Z <$> (ChosenFieldQuery <$> parseSchemaReturn vmap frmap wanted sels) + | otherwise + = S <$> selectField tyName vmap frmap w sels + where + mname = T.pack $ nameVal (Proxy @fname) + +class ParseSchemaReturn (sch :: Schema') (r :: FieldType Symbol) where + parseSchemaReturn :: MonadError T.Text f + => VariableMap + -> FragmentMap + -> T.Text + -> GQL.SelectionSet + -> f (ReturnSchemaQuery sch r) + +instance ParseSchemaReturn sch ('TPrimitive t) where + parseSchemaReturn _ _ _ [] + = pure RetSchPrimitive + parseSchemaReturn _ _ fname _ + = throwError $ "field '" <> fname <> "' should not have a selection of subfields" +instance ( ParseSchema sch (sch :/: sty) ) + => ParseSchemaReturn sch ('TSchematic sty) where + parseSchemaReturn vmap frmap fname s + = RetSchSchema <$> parseSchema vmap frmap fname s +instance ParseSchemaReturn sch r + => ParseSchemaReturn sch ('TList r) where + parseSchemaReturn vmap frmap fname s + = RetSchList <$> parseSchemaReturn vmap frmap fname s +instance ParseSchemaReturn sch r + => ParseSchemaReturn sch ('TOption r) where + parseSchemaReturn vmap frmap fname s + = RetSchOptional <$> parseSchemaReturn vmap frmap fname s diff --git a/src/Mu/GraphQL/Query/Run.hs b/src/Mu/GraphQL/Query/Run.hs new file mode 100644 --- /dev/null +++ b/src/Mu/GraphQL/Query/Run.hs @@ -0,0 +1,771 @@ +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedLists #-} +{-# language OverloadedStrings #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TupleSections #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-# language ViewPatterns #-} +{-# OPTIONS_GHC -fprint-explicit-foralls #-} +module Mu.GraphQL.Query.Run ( + GraphQLApp +, runPipeline +, runSubscriptionPipeline +, runDocument +, runQuery +, runSubscription +-- * Typeclass to be able to run query handlers +, RunQueryFindHandler +) where + +import Control.Concurrent.STM.TMQueue +import Control.Monad.Except (MonadError, runExceptT) +import Control.Monad.Writer +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.Conduit +import Data.Conduit.Combinators (sinkList, yieldMany) +import Data.Conduit.TQueue +import qualified Data.HashMap.Strict as HM +import Data.Maybe +import qualified Data.Text as T +import GHC.TypeLits +import qualified Language.GraphQL.Draft.Syntax as GQL + +import Data.Coerce (coerce) +import Mu.GraphQL.Query.Definition +import qualified Mu.GraphQL.Query.Introspection as Intro +import Mu.GraphQL.Query.Parse +import Mu.Rpc +import Mu.Schema +import Mu.Server + +data GraphQLError + = GraphQLError ServerError [T.Text] + +type GraphQLApp p qr mut sub m chn hs + = (ParseTypedDoc p qr mut sub, RunDocument p qr mut sub m chn hs) + +runPipeline + :: forall qr mut sub p m chn hs. GraphQLApp p qr mut sub m chn hs + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m hs + -> Proxy qr -> Proxy mut -> Proxy sub + -> Maybe T.Text -> VariableMapC -> GQL.ExecutableDocument + -> IO Aeson.Value +runPipeline f svr _ _ _ opName vmap doc + = case parseDoc @qr @mut @sub opName vmap doc of + Left e -> pure $ singleErrValue e + Right (d :: Document p qr mut sub) -> do + (data_, errors) <- runWriterT (runDocument f svr d) + case errors of + [] -> pure $ Aeson.object [ ("data", data_) ] + _ -> pure $ Aeson.object [ ("data", data_), ("errors", Aeson.listValue errValue errors) ] + +runSubscriptionPipeline + :: forall qr mut sub p m chn hs. GraphQLApp p qr mut sub m chn hs + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m hs + -> Proxy qr -> Proxy mut -> Proxy sub + -> Maybe T.Text -> VariableMapC -> GQL.ExecutableDocument + -> ConduitT Aeson.Value Void IO () + -> IO () +runSubscriptionPipeline f svr _ _ _ opName vmap doc sink + = case parseDoc @qr @mut @sub opName vmap doc of + Left e + -> yieldSingleError e sink + Right (d :: Document p qr mut sub) + -> runDocumentSubscription f svr d sink + +singleErrValue :: T.Text -> Aeson.Value +singleErrValue e + = Aeson.object [ ("errors", Aeson.Array [ + Aeson.object [ ("message", Aeson.String e) ] ])] + +errValue :: GraphQLError -> Aeson.Value +errValue (GraphQLError (ServerError _ msg) path) + = Aeson.object [ + ("message", Aeson.String $ T.pack msg) + , ("path", Aeson.toJSON path) + ] + +yieldSingleError :: Monad m + => T.Text -> ConduitM Aeson.Value Void m () -> m () +yieldSingleError e sink = + runConduit $ yieldMany ([singleErrValue e] :: [Aeson.Value]) .| sink + +yieldError :: Monad m + => ServerError -> [T.Text] + -> ConduitM Aeson.Value Void m () -> m () +yieldError e path sink = do + let val = Aeson.object [ ("errors", Aeson.listValue errValue [GraphQLError e path]) ] + runConduit $ yieldMany ([val] :: [Aeson.Value]) .| sink + +class RunDocument (p :: Package') + (qr :: Maybe Symbol) + (mut :: Maybe Symbol) + (sub :: Maybe Symbol) + m chn hs where + runDocument :: + (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m hs + -> Document p qr mut sub + -> WriterT [GraphQLError] IO Aeson.Value + runDocumentSubscription :: + (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m hs + -> Document p qr mut sub + -> ConduitT Aeson.Value Void IO () + -> IO () + +instance + ( p ~ 'Package pname ss + , KnownSymbol qr + , RunQueryFindHandler m p hs chn ss (LookupService ss qr) hs + , MappingRight chn qr ~ () + , KnownSymbol mut + , RunQueryFindHandler m p hs chn ss (LookupService ss mut) hs + , MappingRight chn mut ~ () + , KnownSymbol sub + , RunQueryFindHandler m p hs chn ss (LookupService ss sub) hs + , MappingRight chn sub ~ () + , Intro.Introspect p ('Just qr) ('Just mut) ('Just sub) + ) => RunDocument p ('Just qr) ('Just mut) ('Just sub) m chn hs where + runDocument f svr d + = let i = Intro.introspect (Proxy @p) (Proxy @('Just qr)) (Proxy @('Just mut)) (Proxy @('Just sub)) + in case d of + QueryDoc q + -> runQuery f i svr [] () q + MutationDoc q + -> runQuery f i svr [] () q + SubscriptionDoc _ + -> pure $ singleErrValue "cannot execute subscriptions in this wire" + runDocumentSubscription f svr (SubscriptionDoc d) + = runSubscription f svr [] () d + runDocumentSubscription f svr d = yieldDocument f svr d + +instance + ( p ~ 'Package pname ss + , KnownSymbol qr + , RunQueryFindHandler m p hs chn ss (LookupService ss qr) hs + , MappingRight chn qr ~ () + , KnownSymbol mut + , RunQueryFindHandler m p hs chn ss (LookupService ss mut) hs + , MappingRight chn mut ~ () + , Intro.Introspect p ('Just qr) ('Just mut) 'Nothing + ) => RunDocument p ('Just qr) ('Just mut) 'Nothing m chn hs where + runDocument f svr d + = let i = Intro.introspect (Proxy @p) (Proxy @('Just qr)) (Proxy @('Just mut)) (Proxy @'Nothing) + in case d of + QueryDoc q + -> runQuery f i svr [] () q + MutationDoc q + -> runQuery f i svr [] () q + runDocumentSubscription = yieldDocument + +instance + ( p ~ 'Package pname ss + , KnownSymbol qr + , RunQueryFindHandler m p hs chn ss (LookupService ss qr) hs + , MappingRight chn qr ~ () + , KnownSymbol sub + , RunQueryFindHandler m p hs chn ss (LookupService ss sub) hs + , MappingRight chn sub ~ () + , Intro.Introspect p ('Just qr) 'Nothing ('Just sub) + ) => RunDocument p ('Just qr) 'Nothing ('Just sub) m chn hs where + runDocument f svr d + = let i = Intro.introspect (Proxy @p) (Proxy @('Just qr)) (Proxy @'Nothing) (Proxy @('Just sub)) + in case d of + QueryDoc q + -> runQuery f i svr [] () q + SubscriptionDoc _ + -> pure $ singleErrValue "cannot execute subscriptions in this wire" + runDocumentSubscription f svr (SubscriptionDoc d) + = runSubscription f svr [] () d + runDocumentSubscription f svr d = yieldDocument f svr d + +instance + ( p ~ 'Package pname ss + , KnownSymbol qr + , RunQueryFindHandler m p hs chn ss (LookupService ss qr) hs + , MappingRight chn qr ~ () + , Intro.Introspect p ('Just qr) 'Nothing 'Nothing + ) => RunDocument p ('Just qr) 'Nothing 'Nothing m chn hs where + runDocument f svr d + = let i = Intro.introspect (Proxy @p) (Proxy @('Just qr)) (Proxy @'Nothing) (Proxy @'Nothing) + in case d of + QueryDoc q + -> runQuery f i svr [] () q + runDocumentSubscription = yieldDocument + +instance + ( TypeError ('Text "you need to have a query in your schema") + ) => RunDocument p 'Nothing mut sub m chn hs where + runDocument _ = error "this should never be called" + runDocumentSubscription _ = error "this should never be called" + +yieldDocument :: + forall p qr mut sub m chn hs. + RunDocument p qr mut sub m chn hs + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m hs + -> Document p qr mut sub + -> ConduitT Aeson.Value Void IO () + -> IO () +yieldDocument f svr doc sink = do + (data_, errors) <- runWriterT (runDocument @p @qr @mut @sub @m @chn @hs f svr doc) + let (val :: Aeson.Value) + = case errors of + [] -> Aeson.object [ ("data", data_) ] + _ -> Aeson.object [ ("data", data_), ("errors", Aeson.listValue errValue errors) ] + runConduit $ yieldMany ([val] :: [Aeson.Value]) .| sink + +runQuery + :: forall m p s pname ss hs sname sanns ms chn inh. + ( RunQueryFindHandler m p hs chn ss s hs + , p ~ 'Package pname ss + , s ~ 'Service sname sanns ms + , inh ~ MappingRight chn sname ) + => (forall a. m a -> ServerErrorIO a) + -> Intro.Schema -> ServerT chn p m hs + -> [T.Text] + -> inh + -> ServiceQuery p s + -> WriterT [GraphQLError] IO Aeson.Value +runQuery f sch whole@(Services ss) path = runQueryFindHandler f sch whole path ss + +runSubscription + :: forall m p s pname ss hs sname sanns ms chn inh. + ( RunQueryFindHandler m p hs chn ss s hs + , p ~ 'Package pname ss + , s ~ 'Service sname sanns ms + , inh ~ MappingRight chn sname ) + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m hs + -> [T.Text] + -> inh + -> OneMethodQuery p s + -> ConduitT Aeson.Value Void IO () + -> IO () +runSubscription f whole@(Services ss) path + = runSubscriptionFindHandler f whole path ss + +class RunQueryFindHandler m p whole chn ss s hs where + runQueryFindHandler + :: ( p ~  'Package pname wholess + , s ~ 'Service sname sanns ms + , inh ~ MappingRight chn sname ) + => (forall a. m a -> ServerErrorIO a) + -> Intro.Schema -> ServerT chn p m whole + -> [T.Text] + -> ServicesT chn ss m hs + -> inh + -> ServiceQuery p s + -> WriterT [GraphQLError] IO Aeson.Value + runSubscriptionFindHandler + :: ( p ~  'Package pname wholess + , s ~ 'Service sname sanns ms + , inh ~ MappingRight chn sname ) + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m whole + -> [T.Text] + -> ServicesT chn ss m hs + -> inh + -> OneMethodQuery p s + -> ConduitT Aeson.Value Void IO () + -> IO () + +instance TypeError ('Text "Could not find handler for " ':<>: 'ShowType s) + => RunQueryFindHandler m p whole chn '[] s '[] where + runQueryFindHandler _ = error "this should never be called" + runSubscriptionFindHandler _ = error "this should never be called" +instance {-# OVERLAPPABLE #-} + RunQueryFindHandler m p whole chn ss s hs + => RunQueryFindHandler m p whole chn (other ': ss) s (h ': hs) where + runQueryFindHandler f sch whole path (_ :<&>: that) + = runQueryFindHandler f sch whole path that + runSubscriptionFindHandler f whole path (_ :<&>: that) + = runSubscriptionFindHandler f whole path that +instance {-# OVERLAPS #-} (s ~ 'Service sname sanns ms, KnownName sname, RunMethod m p whole chn sname ms h) + => RunQueryFindHandler m p whole chn (s ': ss) s (h ': hs) where + runQueryFindHandler f sch whole path (this :<&>: _) inh queries + = Aeson.object . catMaybes <$> mapM runOneQuery queries + where + -- if we include the signature we have to write + -- an explicit type signature for 'runQueryFindHandler' + runOneQuery (OneMethodQuery nm args) + = runMethod f whole (Proxy @sname) path nm inh this args + -- handle __typename + runOneQuery (TypeNameQuery nm) + = let realName = fromMaybe "__typename" nm + in pure $ Just (realName, Aeson.String $ T.pack $ nameVal (Proxy @sname)) + -- handle __schema + runOneQuery (SchemaQuery nm ss) + = do let realName = fromMaybe "__schema" nm + Just . (realName, ) <$> runIntroSchema path sch ss + -- handle __type + runOneQuery (TypeQuery nm ty ss) + = do let realName = fromMaybe "__schema" nm + res <- runIntroType path sch (Intro.TypeRef ty) ss + case res of + Just val -> pure $ Just (realName, val) + Nothing -> do tell [GraphQLError + (ServerError Invalid + $ "cannot find type '" <> T.unpack ty <> "'") + path] + pure $ Just (realName, Aeson.Null) + -- subscriptions should only have one element + runSubscriptionFindHandler f whole path (this :<&>: _) inh (OneMethodQuery nm args) sink + = runMethodSubscription f whole (Proxy @sname) path nm inh this args sink + runSubscriptionFindHandler _ _ _ _ _ (TypeNameQuery nm) sink + = let realName = fromMaybe "__typename" nm + o = Aeson.object [(realName, Aeson.String $ T.pack $ nameVal (Proxy @sname))] + in runConduit $ yieldMany ([o] :: [Aeson.Value]) .| sink + runSubscriptionFindHandler _ _ _ _ _ _ sink + = runConduit $ yieldMany + ([singleErrValue "__schema and __type are not supported in subscriptions"] + :: [Aeson.Value]) + .| sink + +class RunMethod m p whole chn sname ms hs where + runMethod + :: ( p ~ 'Package pname wholess + , inh ~ MappingRight chn sname ) + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m whole + -> Proxy sname -> [T.Text] -> Maybe T.Text -> inh + -> HandlersT chn inh ms m hs + -> NS (ChosenMethodQuery p) ms + -> WriterT [GraphQLError] IO (Maybe (T.Text, Aeson.Value)) + runMethodSubscription + :: ( p ~ 'Package pname wholess + , inh ~ MappingRight chn sname ) + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m whole + -> Proxy sname -> [T.Text] -> Maybe T.Text -> inh + -> HandlersT chn inh ms m hs + -> NS (ChosenMethodQuery p) ms + -> ConduitT Aeson.Value Void IO () + -> IO () + +instance RunMethod m p whole chn s '[] '[] where + runMethod _ = error "this should never be called" + runMethodSubscription _ = error "this should never be called" +instance (RunMethod m p whole chn s ms hs, KnownName mname, RunHandler m p whole chn args r h) + => RunMethod m p whole chn s ('Method mname anns args r ': ms) (h ': hs) where + -- handle normal methods + runMethod f whole _ path nm inh (h :<||>: _) (Z (ChosenMethodQuery args ret)) + = ((realName ,) <$>) <$> runHandler f whole (path ++ [realName]) (h inh) args ret + where realName = fromMaybe (T.pack $ nameVal (Proxy @mname)) nm + runMethod f whole p path nm inh (_ :<||>: r) (S cont) + = runMethod f whole p path nm inh r cont + -- handle subscriptions + runMethodSubscription f whole _ path nm inh (h :<||>: _) (Z (ChosenMethodQuery args ret)) sink + = runHandlerSubscription f whole (path ++ [realName]) (h inh) args ret sink + where realName = fromMaybe (T.pack $ nameVal (Proxy @mname)) nm + runMethodSubscription f whole p path nm inh (_ :<||>: r) (S cont) sink + = runMethodSubscription f whole p path nm inh r cont sink + +class Handles chn args r m h + => RunHandler m p whole chn args r h where + runHandler + :: (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m whole + -> [T.Text] + -> h + -> NP (ArgumentValue p) args + -> ReturnQuery p r + -> WriterT [GraphQLError] IO (Maybe Aeson.Value) + runHandlerSubscription + :: (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m whole + -> [T.Text] + -> h + -> NP (ArgumentValue p) args + -> ReturnQuery p r + -> ConduitT Aeson.Value Void IO () + -> IO () + +instance (ArgumentConversion chn ref t, RunHandler m p whole chn rest r h) + => RunHandler m p whole chn ('ArgSingle aname aanns ref ': rest) r (t -> h) where + runHandler f whole path h (ArgumentValue one :* rest) + = runHandler f whole path (h (convertArg (Proxy @chn) one)) rest + runHandlerSubscription f whole path h (ArgumentValue one :* rest) + = runHandlerSubscription f whole path (h (convertArg (Proxy @chn) one)) rest +instance ( MonadError ServerError m + , FromRef chn ref t + , ArgumentConversion chn ('ListRef ref) [t] + , RunHandler m p whole chn rest r h ) + => RunHandler m p whole chn ('ArgStream aname aanns ref ': rest) r (ConduitT () t m () -> h) where + runHandler f whole path h (ArgumentStream lst :* rest) + = let converted :: [t] = convertArg (Proxy @chn) lst + in runHandler f whole path (h (yieldMany converted)) rest + runHandlerSubscription f whole path h (ArgumentStream lst :* rest) sink + = let converted :: [t] = convertArg (Proxy @chn) lst + in runHandlerSubscription f whole path (h (yieldMany converted)) rest sink +instance (MonadError ServerError m) + => RunHandler m p whole chn '[] 'RetNothing (m ()) where + runHandler f _ path h Nil _ = do + res <- liftIO $ runExceptT (f h) + case res of + Right _ -> pure $ Just Aeson.Null + Left e -> tell [GraphQLError e path] >> pure Nothing + runHandlerSubscription f _ path h Nil _ sink = do + res <- liftIO $ runExceptT (f h) + case res of + Right _ -> runConduit $ yieldMany ([] :: [Aeson.Value]) .| sink + Left e -> yieldError e path sink +instance (MonadError ServerError m, ResultConversion m p whole chn r l) + => RunHandler m p whole chn '[] ('RetSingle r) (m l) where + runHandler f whole path h Nil (RSingle q) = do + res <- liftIO $ runExceptT (f h) + case res of + Right v -> convertResult f whole path q v + Left e -> tell [GraphQLError e path] >> pure Nothing + runHandlerSubscription f whole path h Nil (RSingle q) sink = do + res <- liftIO $ runExceptT (f h) + val <- case res of + Right v -> do + (data_, errors) <- runWriterT (convertResult f whole path q v) + case errors of + [] -> pure $ Aeson.object [ ("data", fromMaybe Aeson.Null data_) ] + _ -> pure $ Aeson.object [ ("data", fromMaybe Aeson.Null data_) + , ("errors", Aeson.listValue errValue errors) ] + Left e -> pure $ Aeson.object [ ("errors", Aeson.listValue errValue [GraphQLError e path]) ] + runConduit $ yieldMany ([val] :: [Aeson.Value]) .| sink +instance (MonadIO m, MonadError ServerError m, ResultConversion m p whole chn r l) + => RunHandler m p whole chn '[] ('RetStream r) (ConduitT l Void m () -> m ()) where + runHandler f whole path h Nil (RStream q) = do + queue <- liftIO newTMQueueIO + res <- liftIO $ runExceptT $ f $ h (sinkTMQueue queue) + case res of + Right _ -> do + info <- runConduit $ sourceTMQueue queue .| sinkList + Just . Aeson.toJSON . catMaybes <$> traverse (convertResult f whole path q) info + Left e -> tell [GraphQLError e []] >> pure Nothing + runHandlerSubscription f whole path h Nil (RStream q) sink = do + res <- liftIO $ runExceptT $ f $ h + (transPipe liftIO (mapInputM convert (error "this should not be called") sink)) + case res of + Right _ -> return () + Left e -> yieldError e path sink + where + convert :: l -> IO Aeson.Value + convert v = do + (data_, errors) <- runWriterT (convertResult f whole path q v) + case errors of + [] -> pure $ Aeson.object [ ("data", fromMaybe Aeson.Null data_) ] + _ -> pure $ Aeson.object [ ("data", fromMaybe Aeson.Null data_) + , ("errors", Aeson.listValue errValue errors) ] + +class FromRef chn ref t + => ArgumentConversion chn ref t where + convertArg :: Proxy chn -> ArgumentValue' p ref -> t +instance ArgumentConversion chn ('PrimitiveRef s) s where + convertArg _ (ArgPrimitive x) = x +instance FromSchema sch sty t + => ArgumentConversion chn ('SchemaRef sch sty) t where + convertArg _ (ArgSchema x) = fromSchema x +instance ArgumentConversion chn ref t + => ArgumentConversion chn ('ListRef ref) [t] where + convertArg p (ArgList x) = convertArg p <$> x +instance ArgumentConversion chn ref t + => ArgumentConversion chn ('OptionalRef ref) (Maybe t) where + convertArg p (ArgOptional x) = convertArg p <$> x + +class ToRef chn r l => ResultConversion m p whole chn r l where + convertResult :: (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m whole + -> [T.Text] + -> ReturnQuery' p r + -> l -> WriterT [GraphQLError] IO (Maybe Aeson.Value) + +instance Aeson.ToJSON t => ResultConversion m p whole chn ('PrimitiveRef t) t where + convertResult _ _ _ RetPrimitive = pure . Just . Aeson.toJSON +instance ( ToSchema sch l r + , RunSchemaQuery sch (sch :/: l) ) + => ResultConversion m p whole chn ('SchemaRef sch l) r where + convertResult _ _ _ (RetSchema r) t + = pure $ Just $ runSchemaQuery (toSchema' @_ @_ @sch @r t) r +instance ( MappingRight chn ref ~ t + , MappingRight chn sname ~ t + , LookupService ss ref ~ 'Service sname sanns ms + , RunQueryFindHandler m ('Package pname ss) whole chn ss ('Service sname sanns ms) whole) + => ResultConversion m ('Package pname ss) whole chn ('ObjectRef ref) t where + convertResult f whole path (RetObject q) h + = Just <$> runQuery @m @('Package pname ss) @(LookupService ss ref) f + (error "cannot inspect schema inside a field") + whole path h q +instance ResultConversion m p whole chn r s + => ResultConversion m p whole chn ('OptionalRef r) (Maybe s) where + convertResult _ _ _ _ Nothing + = pure Nothing + convertResult f whole path (RetOptional q) (Just x) + = convertResult f whole path q x +instance ResultConversion m p whole chn r s + => ResultConversion m p whole chn ('ListRef r) [s] where + convertResult f whole path (RetList q) xs + = Just . Aeson.toJSON . catMaybes <$> mapM (convertResult f whole path q) xs + +class RunSchemaQuery sch r where + runSchemaQuery + :: Term sch r + -> SchemaQuery sch r + -> Aeson.Value +instance ( Aeson.ToJSON (Term sch ('DEnum name choices)) ) + => RunSchemaQuery sch ('DEnum name choices) where + runSchemaQuery t _ = Aeson.toJSON t +instance ( KnownName rname, RunSchemaField sch fields ) + => RunSchemaQuery sch ('DRecord rname fields) where + runSchemaQuery (TRecord args) (QueryRecord rs) + = Aeson.object $ mapMaybe runOneQuery rs + where + runOneQuery (OneFieldQuery nm choice) + = let (val, fname) = runSchemaField args choice + realName = fromMaybe fname nm + in (realName,) <$> val + runOneQuery (TypeNameFieldQuery nm) + = let realName = fromMaybe "__typename" nm + -- add the 'R' because it's on return position + in pure (realName, Aeson.String $ T.pack $ nameVal (Proxy @rname) ++ "R") + + +class RunSchemaField sch args where + runSchemaField + :: NP (Field sch) args + -> NS (ChosenFieldQuery sch) args + -> (Maybe Aeson.Value, T.Text) + +instance RunSchemaField sch '[] where + runSchemaField = error "this should never be called" +instance (KnownName fname, RunSchemaType sch t, RunSchemaField sch fs) + => RunSchemaField sch ('FieldDef fname t ': fs) where + runSchemaField (Field x :* _) (Z (ChosenFieldQuery c)) + = (runSchemaType x c, T.pack $ nameVal (Proxy @fname)) + runSchemaField (_ :* xs) (S rest) + = runSchemaField xs rest + +class RunSchemaType sch t where + runSchemaType + :: FieldValue sch t + -> ReturnSchemaQuery sch t + -> Maybe Aeson.Value +instance ( Aeson.ToJSON t ) + => RunSchemaType sch ('TPrimitive t) where + runSchemaType (FPrimitive x) _ + = Just $ Aeson.toJSON x +instance RunSchemaType sch r + => RunSchemaType sch ('TList r) where + runSchemaType (FList xs) (RetSchList r) + = Just . Aeson.toJSON $ mapMaybe (`runSchemaType` r) xs +instance RunSchemaType sch r + => RunSchemaType sch ('TOption r) where + runSchemaType (FOption xs) (RetSchOptional r) + = xs >>= flip runSchemaType r +instance RunSchemaQuery sch (sch :/: l) + => RunSchemaType sch ('TSchematic l) where + runSchemaType (FSchematic t) (RetSchSchema r) + = Just $ runSchemaQuery t r + + +runIntroSchema + :: [T.Text] -> Intro.Schema -> GQL.SelectionSet + -> WriterT [GraphQLError] IO Aeson.Value +runIntroSchema path s@(Intro.Schema qr mut sub ts) ss + = do things <- catMaybes <$> traverse runOne ss + pure $ Aeson.object things + where + runOne (GQL.SelectionField (GQL.Field (coerce -> alias) (coerce -> nm) _ _ innerss)) + = let realName :: T.Text = fromMaybe nm alias + path' = path ++ [realName] + in fmap (realName,) <$> case nm of + "description" + -> pure $ Just Aeson.Null + "directives" + -> pure $ Just $ Aeson.Array [] + "queryType" + -> case qr >>= flip HM.lookup ts of + Nothing -> pure Nothing + Just ty -> runIntroType path' s ty innerss + "mutationType" + -> case mut >>= flip HM.lookup ts of + Nothing -> pure Nothing + Just ty -> runIntroType path' s ty innerss + "subscriptionType" + -> case sub >>= flip HM.lookup ts of + Nothing -> pure Nothing + Just ty -> runIntroType path' s ty innerss + "types" + -> do tys <- catMaybes <$> mapM (\t -> runIntroType path' s t innerss) (HM.elems ts) + pure $ Just $ Aeson.toJSON tys + _ -> do tell [GraphQLError + (ServerError Invalid + $ "field '" <> T.unpack nm <> "' was not found on type '__Schema'") + path] + pure Nothing + -- we do not support spreads here + runOne _ = pure Nothing + +runIntroType + :: [T.Text] -> Intro.Schema -> Intro.Type -> GQL.SelectionSet + -> WriterT [GraphQLError] IO (Maybe Aeson.Value) +runIntroType path s@(Intro.Schema _ _ _ ts) (Intro.TypeRef t) ss + = case HM.lookup t ts of + Nothing -> pure Nothing + Just ty -> runIntroType path s ty ss +runIntroType path s (Intro.Type k tnm fs vals ofT) ss + = do things <- catMaybes <$> traverse runOne ss + pure $ Just $ Aeson.object things + where + runOne (GQL.SelectionField (GQL.Field (coerce -> alias) (coerce -> nm) _ _ innerss)) + = let realName :: T.Text = fromMaybe nm alias + path' = path ++ [realName] + in fmap (realName,) <$> case (nm, innerss) of + ("kind", []) + -> pure $ Just $ Aeson.String $ T.pack (show k) + ("name", []) + -> pure $ Just $ maybe Aeson.Null Aeson.String tnm + ("description", []) + -> pure $ Just Aeson.Null + + ("fields", _) + -> case k of + Intro.OBJECT + -> do things <- mapM (\f -> runIntroFields path' f innerss) fs + pure $ Just $ Aeson.toJSON things + _ -> pure $ Just Aeson.Null + ("inputFields", _) + -> case k of + Intro.INPUT_OBJECT + -> do things <- mapM (\f -> runIntroFields path' f innerss) fs + pure $ Just $ Aeson.toJSON things + _ -> pure $ Just Aeson.Null + ("enumValues", _) + -> do things <- mapM (\e -> runIntroEnums path' e innerss) vals + pure $ Just $ Aeson.toJSON things + + ("ofType", _) + -> case ofT of + Nothing -> pure $ Just Aeson.Null + Just o -> runIntroType path' s o innerss + + -- unions and interfaces are not supported + ("interfaces", _) + -> pure $ Just $ Aeson.Array [] + ("possibleTypes", _) + -> pure $ Just $ Aeson.Array [] + + _ -> do tell [GraphQLError + (ServerError Invalid + $ "field '" <> T.unpack nm <> "' was not found on type '__Type'") + path] + pure Nothing + -- we do not support spreads here + runOne _ = pure Nothing + + runIntroFields + :: [T.Text] -> Intro.Field -> GQL.SelectionSet + -> WriterT [GraphQLError] IO (Maybe Aeson.Value) + runIntroFields fpath fld fss + = do things <- catMaybes <$> traverse (runIntroField fpath fld) fss + pure $ Just $ Aeson.object things + + runIntroField fpath (Intro.Field fnm fargs fty) + (GQL.SelectionField (GQL.Field (coerce -> alias) (coerce -> nm) _ _ innerss)) + = let realName :: T.Text = fromMaybe nm alias + fpath' = fpath ++ [realName] + in fmap (realName,) <$> case (nm, innerss) of + ("name", []) + -> pure $ Just $ Aeson.String fnm + ("description", []) + -> pure $ Just Aeson.Null + ("isDeprecated", []) + -> pure $ Just $ Aeson.Bool False + ("deprecationReason", []) + -> pure $ Just Aeson.Null + + -- this is used by __InputValue, + -- which is required when the field + -- is inside an INPUT_OBJECT + ("defaultValue", []) + -> pure $ Just Aeson.Null + + ("type", _) + -> runIntroType fpath' s fty innerss + ("args", _) + -> do things <- mapM (\i -> runIntroInputs fpath' i innerss) fargs + pure $ Just $ Aeson.toJSON things + + _ -> do tell [GraphQLError + (ServerError Invalid + $ "field '" <> T.unpack nm <> "' was not found on type '__Field'") + fpath] + pure Nothing + -- we do not support spreads here + runIntroField _ _ _ = pure Nothing + + runIntroEnums + :: [T.Text] -> Intro.EnumValue -> GQL.SelectionSet + -> WriterT [GraphQLError] IO (Maybe Aeson.Value) + runIntroEnums epath enm ess + = do things <- catMaybes <$> traverse (runIntroEnum epath enm) ess + pure $ Just $ Aeson.object things + + runIntroEnum epath (Intro.EnumValue enm) + (GQL.SelectionField (GQL.Field (coerce -> alias) (coerce -> nm) _ _ innerss)) + = let realName :: T.Text = fromMaybe nm alias + in fmap (realName,) <$> case (nm, innerss) of + ("name", []) + -> pure $ Just $ Aeson.String enm + ("description", []) + -> pure $ Just Aeson.Null + ("isDeprecated", []) + -> pure $ Just $ Aeson.Bool False + ("deprecationReason", []) + -> pure $ Just Aeson.Null + + _ -> do tell [GraphQLError + (ServerError Invalid + $ "field '" <> T.unpack nm <> "' was not found on type '__EnumValue'") + epath] + pure Nothing + -- we do not support spreads here + runIntroEnum _ _ _ = pure Nothing + + runIntroInputs + :: [T.Text] -> Intro.Input -> GQL.SelectionSet + -> WriterT [GraphQLError] IO (Maybe Aeson.Value) + runIntroInputs ipath inm iss + = do things <- catMaybes <$> traverse (runIntroInput ipath inm) iss + pure $ Just $ Aeson.object things + + runIntroInput ipath (Intro.Input inm def ty) + (GQL.SelectionField (GQL.Field (coerce -> alias) (coerce -> nm) _ _ innerss)) + = let realName :: T.Text = fromMaybe nm alias + ipath' = ipath ++ [realName] + in fmap (realName,) <$> case (nm, innerss) of + ("name", []) + -> pure $ Just $ Aeson.String inm + ("description", []) + -> pure $ Just Aeson.Null + ("defaultValue", []) + -> pure $ Just $ maybe Aeson.Null Aeson.String def + + ("type", _) + -> runIntroType ipath' s ty innerss + + _ -> do tell [GraphQLError + (ServerError Invalid + $ "field '" <> T.unpack nm <> "' was not found on type '__Field'") + ipath] + pure Nothing + -- we do not support spreads here + runIntroInput _ _ _ = pure Nothing diff --git a/src/Mu/GraphQL/Server.hs b/src/Mu/GraphQL/Server.hs new file mode 100644 --- /dev/null +++ b/src/Mu/GraphQL/Server.hs @@ -0,0 +1,218 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language GADTs #-} +{-# language OverloadedLists #-} +{-# language OverloadedStrings #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-| +Description : Execute a Mu 'Server' using GraphQL + +This module allows you to server a Mu 'Server' +as a WAI 'Application' using GraphQL. + +The simples way is to use 'runGraphQLAppQuery' +(if you only provide GraphQL queries) or +'runGraphQLApp' (if you also have mutations +or subscriptions). All other variants provide +more control over the settings. +-} +module Mu.GraphQL.Server ( + GraphQLApp + -- * Run an GraphQL resolver directly + , runGraphQLApp + , runGraphQLAppSettings + , runGraphQLAppQuery + , runGraphQLAppTrans + -- * Build a WAI 'Application' + , graphQLApp + , graphQLAppQuery + , graphQLAppTrans + , graphQLAppTransQuery +) where + +import Control.Applicative ((<|>)) +import Control.Monad (join) +import qualified Data.Aeson as A +import Data.Aeson.Text (encodeToLazyText) +import Data.ByteString.Lazy (fromStrict, toStrict) +import qualified Data.HashMap.Strict as HM +import Data.Proxy +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import qualified Data.Text.Lazy.Encoding as T +import Language.GraphQL.Draft.Parser (parseExecutableDoc) +import Network.HTTP.Types.Header (hContentType) +import Network.HTTP.Types.Method (StdMethod (..), parseMethod) +import Network.HTTP.Types.Status (ok200) +import Network.Wai +import Network.Wai.Handler.Warp (Port, Settings, run, runSettings) +import qualified Network.Wai.Handler.WebSockets as WS +import qualified Network.WebSockets as WS + +import Mu.GraphQL.Query.Parse +import Mu.GraphQL.Query.Run +import Mu.GraphQL.Subscription.Protocol +import Mu.Server + +data GraphQLInput = GraphQLInput T.Text VariableMapC (Maybe T.Text) + +instance A.FromJSON GraphQLInput where + parseJSON = A.withObject "GraphQLInput" $ + \v -> GraphQLInput + <$> v A..: "query" + <*> (v A..: "variables" <|> pure HM.empty) + <*> v A..:? "operationName" + +-- | Turn a Mu GraphQL 'Server' into a WAI 'Application'. +-- Use this version when your server has not only +-- queries, but also mutations or subscriptions. +graphQLApp :: + ( GraphQLApp p qr mut sub ServerErrorIO chn hs ) + => ServerT chn p ServerErrorIO hs + -> Proxy qr + -> Proxy mut + -> Proxy sub + -> Application +graphQLApp = graphQLAppTrans id + +-- | Turn a Mu GraphQL 'Server' into a WAI 'Application'. +-- Use this version when your server has only queries. +graphQLAppQuery :: + forall qr p chn hs. + ( GraphQLApp p ('Just qr) 'Nothing 'Nothing ServerErrorIO chn hs ) + => ServerT chn p ServerErrorIO hs + -> Proxy qr + -> Application +graphQLAppQuery svr _ + = graphQLApp svr (Proxy @('Just qr)) (Proxy @'Nothing) (Proxy @'Nothing) + +-- | Turn a Mu GraphQL 'Server' into a WAI 'Application' +-- using a combined transformer stack. +-- See also documentation for 'graphQLAppQuery'. +graphQLAppTransQuery :: + forall qr m p chn hs. + ( GraphQLApp p ('Just qr) 'Nothing 'Nothing m chn hs ) + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m hs + -> Proxy qr + -> Application +graphQLAppTransQuery f svr _ + = graphQLAppTrans f svr (Proxy @('Just qr)) (Proxy @'Nothing) (Proxy @'Nothing) + +-- | Turn a Mu GraphQL 'Server' into a WAI 'Application' +-- using a combined transformer stack. +-- See also documentation for 'graphQLApp'. +graphQLAppTrans :: + ( GraphQLApp p qr mut sub m chn hs ) + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m hs + -> Proxy qr + -> Proxy mut + -> Proxy sub + -> Application +graphQLAppTrans f server q m s + = WS.websocketsOr WS.defaultConnectionOptions + (wsGraphQLAppTrans f server q m s) + (httpGraphQLAppTrans f server q m s) + +httpGraphQLAppTrans :: + ( GraphQLApp p qr mut sub m chn hs ) + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m hs + -> Proxy qr + -> Proxy mut + -> Proxy sub + -> Application +httpGraphQLAppTrans f server q m s req res = + case parseMethod (requestMethod req) of + Left err -> toError $ decodeUtf8 err + Right GET -> do + let qst = queryString req + opN = decodeUtf8 <$> join (lookup "operationName" qst) + case (fmap decodeUtf8 <$> lookup "query" qst, lookup "variables" qst) of + (Just (Just qry), Just (Just vars)) -> + case A.eitherDecode $ fromStrict vars of + Left err -> toError $ T.pack err + Right vrs -> execQuery opN vrs qry + (Just (Just qry), _) -> execQuery opN HM.empty qry + _ -> toError "Error parsing query" + Right POST -> do + body <- strictRequestBody req + case lookup hContentType $ requestHeaders req of + Just "application/json" -> + case A.eitherDecode body of + Left err -> toError $ T.pack err + Right (GraphQLInput qry vars opName) -> execQuery opName vars qry + Just "application/graphql" -> + execQuery Nothing HM.empty (decodeUtf8 $ toStrict body) + _ -> toError "No `Content-Type` header found!" + _ -> toError "Unsupported method" + where + execQuery :: Maybe T.Text -> VariableMapC -> T.Text -> IO ResponseReceived + execQuery opn vals qry = + case parseExecutableDoc qry of + Left err -> toError err + Right doc -> runPipeline f server q m s opn vals doc >>= toResponse + toError :: T.Text -> IO ResponseReceived + toError err = toResponse $ A.object [ ("errors", A.Array [ A.object [ ("message", A.String err) ] ])] + toResponse :: A.Value -> IO ResponseReceived + toResponse = res . responseBuilder ok200 [] . T.encodeUtf8Builder . encodeToLazyText + +wsGraphQLAppTrans + :: ( GraphQLApp p qr mut sub m chn hs ) + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m hs + -> Proxy qr + -> Proxy mut + -> Proxy sub + -> WS.ServerApp +wsGraphQLAppTrans f server q m s conn + = do conn' <- WS.acceptRequest conn + flip protocol conn' $ runSubscriptionPipeline f server q m s + +-- | Run a Mu 'graphQLApp' using the given 'Settings'. +-- +-- Go to 'Network.Wai.Handler.Warp' to declare 'Settings'. +runGraphQLAppSettings :: + ( GraphQLApp p qr mut sub ServerErrorIO chn hs ) + => Settings + -> ServerT chn p ServerErrorIO hs + -> Proxy qr + -> Proxy mut + -> Proxy sub + -> IO () +runGraphQLAppSettings st svr q m s = runSettings st (graphQLApp svr q m s) + +-- | Run a Mu 'graphQLApp' on the given port. +runGraphQLApp :: + ( GraphQLApp p qr mut sub ServerErrorIO chn hs ) + => Port + -> ServerT chn p ServerErrorIO hs + -> Proxy qr + -> Proxy mut + -> Proxy sub + -> IO () +runGraphQLApp port svr q m s = run port (graphQLApp svr q m s) + +-- | Run a Mu 'graphQLApp' on a transformer stack on the given port. +runGraphQLAppTrans :: + ( GraphQLApp p qr mut sub m chn hs ) + => Port + -> (forall a. m a -> ServerErrorIO a) + -> ServerT chn p m hs + -> Proxy qr + -> Proxy mut + -> Proxy sub + -> IO () +runGraphQLAppTrans port f svr q m s = run port (graphQLAppTrans f svr q m s) + +-- | Run a query-only Mu 'graphQLApp' on the given port. +runGraphQLAppQuery :: + ( GraphQLApp p ('Just qr) 'Nothing 'Nothing ServerErrorIO chn hs ) + => Port + -> ServerT chn p ServerErrorIO hs + -> Proxy qr + -> IO () +runGraphQLAppQuery port svr q = run port (graphQLAppQuery svr q) diff --git a/src/Mu/GraphQL/Subscription/Protocol.hs b/src/Mu/GraphQL/Subscription/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Mu/GraphQL/Subscription/Protocol.hs @@ -0,0 +1,158 @@ +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} +{- +This module implements the protocol as specified in +https://github.com/apollographql/subscriptions-transport-ws/blob/master/PROTOCOL.md +-} +module Mu.GraphQL.Subscription.Protocol where + +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Monad (forM_) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Aeson ((.:), (.:?), (.=)) +import qualified Data.Aeson as A +import Data.Conduit +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Language.GraphQL.Draft.Parser (parseExecutableDoc) +import Language.GraphQL.Draft.Syntax (ExecutableDocument) +import qualified ListT as L +import Network.WebSockets +import qualified StmContainers.Map as M + +import Mu.GraphQL.Query.Parse + +protocol :: ( Maybe T.Text -> VariableMapC -> ExecutableDocument + -> ConduitT A.Value Void IO () + -> IO () ) + -> Connection -> IO () +protocol f conn = start + where + -- listen for GQL_CONNECTION_INIT + start = do + msg <- receiveJSON conn + case msg of + Just (GQLConnectionInit _) + -> do -- send GQL_CONNECTION_ACK + sendJSON conn GQLConnectionAck + vars <- M.newIO + -- send GQL_KEEP_ALIVE each 1s. + withAsync keepAlive $ \ka -> + -- start listening for incoming messages + listen ka vars + _ -> start -- Keep waiting + -- keep-alive + keepAlive = do + sendJSON conn GQLKeepAlive + threadDelay 1000000 + keepAlive + -- listen for messages from client + listen ka vars = do + msg <- receiveJSON conn + case msg of + Just (GQLStart i q v o) -- start handling + -> withAsync (handle i q v o >> atomically (M.delete i vars)) $ \t -> do + atomically $ M.insert t i vars + listen ka vars + Just (GQLStop i) -- stop with handling that query + -> do r <- atomically $ M.lookup i vars + case r of + Nothing -> return () + Just a -> do cancel a + atomically $ M.delete i vars + listen ka vars + Just GQLTerminate -- terminate all queries + -> do cancelAll ka vars + sendClose conn ("GraphQL session terminated" :: T.Text) + _ -> listen ka vars -- Keep going + -- Handle a single query + handle i q v o + = case parseExecutableDoc q of + Left err -> sendJSON conn (GQLError i (A.toJSON err)) + Right d -> do + f o v d (cndt i) + sendJSON conn (GQLComplete i) + -- Conduit which sends the results via the wire + cndt i = do + msg <- await + case msg of + Nothing -> return () + Just v -> do liftIO $ sendJSON conn (GQLData i v) + cndt i + -- Cancel all pending subscriptions + cancelAll ka vars + = do cancel ka + vs <- atomically $ L.toList $ M.listT vars + forM_ (map snd vs) cancel + +receiveJSON :: A.FromJSON a => Connection -> IO (Maybe a) +receiveJSON conn = do + d <- receiveData conn + return $ A.decode d + +sendJSON :: A.ToJSON a => Connection -> a -> IO () +sendJSON conn v + = sendTextData conn (A.encode v) + +data ClientMessage + = GQLConnectionInit { initPayload :: Maybe A.Value } + | GQLStart { clientMsgId :: T.Text + , query :: T.Text + , variables :: VariableMapC + , operationName :: Maybe T.Text} + | GQLStop { clientMsgId :: T.Text } + | GQLTerminate + deriving Show + +data ServerMessage + = GQLConnectionError { errorPayload :: Maybe A.Value } + | GQLConnectionAck + | GQLData { serverMsgId :: T.Text + , payload :: A.Value } + | GQLError { serverMsgId :: T.Text + , payload :: A.Value } + | GQLComplete { serverMsgId :: T.Text} + | GQLKeepAlive + deriving Show + +instance A.FromJSON ClientMessage where + parseJSON = A.withObject "ClientMessage" $ \v -> do + ty :: String <- v .: "type" + case ty of + "connection_init" + -> GQLConnectionInit <$> v .:? "payload" + "start" + -> do i <- v .: "id" + (q,vrs,opN) <- v .: "payload" >>= parsePayload + pure $ GQLStart i q vrs opN + "stop" + -> GQLStop <$> v .: "id" + "terminate" + -> pure GQLTerminate + _ -> empty + where + parsePayload = A.withObject "ClientMessage/GQL_START" $ + \v -> (,,) <$> v .: "query" + <*> (v .: "variables" <|> pure HM.empty) + <*> v .:? "operationName" + +theType :: (A.KeyValue kv) => T.Text -> kv +theType t = "type" .= t + +instance A.ToJSON ServerMessage where + toJSON (GQLConnectionError e) + = A.object [theType "connection_error", "payload" .= e] + toJSON GQLConnectionAck + = A.object [theType "connection_acl"] + toJSON (GQLData i p) + = A.object [theType "data", "id" .= i, "payload" .= p] + toJSON (GQLError i p) + = A.object [theType "error", "id" .= i, "payload" .= p] + toJSON (GQLComplete i) + = A.object [theType "complete", "id" .= i] + toJSON GQLKeepAlive + = A.object [theType "connection_keep_alive"]