mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-09-11 14:36:01 +03:00
Better API to declare servers (#173)
This commit is contained in:
parent
7512320ee6
commit
675a3b748a
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user