mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-09-11 14:36:01 +03:00
First GraphQL app! (#133)
This commit is contained in:
parent
6a733dbd6b
commit
bd950a4b91
81
graphql/exe/Main.hs
Normal file
81
graphql/exe/Main.hs
Normal file
@ -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
|
1
graphql/exe/hie.yaml
Normal file
1
graphql/exe/hie.yaml
Normal file
@ -0,0 +1 @@
|
||||
cradle: { stack: { component: "mu-graphql:exe:library-graphql" } }
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user