Missing GraphQL instances + enum example (#204)

examples/seed/mu-example-seed.cabal

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

examples/seed/seed.graphql

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

examples/seed/seed.proto

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

examples/seed/src/Main.hs

@@ -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... 😭"

examples/seed/src/Optics.hs

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

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

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

graphql/src/Mu/GraphQL/Server.hs

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