mu-rpc 0.4.0.1 → 0.5.0.0

raw patch · 5 files changed

+100/−30 lines, 5 filessetup-changedPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Setup.hs +1/−1
• mu-rpc.cabal +2/−2
• src/Mu/Rpc.hs +29/−7
• src/Mu/Rpc/Examples.hs +27/−14
• src/Mu/Server.hs +41/−6

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

@@ -1,5 +1,5 @@ name:               mu-rpc-version:            0.4.0.1+version:            0.5.0.0 synopsis:           Protocol-independent declaration of services and servers. description:   Protocol-independent declaration of services and servers for mu-haskell.@@ -33,7 +33,7 @@     , conduit           >=1.3.2 && <1.4     , http-types        >=0.12  && <0.13     , mtl               >=2.2   && <2.3-    , mu-schema         ==0.3.*+    , mu-schema         >=0.3   && <0.4     , sop-core          >=0.5   && <0.6     , template-haskell  >=2.14  && <2.17     , text              >=1.2   && <1.3

@@ -20,7 +20,7 @@ -} module Mu.Rpc (   Package', Package(..)-, Service', Service(..), Object+, Service', Service(..), Object, Union , Method', Method(..), ObjectField , LookupService, LookupMethod , TypeRef(..), Argument', Argument(..), Return(..)@@ -56,6 +56,7 @@ data Service serviceName methodName argName tyRef   = Service serviceName             [Method serviceName methodName argName tyRef]+  | OneOf serviceName [serviceName]  -- | A method is defined by its name, arguments, and return type. data Method serviceName methodName argName tyRef@@ -66,6 +67,8 @@ -- Synonyms for GraphQL -- | An object is a set of fields, in GraphQL lingo. type Object = 'Service+-- | A union is one of the objects.+type Union = 'OneOf -- | A field in an object takes some input objects, --   and returns a value or some other object, --   in GraphQL lingo.@@ -76,6 +79,7 @@               :: Service snm mnm anm tr where   LookupService '[] s = TypeError ('Text "could not find method " ':<>: 'ShowType s)   LookupService ('Service s ms ': ss) s = 'Service s ms+  LookupService ('OneOf   s ms ': ss) s = 'OneOf   s ms   LookupService (other         ': ss) s = LookupService ss s  -- | Look up a method in a service definition using its name.@@ -136,7 +140,7 @@   = NoRpcInfo   | RpcInfo { packageInfo :: Package Text Text Text TyInfo             , serviceInfo :: Service Text Text Text TyInfo-            , methodInfo  :: Method  Text Text Text TyInfo+            , methodInfo  :: Maybe (Method Text Text Text TyInfo)             , headers     :: RequestHeaders             , extraInfo   :: i             }@@ -150,10 +154,15 @@ instance Show (RpcInfo i) where   show NoRpcInfo     = "<no info>"-  show (RpcInfo (Package Nothing _) (Service s _) (Method m _ _) _ _)-    = T.unpack (s <> ":" <> m)-  show (RpcInfo (Package (Just p) _) (Service s _) (Method m _ _) _ _)-    = T.unpack (p <> ":" <> s <> ":" <> m)+  show (RpcInfo (Package p _) s m _ _)+    = T.unpack $ showPkg p (showMth m (showSvc s))+    where+      showPkg Nothing    = id+      showPkg (Just pkg) = ((pkg <> ":") <>)+      showMth Nothing                = id+      showMth (Just (Method mt _ _)) = (<> (":" <> mt))+      showSvc (Service sv _) = sv+      showSvc (OneOf   sv _) = sv  class ReflectRpcInfo (p :: Package') (s :: Service') (m :: Method') where   reflectRpcInfo :: Proxy p -> Proxy s -> Proxy m -> RequestHeaders -> i -> RpcInfo i@@ -175,6 +184,13 @@ instance (KnownSymbol s) => KnownMaySymbol ('Just s) where   maySymbolVal _ = Just $ T.pack $ symbolVal (Proxy @s) +class KnownSymbols (m :: [Symbol]) where+  symbolsVal :: Proxy m -> [Text]+instance KnownSymbols '[] where+  symbolsVal _ = []+instance (KnownSymbol s, KnownSymbols ss) => KnownSymbols (s ': ss) where+  symbolsVal _ = T.pack (symbolVal (Proxy @s)) : symbolsVal (Proxy @ss)+ class ReflectServices (ss :: [Service']) where   reflectServices :: Proxy ss -> [Service Text Text Text TyInfo] instance ReflectServices '[] where@@ -204,13 +220,19 @@   reflectRpcInfo _ ps pm req extra     = RpcInfo (Package (maySymbolVal (Proxy @pname))                        (reflectServices (Proxy @ss)))-              (reflectService ps) (reflectMethod pm) req extra+              (reflectService ps) (Just (reflectMethod pm)) req extra  instance (KnownSymbol sname, ReflectMethods ms)          => ReflectService ('Service sname ms) where   reflectService _     = Service (T.pack $ symbolVal (Proxy @sname))               (reflectMethods (Proxy @ms))++instance (KnownSymbol sname, KnownSymbols elts)+         => ReflectService ('OneOf sname elts) where+  reflectService _+    = OneOf (T.pack $ symbolVal (Proxy @sname))+            (symbolsVal (Proxy @elts))  instance (KnownSymbol mname, ReflectArgs args, ReflectReturn r)          => ReflectMethod ('Method mname args r) where

@@ -105,30 +105,43 @@ type ApolloService   = 'Package ('Just "apollo")       '[ Object "Book"-        '[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))-        , ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))-        ]-      , Object "Author"-        '[ ObjectField "name" '[] ('RetSingle ('PrimitiveRef String))-        , ObjectField "books" '[] ('RetSingle ('ListRef ('ObjectRef "Book")))-        ]+         '[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))+          , ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))+          ]+      ,  Object "Paper"+         '[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))+          , ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))+          ]+      ,  Union "Writing" ["Book", "Paper"]+      ,  Object "Author"+         '[ ObjectField "name" '[] ('RetSingle ('PrimitiveRef String))+          , ObjectField "writings" '[] ('RetSingle ('ListRef ('ObjectRef "Writing")))+          ]       ]  type ApolloBookAuthor = '[-    "Book"   ':-> (String, Integer)-  , "Author" ':-> Integer+    "Book"    ':-> (String, Integer)+  , "Paper"   ':-> (String, Integer)+  , "Writing" ':-> Either (String, Integer) (String, Integer)+  , "Author"  ':-> Integer   ]  apolloServer :: forall m i. (MonadServer m)              => ServerT ApolloBookAuthor i ApolloService m _ apolloServer   = resolver-      ( object @"Author" ( field @"name"   authorName-                         , field @"books"  authorBooks )+      ( object @"Author" ( field @"name"     authorName+                         , field @"writings" authorWrs )       , object @"Book"   ( field @"author" (pure . snd)-                         , field @"title"  (pure . fst) ) )+                         , field @"title"  (pure . fst) )+      , object @"Paper"  ( field @"author" (pure . snd)+                         , field @"title"  (pure . fst) )+      , union @"Writing" writing )   where     authorName :: Integer -> m String     authorName _ = pure "alex"  -- this would run in the DB-    authorBooks :: Integer -> m [(String, Integer)]-    authorBooks _ = pure []+    authorWrs :: Integer -> m [Either (String, Integer) (String, Integer)]+    authorWrs _ = pure []++    writing (Left  c) = pure $ unionChoice @"Book" c+    writing (Right c) = pure $ unionChoice @"Paper" c

