Better API to declare servers (#173)

core/rpc/src/Mu/Rpc/Examples.hs

@@ -9,6 +9,7 @@
 {-# language PartialTypeSignatures #-}
 {-# language PolyKinds             #-}
 {-# language ScopedTypeVariables   #-}
+{-# language TypeApplications      #-}
 {-# language TypeFamilies          #-}
 {-# language TypeOperators         #-}
 {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
@@ -71,7 +72,10 @@ newtype HiRequest = HiRequest { number :: Int }
 quickstartServer :: forall m. (MonadServer m)
                  => ServerT '[] QuickStartService m _
 quickstartServer
-  = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0)
+  -- = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0)
+  = singleService ( method @"SayHello" sayHello
+                  , method @"SayManyHellos" sayManyHellos
+                  , method @"SayHi" sayHi )
   where
     sayHello :: HelloRequest -> m HelloResponse
     sayHello (HelloRequest nm)
@@ -87,20 +91,7 @@ quickstartServer
     sayManyHellos source sink
       = runConduit $ source .| C.mapM sayHello .| sink
 
-{-
-From https://www.apollographql.com/docs/apollo-server/schema/schema/
-
-type Book {
-  title: String
-  author: Author
-}
-
-type Author {
-  name: String
-  books: [Book]
-}
--}
-
+-- From https://www.apollographql.com/docs/apollo-server/schema/schema/
 type ApolloService
   = 'Package ('Just "apollo")
       '[ Object "Book" '[]
@@ -120,9 +111,11 @@ type ApolloBookAuthor = '[
 
 apolloServer :: forall m. (MonadServer m) => ServerT ApolloBookAuthor ApolloService m _
 apolloServer
-  = Services $ (pure . fst :<||>: pure . snd :<||>: H0)
-               :<&>: (authorName :<||>: authorBooks :<||>: H0)
-               :<&>: S0
+  = resolver
+      ( object @"Author" ( field @"name"   authorName
+                         , field @"books"  authorBooks )
+      , object @"Book"   ( field @"author" (pure . snd)
+                         , field @"title"  (pure . fst) ) )
   where
     authorName :: Integer -> m String
     authorName _ = pure "alex"  -- this would run in the DB

core/rpc/src/Mu/Server.hs

@@ -3,11 +3,13 @@
 {-# language ExistentialQuantification #-}
 {-# language FlexibleContexts          #-}
 {-# language FlexibleInstances         #-}
+{-# language FunctionalDependencies    #-}
 {-# language GADTs                     #-}
-{-# language MultiParamTypeClasses     #-}
 {-# language PatternSynonyms           #-}
 {-# language PolyKinds                 #-}
 {-# language RankNTypes                #-}
+{-# language ScopedTypeVariables       #-}
+{-# language TypeApplications          #-}
 {-# language TypeFamilies              #-}
 {-# language TypeOperators             #-}
 {-# language UndecidableInstances      #-}
@@ -36,10 +38,12 @@ We recommend you to catch exceptions and return custom
 -}
 module Mu.Server (
   -- * Servers and handlers
-  MonadServer
-, SingleServerT
-, ServerT(.., Server), ServicesT(..), HandlersT(.., (:<|>:))
-, ServiceChain, noContext
+  MonadServer, ServiceChain, noContext
+  -- ** Definitions by name
+, singleService, method, resolver, object, field, NamedList(..)
+  -- ** Definitions by position
+, SingleServerT, pattern Server
+, ServerT(..), ServicesT(..), HandlersT(.., (:<|>:))
   -- ** Simple servers using only IO
 , ServerErrorIO, ServerIO
   -- * Errors which might be raised
@@ -53,6 +57,7 @@ module Mu.Server (
 import           Control.Monad.Except
 import           Data.Conduit
 import           Data.Kind
+import           GHC.TypeLits
 
 import           Mu.Rpc
 import           Mu.Schema
@@ -207,3 +212,114 @@ instance (MonadError ServerError m, ToRef chn ref v, handler ~ m v)
          => Handles chn '[] ('RetSingle ref) m handler
 instance (MonadError ServerError m, ToRef chn ref v, handler ~ (ConduitT v Void m () -> m ()))
          => Handles chn '[] ('RetStream ref) m handler
+
+-- SIMPLER WAY TO DECLARE SERVICES
+
+method :: forall n p. p -> Named n (() -> p)
+method f = Named (\() -> f)
+field :: forall n h. h -> Named n h
+field  = Named
+
+singleService
+  :: (ToNamedList p nl, ToHandlers chn () methods m hs nl, MappingRight chn sname ~ ())
+  => p -> ServerT chn ('Package pname '[ 'Service sname sanns methods ]) m '[hs]
+singleService nl = Server $ toHandlers $ toNamedList nl
+
+object
+  :: forall sname p nl chn ms m hs.
+     (ToNamedList p nl, ToHandlers chn (MappingRight chn sname) ms m hs nl)
+  => p -> Named sname (HandlersT chn (MappingRight chn sname) ms m hs)
+object nl = Named $ toHandlers $ toNamedList nl
+
+resolver
+  :: (ToNamedList p nl, ToServices chn ss m hs nl)
+  => p -> ServerT chn ('Package pname ss) m hs
+resolver nl = Services $ toServices $ toNamedList nl
+
+data Named n h where
+  Named :: forall n h. h -> Named n h
+
+infixr 4 :|:
+data NamedList (hs :: [(Symbol, *)]) where
+  N0    :: NamedList '[]
+  (:|:) :: Named n h -> NamedList hs
+        -> NamedList ('(n, h) ': hs)
+
+class ToNamedList p nl | p -> nl where
+  toNamedList :: p -> NamedList nl
+
+instance ToNamedList (NamedList nl) nl where
+  toNamedList = id
+instance ToNamedList () '[] where
+  toNamedList _ = N0
+instance ToNamedList (Named n h) '[ '(n, h) ] where
+  toNamedList n = n :|: N0
+instance ToNamedList (Named n1 h1, Named n2 h2)
+                     '[ '(n1, h1), '(n2, h2) ] where
+  toNamedList (n1, n2) = n1 :|: n2 :|: N0
+instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3)
+                     '[ '(n1, h1), '(n2, h2), '(n3, h3) ] where
+  toNamedList (n1, n2, n3) = n1 :|: n2 :|: n3 :|: N0
+instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4)
+                     '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4) ] where
+  toNamedList (n1, n2, n3, n4) = n1 :|: n2 :|: n3 :|: n4 :|: N0
+instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5)
+                     '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5) ] where
+  toNamedList (n1, n2, n3, n4, n5) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: N0
+instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6)
+                     '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6) ] where
+  toNamedList (n1, n2, n3, n4, n5, n6) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: N0
+instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6, Named n7 h7)
+                     '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7) ] where
+  toNamedList (n1, n2, n3, n4, n5, n6, n7) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: n7 :|: N0
+instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6, Named n7 h7, Named n8 h8)
+                     '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8) ] where
+  toNamedList (n1, n2, n3, n4, n5, n6, n7, n8) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: n7 :|: n8 :|: N0
+instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6, Named n7 h7, Named n8 h8, Named n9 h9)
+                     '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8), '(n9, h9) ] where
+  toNamedList (n1, n2, n3, n4, n5, n6, n7, n8, n9) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: n7 :|: n8 :|: n9 :|: N0
+
+class ToHandlers chn inh ms m hs nl | chn inh ms m nl -> hs where
+  toHandlers :: NamedList nl
+             -> HandlersT chn inh ms m hs
+
+instance ToHandlers chn inh '[] m '[] nl where
+  toHandlers _ = H0
+instance (FindHandler name inh h nl, Handles chn args ret m h, ToHandlers chn inh ms m hs nl)
+         => ToHandlers chn inh ('Method name anns args ret ': ms) m (h ': hs) nl where
+  toHandlers nl = findHandler (Proxy @name) nl :<||>: toHandlers nl
+
+class FindHandler name inh h nl | name nl -> inh h where
+  findHandler :: Proxy name -> NamedList nl -> inh -> h
+instance (inh ~ h, h ~ TypeError ('Text "cannot find handler for " ':<>: 'ShowType name))
+         => FindHandler name inh h '[] where
+  findHandler = error "this should never be called"
+instance {-# OVERLAPS #-} (inh ~ inh', h ~ h')
+         => FindHandler name inh h ( '(name, inh' -> h') ': rest ) where
+  findHandler _ (Named f :|: _) = f
+instance {-# OVERLAPPABLE #-} FindHandler name inh h rest
+         => FindHandler name inh h (thing ': rest) where
+  findHandler p (_ :|: rest) = findHandler p rest
+
+class ToServices chn ss m hs nl | chn ss m nl -> hs where
+  toServices :: NamedList nl
+             -> ServicesT chn ss m hs
+
+instance ToServices chn '[] m '[] nl where
+  toServices _ = S0
+instance ( FindService name (HandlersT chn (MappingRight chn name) methods m h) nl
+         , ToServices chn ss m hs nl)
+         => ToServices chn ('Service name anns methods ': ss) m (h ': hs) nl where
+  toServices nl = findService (Proxy @name) nl :<&>: toServices nl
+
+class FindService name h nl | name nl -> h where
+  findService :: Proxy name -> NamedList nl -> h
+instance (h ~ TypeError ('Text "cannot find handler for " ':<>: 'ShowType name))
+         => FindService name h '[] where
+  findService = error "this should never be called"
+instance {-# OVERLAPS #-} (h ~ h')
+         => FindService name h ( '(name, h') ': rest ) where
+  findService _ (Named f :|: _) = f
+instance {-# OVERLAPPABLE #-} FindService name h rest
+         => FindService name h (thing ': rest) where
+  findService p (_ :|: rest) = findService p rest

examples/health-check/src/Server.hs

@@ -41,8 +41,13 @@ type StatusMap = M.Map T.Text T.Text
 type StatusUpdates = TBMChan HealthStatusMsg
 
 server :: StatusMap -> StatusUpdates -> ServerIO HealthCheckService _
-server m upd = Server (setStatus_ m upd :<|>: checkH_ m :<|>: clearStatus_ m :<|>:
-  checkAll_ m :<|>: cleanAll_ m :<|>: watch_ upd :<|>: H0)
+server m upd
+  = singleService ( method @"setStatus"   $ setStatus_ m upd
+                  , method @"check"       $ checkH_ m
+                  , method @"clearStatus" $ clearStatus_ m
+                  , method @"checkAll"    $ checkAll_ m
+                  , method @"cleanAll"    $ cleanAll_ m
+                  , method @"watch"       $ watch_ upd)
 
 setStatus_ :: StatusMap -> StatusUpdates -> HealthStatusMsg -> ServerErrorIO ()
 setStatus_ m upd

examples/route-guide/src/Server.hs

@@ -1,7 +1,9 @@
+{-# language DataKinds             #-}
 {-# language DuplicateRecordFields #-}
 {-# language OverloadedStrings     #-}
 {-# language PartialTypeSignatures #-}
 {-# language ScopedTypeVariables   #-}
+{-# language TypeApplications      #-}
 {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
 
 module Main where
@@ -68,8 +70,11 @@ calcDistance (Point lat1 lon1) (Point lat2 lon2)
 -- https://github.com/higherkindness/mu/blob/master/modules/examples/routeguide/server/src/main/scala/handlers/RouteGuideServiceHandler.scala
 
 server :: Features -> TBMChan RouteNote -> ServerIO RouteGuideService _
-server f m = Server
-  (getFeature f :<|>: listFeatures f  :<|>: recordRoute f :<|>: routeChat m :<|>: H0)
+server f m
+  = singleService ( method @"GetFeature"   $ getFeature f
+                  , method @"ListFeatures" $ listFeatures f
+                  , method @"RecordRoute"  $ recordRoute f
+                  , method @"RouteChat"    $ routeChat m)
 
 getFeature :: Features -> Point -> ServerErrorIO Feature
 getFeature fs p = pure $ fromMaybe nilFeature (findFeatureIn fs p)

examples/seed/src/Main.hs

@@ -61,7 +61,8 @@ main = do
 -- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala
 
 server :: (MonadServer m, MonadLogger m) => SingleServerT PeopleService m _
-server = Server (getPerson :<|>: getPersonStream :<|>: H0)
+server
+  = singleService (method @"getPerson" getPerson, method @"getPersonStream" getPersonStream)
 
 evolvePerson :: PeopleRequest -> PeopleResponse
 evolvePerson (PeopleRequest n) = PeopleResponse $ Just $ Person n 18

examples/todolist/src/Server.hs

@@ -2,6 +2,7 @@
 {-# language NamedFieldPuns        #-}
 {-# language OverloadedStrings     #-}
 {-# language PartialTypeSignatures #-}
+{-# language TypeApplications      #-}
 {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
 
 module Main where
@@ -31,8 +32,13 @@ type Id = TVar Int32
 type TodoList = TVar [TodoListMessage]
 
 server :: Id -> TodoList -> ServerIO TodoListService _
-server i t = Server
-  (reset i t :<|>: insert i t :<|>: retrieve t :<|>: list_ t :<|>: update t :<|>: destroy t :<|>: H0)
+server i t
+  = singleService ( method @"reset"    $ reset i t
+                  , method @"insert"   $ insert i t
+                  , method @"retrieve" $ retrieve t
+                  , method @"list"     $ list_ t
+                  , method @"update"   $ update t
+                  , method @"destroy"  $ destroy t )
 
 reset :: Id -> TodoList -> ServerErrorIO MessageId
 reset i t = alwaysOk $ do

examples/with-persistent/src/Server.hs

@@ -1,3 +1,4 @@
+{-# language DataKinds             #-}
 {-# language FlexibleContexts      #-}
 {-# language OverloadedStrings     #-}
 {-# language PartialTypeSignatures #-}
@@ -27,7 +28,10 @@ main = do
       liftIO $ runGRpcApp msgProtoBuf 1234 (server conn)
 
 server :: SqlBackend -> SingleServerT PersistentService ServerErrorIO _
-server p = Server (getPerson p :<|>: newPerson p :<|>: allPeople p :<|>: H0)
+server p
+  = singleService ( method @"getPerson" $ getPerson p
+                  , method @"newPerson" $ newPerson p
+                  , method @"allPeople" $ allPeople p)
 
 getPerson :: SqlBackend -> MPersonRequest -> ServerErrorIO (Entity Person)
 getPerson conn (MPersonRequest idf) = do

graphql/exe/Main.hs

@@ -64,15 +64,18 @@ library
 
 libraryServer :: forall m. (MonadServer m) => ServerT ServiceMapping ServiceDefinition m _
 libraryServer
-  = Services $ (bookId :<||>: bookTitle :<||>: bookAuthor :<||>: H0)
-               :<&>: (authorId :<||>: authorName :<||>: authorBooks :<||>: H0)
-               :<&>: (noContext findAuthor
-                      :<||>: noContext findBookTitle
-                      :<||>: noContext allAuthors
-                      :<||>: noContext allBooks'
-                      :<||>: H0)
-               :<&>: (noContext allBooksConduit :<||>: H0)
-               :<&>: S0
+  = resolver ( object @"Book"   ( field  @"id"      bookId
+                                , field  @"title"   bookTitle
+                                , field  @"author"  bookAuthor )
+             , object @"Author" ( field  @"id"      authorId
+                                , field  @"name"    authorName
+                                , field  @"books"   authorBooks )
+             , object @"Query"  ( method @"author"  findAuthor
+                                , method @"book"    findBookTitle
+                                , method @"authors" allAuthors
+                                , method @"books"   allBooks' )
+             , object @"Subscription" ( method @"books" allBooksConduit )
+             )
   where
     findBook i = find ((==i) . fst3) library