Enter via natural transformations

.gitignore

@@ -21,3 +21,4 @@ cabal.config
 *.prof
 *.aux
 *.hp
+Setup

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

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

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)

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"