@@ -1,3 +1,4 @@+{-# language AllowAmbiguousTypes       #-} {-# language CPP                       #-} {-# language ConstraintKinds           #-} {-# language DataKinds                 #-}@@ -54,12 +55,13 @@   -- ** Definitions by name , singleService , method, methodWithInfo-, resolver, object+, resolver, object, union , field, fieldWithInfo+, UnionChoice(..), unionChoice , NamedList(..)   -- ** Definitions by position , SingleServerT, pattern Server-, ServerT(..), ServicesT(..), HandlersT(.., (:<||>:), (:<|>:))+, ServerT(..), ServicesT(..), ServiceT(..), HandlersT(.., (:<||>:), (:<|>:))   -- ** Simple servers using only IO , ServerErrorIO, ServerIO   -- * Errors which might be raised@@ -74,6 +76,7 @@ import           Control.Monad.Except import           Data.Conduit import           Data.Kind+import           Data.Typeable import           GHC.TypeLits  import           Mu.Rpc@@ -151,7 +154,7 @@ pattern Server :: (MappingRight chn sname ~ ())                => HandlersT chn info () methods m hs                -> ServerT chn info ('Package pname '[ 'Service sname methods ]) m '[hs]-pattern Server svr = Services (svr :<&>: S0)+pattern Server svr = Services (ProperSvc svr :<&>: S0)  infixr 3 :<&>: -- | Definition of a complete server for a service.@@ -159,10 +162,32 @@                (s :: [Service snm mnm anm (TypeRef snm)])                (m :: Type -> Type) (hs :: [[Type]]) where   S0 :: ServicesT chn info '[] m '[]-  (:<&>:) :: HandlersT chn info (MappingRight chn sname) methods m hs+  (:<&>:) :: ServiceT chn info svc m hs           -> ServicesT chn info rest m hss-          -> ServicesT chn info ('Service sname methods ': rest) m (hs ': hss)+          -> ServicesT chn info (svc ': rest) m (hs ': hss) +type family InUnion (x :: k) (xs :: [k]) :: Constraint where+  InUnion x '[] = TypeError ('ShowType x ':<>: 'Text " is not part of the union")+  InUnion x (x ': xs) = ()+  InUnion x (y ': xs) = InUnion x xs++data UnionChoice chn elts where+  UnionChoice :: (InUnion elt elts, Typeable elt)+              => Proxy elt -> MappingRight chn elt+              -> UnionChoice chn elts++unionChoice :: forall elt elts chn.+               (InUnion elt elts, Typeable elt)+            => MappingRight chn elt -> UnionChoice chn elts+unionChoice = UnionChoice (Proxy @elt)++-- | Definition of different kinds of services.+data ServiceT chn info svc m hs where+  ProperSvc :: HandlersT chn info (MappingRight chn sname) methods m hs+            -> ServiceT chn info ('Service sname methods) m hs+  OneOfSvc  :: (MappingRight chn sname -> m (UnionChoice chn elts))+            -> ServiceT chn info ('OneOf sname elts) m '[]+ -- | 'HandlersT' is a sequence of handlers. --   Note that the handlers for your service --   must appear __in the same order__ as they@@ -322,6 +347,11 @@   => p -> Named sname (HandlersT chn info (MappingRight chn sname) ms m hs) object nl = Named $ toHandlers $ toNamedList nl +union :: forall sname chn m elts.+         (MappingRight chn sname -> m (UnionChoice chn elts))+      -> Named sname (MappingRight chn sname -> m (UnionChoice chn elts))+union = Named+ -- | Combines the implementation of several GraphQL objects, --   which means a whole Mu service for a GraphQL server. --   Intented to be used with a tuple of 'objects':@@ -412,7 +442,12 @@ instance ( FindService name (HandlersT chn info (MappingRight chn name) methods m h) nl          , ToServices chn info ss m hs nl)          => ToServices chn info ('Service name methods ': ss) m (h ': hs) nl where-  toServices nl = findService (Proxy @name) nl :<&>: toServices nl+  toServices nl = ProperSvc (findService (Proxy @name) nl) :<&>: toServices nl+instance ( FindService name (MappingRight chn name -> m (UnionChoice chn elts)) nl+         , ToServices chn info ss m hs nl)+         => ToServices chn info ('OneOf name elts ': ss) m ('[] ': hs) nl where+  toServices nl = OneOfSvc (findService (Proxy @name) nl) :<&>: toServices nl+  class FindService name h nl | name nl -> h where   findService :: Proxy name -> NamedList nl -> h