diff --git a/.gitignore b/.gitignore index 7d7195eb..3007a0c1 100644 --- a/.gitignore +++ b/.gitignore @@ -21,3 +21,4 @@ cabal.config *.prof *.aux *.hp +Setup diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 9c094a20..293cd289 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -37,6 +37,7 @@ library Servant.Server Servant.Server.Internal Servant.Server.Internal.ServantErr + Servant.Server.Internal.Enter Servant.Utils.StaticFiles build-depends: base >= 4.7 && < 5 @@ -46,6 +47,8 @@ library , either >= 4.3 && < 4.4 , http-types >= 0.8 && < 0.9 , network-uri >= 2.6 && < 2.7 + , mtl >= 2 && < 3 + , mmorph >= 1 , safe >= 0.3 && < 0.4 , servant >= 0.2 && < 0.4 , split >= 0.2 && < 0.3 @@ -101,6 +104,7 @@ test-suite spec , temporary , text , transformers + , mtl , wai , wai-extra , warp diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 6cef90f5..8ceac15c 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -16,6 +16,10 @@ module Servant.Server , Server , ServerT + -- * Enter + -- Applying functions to all handlers + , Enter(..) + -- * Default error type , ServantErr(..) -- ** 3XX @@ -59,6 +63,7 @@ import Network.Wai (Application) import Servant.API (Canonicalize, canonicalize) import Servant.Server.Internal import Servant.Server.Internal.ServantErr +import Servant.Server.Internal.Enter -- * Implementing Servers diff --git a/servant-server/src/Servant/Server/Internal/Enter.hs b/servant-server/src/Servant/Server/Internal/Enter.hs new file mode 100644 index 00000000..884d0b61 --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Enter.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Server.Internal.Enter where + +import Control.Applicative +import qualified Control.Category as C +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except +#endif +import Control.Monad.Identity +import Control.Monad.Morph +import Control.Monad.Reader +import qualified Control.Monad.State.Lazy as LState +import qualified Control.Monad.State.Strict as SState +import Control.Monad.Trans.Either +import qualified Control.Monad.Writer.Lazy as LWriter +import qualified Control.Monad.Writer.Strict as SWriter +import Data.Typeable +import Servant.API + +class Enter typ arg ret | typ arg -> ret, typ ret -> arg where + enter :: arg -> typ -> ret + +-- ** Servant combinators +instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2 + , arg1 ~ arg2 + ) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where + enter e (a :<|> b) = enter e a :<|> enter e b + +instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where + enter arg f a = enter arg (f a) + +-- ** Useful instances + +newtype m :~> n = Nat { unNat :: forall a. m a -> n a} deriving Typeable + +instance C.Category (:~>) where + id = Nat id + Nat f . Nat g = Nat (f . g) + +instance Enter (m a) (m :~> n) (n a) where + enter (Nat f) = f + +liftNat :: (MonadTrans t, Monad m) => m :~> t m +liftNat = Nat lift + +runReaderTNat :: r -> (ReaderT r m :~> m) +runReaderTNat a = Nat (`runReaderT` a) + +evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m) +evalStateTLNat a = Nat (`LState.evalStateT` a) + +evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m) +evalStateTSNat a = Nat (`SState.evalStateT` a) + +-- | Log the contents of `SWriter.WriterT` with the function provided as the +-- first argument, and return the value of the @WriterT@ computation +logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m) +logWriterTSNat logger = Nat $ \x -> do + (a, w) <- SWriter.runWriterT x + liftIO $ logger w + return a + +-- | Like `logWriterTSNat`, but for strict @WriterT@. +logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m) +logWriterTLNat logger = Nat $ \x -> do + (a, w) <- LWriter.runWriterT x + liftIO $ logger w + return a + +#if MIN_VERSION_mtl(2,2,1) +fromExceptT :: ExceptT e m :~> EitherT e m +fromExceptT = Nat $ \x -> EitherT $ runExceptT x +#endif + +-- | Like @mmorph@'s `hoist`. +hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n) +hoistNat (Nat n) = Nat $ hoist n + +embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n) +embedNat (Nat n) = Nat $ embed n + +squashNat :: (Monad m, MMonad t) => t (t m) :~> t m +squashNat = Nat squash + +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 new file mode 100644 index 00000000..5bdf158a --- /dev/null +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +module Servant.Server.Internal.EnterSpec where + +import qualified Control.Category as C +import Control.Monad.Reader +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, + shouldRespondWith, with) + +spec :: Spec +spec = describe "module Servant.Server.Enter" $ do + enterSpec + +type ReaderAPI = "int" :> Get '[JSON] Int + :<|> "string" :> Post '[JSON] String + +type IdentityAPI = "bool" :> Get '[JSON] Bool + +type CombinedAPI = ReaderAPI :<|> IdentityAPI + +readerAPI :: Proxy ReaderAPI +readerAPI = Proxy + +combinedAPI :: Proxy CombinedAPI +combinedAPI = Proxy + +readerServer' :: ServerT ReaderAPI (Reader String) +readerServer' = return 1797 :<|> ask + +fReader :: Reader String :~> EitherT ServantErr IO +fReader = generalizeNat C.. (runReaderTNat "hi") + +readerServer :: Server ReaderAPI +readerServer = enter fReader readerServer' + +combinedReaderServer' :: ServerT CombinedAPI (Reader String) +combinedReaderServer' = readerServer' :<|> enter generalizeNat (return True) + +combinedReaderServer :: Server CombinedAPI +combinedReaderServer = enter fReader combinedReaderServer' + +enterSpec :: Spec +enterSpec = describe "Enter" $ do + with (return (serve readerAPI readerServer)) $ do + + it "allows running arbitrary monads" $ do + get "int" `shouldRespondWith` "1797" + post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 } + + with (return (serve combinedAPI combinedReaderServer)) $ do + it "allows combnation of enters" $ do + get "bool" `shouldRespondWith` "true" diff --git a/servant/Setup b/servant/Setup deleted file mode 100755 index 7e7b3990..00000000 Binary files a/servant/Setup and /dev/null differ