mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-09-11 14:36:01 +03:00
Missing GraphQL instances + enum example (#204)
This commit is contained in:
parent
c92f97d0ec
commit
1d7a52a2a6
@ -39,6 +39,7 @@ executable seed-server
|
||||
, mu-protobuf >=0.3.0
|
||||
, mu-rpc >=0.3.0
|
||||
, mu-schema >=0.3.0
|
||||
, random
|
||||
, stm
|
||||
, text
|
||||
, wai
|
||||
@ -57,6 +58,7 @@ executable seed-server-optics
|
||||
, mu-protobuf >=0.3.0
|
||||
, mu-rpc >=0.3.0
|
||||
, mu-schema >=0.3.0
|
||||
, random
|
||||
, stm
|
||||
, text
|
||||
|
||||
|
31
examples/seed/seed.graphql
Normal file
31
examples/seed/seed.graphql
Normal file
@ -0,0 +1,31 @@
|
||||
schema {
|
||||
query: PeopleService
|
||||
}
|
||||
|
||||
type PeopleService {
|
||||
getPerson(arg: PeopleRequest): PeopleResponse
|
||||
getWeather(arg: WeatherRequest): WeatherResponse
|
||||
}
|
||||
|
||||
type Person {
|
||||
name: String!
|
||||
age: Int!
|
||||
}
|
||||
input PeopleRequest {
|
||||
name: String!
|
||||
}
|
||||
type PeopleResponse {
|
||||
person: Person
|
||||
}
|
||||
|
||||
enum Weather {
|
||||
sunny
|
||||
cloudy
|
||||
rainy
|
||||
}
|
||||
input WeatherRequest {
|
||||
currentWeather: Weather
|
||||
}
|
||||
type WeatherResponse {
|
||||
message: String!
|
||||
}
|
@ -1,5 +1,4 @@
|
||||
syntax = "proto3";
|
||||
|
||||
package seed;
|
||||
|
||||
message Person { string name = 1; int32 age = 2; }
|
||||
@ -7,12 +6,19 @@ message PeopleRequest { string name = 1; }
|
||||
message PeopleResponse { Person person = 1; }
|
||||
|
||||
enum Weather {
|
||||
sunny = 0;
|
||||
sunny = 0;
|
||||
cloudy = 1;
|
||||
rainy = 2;
|
||||
rainy = 2;
|
||||
}
|
||||
message WeatherRequest {
|
||||
Weather currentWeather = 1;
|
||||
}
|
||||
message WeatherResponse {
|
||||
string message = 1;
|
||||
}
|
||||
|
||||
service PeopleService {
|
||||
rpc getPerson (PeopleRequest) returns (PeopleResponse);
|
||||
rpc getPersonStream (stream PeopleRequest) returns (stream PeopleResponse);
|
||||
rpc getWeather (WeatherRequest) returns (WeatherResponse);
|
||||
}
|
||||
|
@ -1,11 +1,13 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language DeriveAnyClass #-}
|
||||
{-# language DeriveGeneric #-}
|
||||
{-# language DerivingVia #-}
|
||||
{-# language DuplicateRecordFields #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language PartialTypeSignatures #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
|
||||
|
||||
module Main where
|
||||
@ -24,6 +26,7 @@ import Mu.GRpc.Server
|
||||
import Mu.Schema
|
||||
import Mu.Server
|
||||
import Network.Wai
|
||||
import System.Random
|
||||
|
||||
import Schema
|
||||
|
||||
@ -46,6 +49,29 @@ newtype PeopleResponse = PeopleResponse
|
||||
, ToSchema SeedSchema "PeopleResponse"
|
||||
, FromSchema SeedSchema "PeopleResponse" )
|
||||
|
||||
type WeatherMapping
|
||||
= '[ "SUNNY" ':-> "sunny"
|
||||
, "CLOUDY" ':-> "cloudy"
|
||||
, "RAINY" ':-> "rainy" ]
|
||||
|
||||
data Weather = SUNNY | CLOUDY | RAINY
|
||||
deriving ( Eq, Show, Ord, Generic )
|
||||
deriving ( ToSchema SeedSchema "Weather"
|
||||
, FromSchema SeedSchema "Weather" )
|
||||
via ( CustomFieldMapping "Weather" WeatherMapping Weather )
|
||||
|
||||
newtype WeatherRequest = WeatherRequest
|
||||
{ currentWeather :: Maybe Weather
|
||||
} deriving ( Eq, Show, Ord, Generic
|
||||
, ToSchema SeedSchema "WeatherRequest"
|
||||
, FromSchema SeedSchema "WeatherRequest" )
|
||||
|
||||
newtype WeatherResponse = WeatherResponse
|
||||
{ message :: T.Text
|
||||
} deriving ( Eq, Show, Ord, Generic
|
||||
, ToSchema SeedSchema "WeatherResponse"
|
||||
, FromSchema SeedSchema "WeatherResponse" )
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStrLn "running seed application"
|
||||
@ -63,6 +89,7 @@ server :: (MonadServer m, MonadLogger m) => SingleServerT PeopleService m _
|
||||
server = singleService
|
||||
( method @"getPerson" getPerson
|
||||
, method @"getPersonStream" getPersonStream
|
||||
, method @"getWeather" getWeather
|
||||
)
|
||||
|
||||
evolvePerson :: PeopleRequest -> PeopleResponse
|
||||
@ -81,3 +108,14 @@ getPersonStream source sink = runConduit $ source .| C.mapM reStream .| sink
|
||||
liftIO $ threadDelay (2 * 1000 * 1000) -- 2 sec
|
||||
logDebugN $ T.pack $ "stream request: " ++ show req
|
||||
pure $ evolvePerson req
|
||||
|
||||
getWeather :: (MonadServer m)
|
||||
=> WeatherRequest
|
||||
-> m WeatherResponse
|
||||
getWeather (WeatherRequest Nothing)
|
||||
= pure $ WeatherResponse "who knows?"
|
||||
getWeather (WeatherRequest (Just w))
|
||||
= pure $ WeatherResponse $ go w
|
||||
where go SUNNY = "is sunny! 😄"
|
||||
go CLOUDY = "is cloudy 😟"
|
||||
go RAINY = "is rainy... 😭"
|
||||
|
@ -23,10 +23,12 @@ import Mu.Server
|
||||
|
||||
import Schema
|
||||
|
||||
type Person = Term SeedSchema (SeedSchema :/: "Person")
|
||||
type PeopleRequest = Term SeedSchema (SeedSchema :/: "PeopleRequest")
|
||||
type PeopleResponse = Term SeedSchema (SeedSchema :/: "PeopleResponse")
|
||||
type Weather = Term SeedSchema (SeedSchema :/: "Weather")
|
||||
type Person = Term SeedSchema (SeedSchema :/: "Person")
|
||||
type PeopleRequest = Term SeedSchema (SeedSchema :/: "PeopleRequest")
|
||||
type PeopleResponse = Term SeedSchema (SeedSchema :/: "PeopleResponse")
|
||||
type Weather = Term SeedSchema (SeedSchema :/: "Weather")
|
||||
type WeatherRequest = Term SeedSchema (SeedSchema :/: "WeatherRequest")
|
||||
type WeatherResponse = Term SeedSchema (SeedSchema :/: "WeatherResponse")
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
@ -39,17 +41,12 @@ main = do
|
||||
server :: (MonadServer m, MonadLogger m) => SingleServerT PeopleService m _
|
||||
server = singleService
|
||||
( method @"getPerson" getPerson
|
||||
, method @"getPersonStream" getPersonStream)
|
||||
, method @"getPersonStream" getPersonStream
|
||||
, method @"getWeather" getWeather )
|
||||
|
||||
evolvePerson :: PeopleRequest -> PeopleResponse
|
||||
evolvePerson req = record1 (Just $ record (req ^. #name, 18))
|
||||
|
||||
getWeather :: Weather -> IO ()
|
||||
getWeather e
|
||||
| e `is` #sunny = putStrLn "is sunny! 😄"
|
||||
| e `is` #cloudy = putStrLn "is cloudy 😟"
|
||||
| e `is` #rainy = putStrLn "is rainy... 😭"
|
||||
|
||||
getPerson :: Monad m => PeopleRequest -> m PeopleResponse
|
||||
getPerson = pure . evolvePerson
|
||||
|
||||
@ -64,3 +61,16 @@ getPersonStream source sink = runConduit $ source .| C.mapM reStream .| sink
|
||||
liftIO $ threadDelay (2 * 1000 * 1000) -- 2 sec
|
||||
logDebugN $ T.pack $ "stream request: " ++ show req
|
||||
pure $ evolvePerson req
|
||||
|
||||
getWeather :: (MonadServer m)
|
||||
=> WeatherRequest
|
||||
-> m WeatherResponse
|
||||
getWeather msg
|
||||
| Just w <- msg ^. #currentWeather
|
||||
= pure $ record1 $ go w
|
||||
| otherwise
|
||||
= pure $ record1 "who knows?"
|
||||
where go e | e `is` #sunny = "is sunny! 😄"
|
||||
| e `is` #cloudy = "is cloudy 😟"
|
||||
| e `is` #rainy = "is rainy... 😭"
|
||||
| otherwise = error "this should never happen"
|
||||
|
@ -384,7 +384,7 @@ instance ParseArg p a
|
||||
parseArgs _ _ _ _
|
||||
= throwError "this field receives one single argument"
|
||||
-- more than one argument
|
||||
instance ( KnownName aname, ParseArg p a, ParseArgs p s m as
|
||||
instance ( KnownName aname, ParseMaybeArg p a, ParseArgs p s m as
|
||||
, s ~ 'Service snm sms, m ~ 'Method mnm margs mr
|
||||
, ann ~ GetArgAnnotationMay (AnnotatedPackage DefaultValue p) snm mnm aname
|
||||
, FindDefaultArgValue ann )
|
||||
@ -393,11 +393,12 @@ instance ( KnownName aname, ParseArg p a, ParseArgs p s m as
|
||||
= 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)
|
||||
-> (:*) <$> (ArgumentValue <$> parseMaybeArg vmap aname (Just x))
|
||||
<*> parseArgs ps pm vmap args
|
||||
Nothing
|
||||
-> do x <- findDefaultArgValue (Proxy @ann) aname
|
||||
(:*) <$> (ArgumentValue <$> parseArg' vmap aname (constToValue x))
|
||||
-> do let x = findDefaultArgValue (Proxy @ann)
|
||||
(:*) <$> (ArgumentValue <$> parseMaybeArg vmap aname
|
||||
(constToValue <$> x))
|
||||
<*> parseArgs ps pm vmap args
|
||||
instance ( KnownName aname, ParseArg p a, ParseArgs p s m as
|
||||
, s ~ 'Service snm sms, m ~ 'Method mnm margs mr
|
||||
@ -408,24 +409,50 @@ instance ( KnownName aname, ParseArg p a, ParseArgs p s m as
|
||||
= 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)
|
||||
-> (:*) <$> (ArgumentStream <$> parseMaybeArg vmap aname (Just x))
|
||||
<*> parseArgs ps pm vmap args
|
||||
Nothing
|
||||
-> do x <- findDefaultArgValue (Proxy @ann) aname
|
||||
(:*) <$> (ArgumentStream <$> parseArg' vmap aname (constToValue x))
|
||||
-> do let x = findDefaultArgValue (Proxy @ann)
|
||||
(:*) <$> (ArgumentStream <$> parseMaybeArg vmap aname
|
||||
(constToValue <$> x))
|
||||
<*> parseArgs ps pm vmap args
|
||||
|
||||
class FindDefaultArgValue (vs :: Maybe DefaultValue) where
|
||||
findDefaultArgValue :: MonadError T.Text f
|
||||
=> Proxy vs
|
||||
-> T.Text
|
||||
-> f GQL.ValueConst
|
||||
findDefaultArgValue :: Proxy vs
|
||||
-> Maybe GQL.ValueConst
|
||||
instance FindDefaultArgValue 'Nothing where
|
||||
findDefaultArgValue _ aname
|
||||
= throwError $ "argument '" <> aname <> "' was not given a value, and has no default one"
|
||||
findDefaultArgValue _ = Nothing
|
||||
instance ReflectValueConst v
|
||||
=> FindDefaultArgValue ('Just ('DefaultValue v)) where
|
||||
findDefaultArgValue _ _ = pure $ reflectValueConst (Proxy @v)
|
||||
findDefaultArgValue _ = Just $ reflectValueConst (Proxy @v)
|
||||
|
||||
class ParseMaybeArg (p :: Package') (a :: TypeRef Symbol) where
|
||||
parseMaybeArg :: MonadError T.Text f
|
||||
=> VariableMap
|
||||
-> T.Text
|
||||
-> Maybe GQL.Value
|
||||
-> f (ArgumentValue' p a)
|
||||
|
||||
instance {-# OVERLAPS #-} (ParseArg p a)
|
||||
=> ParseMaybeArg p ('OptionalRef a) where
|
||||
parseMaybeArg vmap aname (Just x)
|
||||
= ArgOptional . Just <$> parseArg' vmap aname x
|
||||
parseMaybeArg _ _ Nothing
|
||||
= pure $ ArgOptional Nothing
|
||||
instance {-# OVERLAPS #-} (ParseArg p a)
|
||||
=> ParseMaybeArg p ('ListRef a) where
|
||||
parseMaybeArg vmap aname (Just x)
|
||||
= parseArg' vmap aname x
|
||||
parseMaybeArg _ _ Nothing
|
||||
= pure $ ArgList []
|
||||
instance {-# OVERLAPPABLE #-} (ParseArg p a)
|
||||
=> ParseMaybeArg p a where
|
||||
parseMaybeArg vmap aname (Just x)
|
||||
= parseArg' vmap aname x
|
||||
parseMaybeArg _ aname Nothing
|
||||
= throwError $ "argument '" <> aname <>
|
||||
"' was not given a value, and has no default one"
|
||||
|
||||
|
||||
parseArg' :: (ParseArg p a, MonadError T.Text f)
|
||||
=> VariableMap
|
||||
|
@ -43,6 +43,7 @@ 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 Mu.Adapter.Json ()
|
||||
import Network.HTTP.Types.Header (hContentType)
|
||||
import Network.HTTP.Types.Method (StdMethod (..), parseMethod)
|
||||
import Network.HTTP.Types.Status (ok200)
|
||||
|
Loading…
Reference in New Issue
Block a user