First GraphQL app! (#133)

graphql/exe/Main.hs

@@ -0,0 +1,81 @@
+{-# language DataKinds             #-}
+{-# language FlexibleContexts      #-}
+{-# language OverloadedStrings     #-}
+{-# language PartialTypeSignatures #-}
+{-# language PolyKinds             #-}
+{-# language ScopedTypeVariables   #-}
+{-# language TupleSections         #-}
+{-# language TypeApplications      #-}
+{-# language TypeOperators         #-}
+module Main where
+
+import           Data.List         (find)
+import           Data.Maybe        (fromMaybe)
+import           Data.Proxy
+import           Data.Text         (Text)
+
+import           Mu.GraphQL.Server
+import           Mu.Rpc
+import           Mu.Schema
+import           Mu.Server
+
+main :: IO ()
+main = runGraphQLApp 8080 libraryServer (Proxy @"Query") (Proxy @"Mutation")
+
+type ServiceDefinition
+  = 'Package ('Just "library")
+      '[ Object "Book" '[]
+        '[ ObjectField "id"     '[] '[] ('RetSingle ('PrimitiveRef Integer))
+         , ObjectField "title"  '[] '[] ('RetSingle ('PrimitiveRef Text))
+         , ObjectField "author" '[] '[] ('RetSingle ('ObjectRef "Author"))
+         ]
+      , Object "Author" '[]
+        '[ ObjectField "id"    '[] '[] ('RetSingle ('PrimitiveRef Integer))
+         , ObjectField "name"  '[] '[] ('RetSingle ('PrimitiveRef Text))
+         , ObjectField "books" '[] '[] ('RetSingle ('ListRef ('ObjectRef "Book")))
+         ]
+      , Object "Query" '[]
+         '[ ObjectField "author" '[]
+              '[ 'ArgSingle ('Just "name") '[] ('PrimitiveRef Text)]
+              ('RetSingle ('OptionalRef ('ObjectRef "Author")))
+          ]
+      , Object "Mutation" '[] '[]
+      ]
+
+type ServiceMapping = '[
+    "Book"   ':-> (Integer, Integer)
+  , "Author" ':-> Integer
+  ]
+
+library :: [(Integer, Text, [(Integer, Text)])]
+library
+  = [ (1, "alex", [(1, "haskell is nice"), (2, "haskell is cool")])
+    , (2, "kant", [(3, "critique of pure reason")])]
+
+libraryServer :: forall m. (MonadServer m) => ServerT ServiceMapping ServiceDefinition m _
+libraryServer
+  = Services $ (bookId :<||>: bookTitle :<||>: bookAuthor :<||>: H0)
+               :<&>: (authorId :<||>: authorName :<||>: authorBooks :<||>: H0)
+               :<&>: (noContext findAuthor :<||>: H0)
+               :<&>: H0 :<&>: S0
+  where bookId (_, bid) = pure bid
+        bookTitle (aid, bid)
+          = case find (\(aid', _, _) -> aid == aid') library of
+              Nothing            -> pure ""
+              Just (_, _, books) -> pure $ fromMaybe "" (lookup bid books)
+        bookAuthor (aid, _) = pure aid
+
+        authorId = pure
+        authorName aid
+          = case find (\(aid', _, _) -> aid == aid') library of
+              Nothing            -> pure ""
+              Just (_, aname, _) -> pure aname
+        authorBooks aid
+          = case find (\(aid', _, _) -> aid == aid') library of
+              Nothing            -> pure []
+              Just (_, _, books) -> pure $ map ((aid, ) . fst) books
+
+        findAuthor aname
+          = case find (\(_, aname', _) -> aname == aname') library of
+              Nothing          -> pure Nothing
+              Just (aid, _, _) -> pure $ Just aid

graphql/exe/hie.yaml

@@ -0,0 +1 @@
+cradle: { stack: { component: "mu-graphql:exe:library-graphql" } }

graphql/mu-graphql.cabal

@@ -14,8 +14,7 @@ homepage:      https://higherkindness.io/mu-haskell/
 bug-reports:   https://github.com/higherkindness/mu-haskell/issues
 
 library
-  exposed-modules:
-    Mu.GraphQL.Server
+  exposed-modules:  Mu.GraphQL.Server
   other-modules:
     Mu.GraphQL.Annotations
     Mu.GraphQL.Query.Definition
@@ -43,3 +42,15 @@ library
   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
+    , mu-graphql
+    , mu-rpc
+    , mu-schema
+    , text

graphql/src/Mu/GraphQL/Query/Parse.hs

@@ -182,7 +182,7 @@ class ParseArgs (p :: Package') (args :: [Argument']) where
 instance ParseArgs p '[] where
   parseArgs _ _ = pure Nil
 instance (KnownName aname, ParseArg p a, ParseArgs p as, FindDefaultArgValue aanns)
-         => ParseArgs p ('ArgSingle aname aanns a ': as) where
+         => ParseArgs p ('ArgSingle ('Just aname) aanns a ': as) where
   parseArgs vmap args
     = case find ((== nameVal (Proxy @aname)) . T.unpack . GQL.unName . GQL._aName) args of
         Just (GQL.Argument _ x)

graphql/src/Mu/GraphQL/Query/Run.hs

@@ -209,3 +209,13 @@ instance ( MappingRight chn ref ~ t
          => ResultConversion ('Package pname ss) whole chn ('ObjectRef ref) t where
   convertResult whole (RetObject q) h
     = Just <$> runQuery @('Package pname ss) @(LookupService ss ref) whole h q
+instance ResultConversion p whole chn r s
+        => ResultConversion p whole chn ('OptionalRef r) (Maybe s) where
+  convertResult _ _ Nothing
+    = pure Nothing
+  convertResult whole (RetOptional q) (Just x)
+    = convertResult whole q x
+instance ResultConversion p whole chn r s
+        => ResultConversion p whole chn ('ListRef r) [s] where
+  convertResult whole (RetList q) xs
+    = Just . Aeson.toJSON . catMaybes <$> mapM (convertResult whole q) xs