diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 8ceac15c..94245f2f 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} -- | This module lets you implement 'Server's for defined APIs. You'll -- most likely just need 'serve'. @@ -17,8 +18,27 @@ module Servant.Server , ServerT -- * Enter - -- Applying functions to all handlers - , Enter(..) + -- $enterDoc + + -- ** Basic functions and datatypes + , enter + , (:~>)(..) + -- ** `Nat` utilities + , liftNat + , runReaderTNat + , evalStateTLNat + , evalStateTSNat + , logWriterTLNat + , logWriterTSNat +#if MIN_VERSION_mtl(2,2,1) + , fromExceptT +#endif + -- ** Functions based on + , hoistNat + , embedNat + , squashNat + , generalizeNat + -- * Default error type , ServantErr(..) @@ -58,12 +78,12 @@ module Servant.Server ) where -import Data.Proxy (Proxy) -import Network.Wai (Application) -import Servant.API (Canonicalize, canonicalize) -import Servant.Server.Internal -import Servant.Server.Internal.ServantErr -import Servant.Server.Internal.Enter +import Data.Proxy (Proxy) +import Network.Wai (Application) +import Servant.API (Canonicalize, canonicalize) +import Servant.Server.Internal +import Servant.Server.Internal.Enter +import Servant.Server.Internal.ServantErr -- * Implementing Servers @@ -88,5 +108,30 @@ import Servant.Server.Internal.Enter -- > -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app +-- serve :: HasServer (Canonicalize layout) => Proxy layout -> Server layout -> Application serve p server = toApplication (route (canonicalize p) server) + + +-- Documentation + +-- $enterDoc +-- Sometimes our cherished `EitherT` monad isn't quite the type you'd like for +-- your handlers. Maybe you want to thread some configuration in a @Reader@ +-- monad. Or have your types ensure that your handlers don't do any IO. Enter +-- `enter`. +-- +-- With `enter`, you can provide a function, wrapped in the `(:~>)` / `Nat` +-- newtype, to convert any number of endpoints from one type constructor to +-- another. For example +-- +-- >>> import Control.Monad.Reader +-- >>> import qualified Control.Category as C +-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String +-- >>> let readerServer = return 1797 :<|> ask :: ServerT ReaderAPI (Reader String) +-- >>> let mainServer = enter (generalizeNat C.. (runReaderTNat "hi")) readerServer :: Server ReaderAPI +-- + +-- $setup +-- >>> import Servant.API +-- >>> import Servant.Server diff --git a/servant-server/src/Servant/Server/Internal/Enter.hs b/servant-server/src/Servant/Server/Internal/Enter.hs index 884d0b61..e408087a 100644 --- a/servant-server/src/Servant/Server/Internal/Enter.hs +++ b/servant-server/src/Servant/Server/Internal/Enter.hs @@ -21,7 +21,9 @@ import Control.Monad.Morph import Control.Monad.Reader import qualified Control.Monad.State.Lazy as LState import qualified Control.Monad.State.Strict as SState +#if MIN_VERSION_mtl(2,2,1) import Control.Monad.Trans.Either +#endif import qualified Control.Monad.Writer.Lazy as LWriter import qualified Control.Monad.Writer.Strict as SWriter import Data.Typeable @@ -41,6 +43,8 @@ instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where -- ** Useful instances +-- | A natural transformation from @m@ to @n@. Used to `enter` particular +-- datatypes. newtype m :~> n = Nat { unNat :: forall a. m a -> n a} deriving Typeable instance C.Category (:~>) where @@ -50,8 +54,9 @@ instance C.Category (:~>) where instance Enter (m a) (m :~> n) (n a) where enter (Nat f) = f -liftNat :: (MonadTrans t, Monad m) => m :~> t m -liftNat = Nat lift +-- | Like `lift`. +liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m +liftNat = Nat Control.Monad.Morph.lift runReaderTNat :: r -> (ReaderT r m :~> m) runReaderTNat a = Nat (`runReaderT` a) @@ -86,11 +91,14 @@ fromExceptT = Nat $ \x -> EitherT $ runExceptT x hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n) hoistNat (Nat n) = Nat $ hoist n +-- | Like @mmorph@'s `embed`. embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n) embedNat (Nat n) = Nat $ embed n +-- | Like @mmorph@'s `squash`. squashNat :: (Monad m, MMonad t) => t (t m) :~> t m squashNat = Nat squash +-- | Like @mmorph@'s `generalize`. generalizeNat :: Applicative m => Identity :~> m generalizeNat = Nat (pure . runIdentity) diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs index 5bdf158a..992e7bf4 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -9,7 +9,6 @@ import Control.Monad.Trans.Either import Data.Proxy import Servant.API import Servant.Server -import Servant.Server.Internal.Enter import Test.Hspec (Spec, describe, it) import Test.Hspec.Wai (get, matchStatus, post,