mu-graphql (empty) → 0.3.0.0

raw patch · 14 files changed

+3155/−0 lines, 14 filesdep +aesondep +asyncdep +attoparsecsetup-changed

Dependencies added: aeson, async, attoparsec, base, bytestring, conduit, graphql-parser, http-types, list-t, mtl, mu-graphql, mu-rpc, mu-schema, parsers, regex-tdfa, scientific, sop-core, stm, stm-chans, stm-conduit, stm-containers, template-haskell, text, unordered-containers, uuid, wai, wai-extra, wai-websockets, warp, warp-tls, websockets

Files

• LICENSE +202/−0
• Setup.hs +2/−0
• exe/Main.hs +103/−0
• exe/schema.graphql +27/−0
• mu-graphql.cabal +80/−0
• src/Mu/GraphQL/Annotations.hs +116/−0
• src/Mu/GraphQL/Quasi.hs +202/−0
• src/Mu/GraphQL/Quasi/LostParser.hs +38/−0
• src/Mu/GraphQL/Query/Definition.hs +114/−0
• src/Mu/GraphQL/Query/Introspection.hs +356/−0
• src/Mu/GraphQL/Query/Parse.hs +768/−0
• src/Mu/GraphQL/Query/Run.hs +771/−0
• src/Mu/GraphQL/Server.hs +218/−0
• src/Mu/GraphQL/Subscription/Protocol.hs +158/−0

@@ -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. <http://47deg.com>++   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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

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

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

@@ -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 <http://47deg.com 47 Degrees>+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

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

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

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

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

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

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

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

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

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