Change to ServerT Raw m = Tagged m Application

For uniformity of Enter.

Previously, `ServerT Raw m ~ Application`. Seems reasonable, but has the
unfortunate consequence of making `Enter` useless for `Raw` routes.
With this change `Tagged m Application` is retagged by `Enter`.

doc/tutorial/Docs.lhs

@@ -220,11 +220,9 @@ api :: Proxy DocsAPI
 api = Proxy
 
 server :: Server DocsAPI
-server = Server.server3 :<|> serveDocs
+server = Server.server3 :<|> Tagged serveDocs where
-
+    serveDocs _ respond =
-  where serveDocs _ respond =
         respond $ responseLBS ok200 [plain] docsBS
-
     plain = ("Content-Type", "text/plain")
 
 app :: Application

servant-client/test/Servant/ClientSpec.hs

@@ -157,8 +157,8 @@ server = serve api (
                    Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])
   :<|> (\ names -> return (zipWith Person names [0..]))
   :<|> return
-  :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")
+  :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")
-  :<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure")
+  :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure")
   :<|> (\ a b c d -> return (a, b, c, d))
   :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
   :<|> return NoContent
@@ -174,9 +174,9 @@ failApi = Proxy
 
 failServer :: Application
 failServer = serve failApi (
-       (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
+       (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
-  :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
+  :<|> (\ _capture -> Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
-  :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
+  :<|> (Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
  )
 
 -- * basic auth stuff

servant-server/servant-server.cabal

@@ -70,6 +70,7 @@ library
       , system-filepath    >= 0.4  && < 0.5
       , filepath           >= 1    && < 1.5
       , resourcet          >= 1.1.6 && <1.2
+      , tagged             >= 0.7.3 && <0.9
       , text               >= 1.2  && < 1.3
       , transformers       >= 0.3  && < 0.6
       , transformers-base  >= 0.4.4 && < 0.5

servant-server/src/Servant/Server.hs

@@ -100,10 +100,12 @@ module Servant.Server
 
   -- * Re-exports
   , Application
+  , Tagged (..)
 
   ) where
 
 import           Data.Proxy                    (Proxy)
+import           Data.Tagged                   (Tagged (..))
 import           Data.Text                     (Text)
 import           Network.Wai                   (Application)
 import           Servant.Server.Internal
@@ -213,10 +215,12 @@ layoutWithContext p context =
 -- newtype, to convert any number of endpoints from one type constructor to
 -- another. For example
 --
+-- /Note:/ 'Server' 'Raw' can also be entered. It will be retagged.
+--
 -- >>> import Control.Monad.Reader
 -- >>> import qualified Control.Category as C
--- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String
+-- >>> type ReaderAPI = "ep1" :> Get '[JSON] Int :<|> "ep2" :> Get '[JSON] String :<|> Raw
--- >>> let readerServer = return 1797 :<|> ask :: ServerT ReaderAPI (Reader String)
+-- >>> let readerServer = return 1797 :<|> ask :<|> Tagged (error "raw server") :: ServerT ReaderAPI (Reader String)
 -- >>> let nt = generalizeNat C.. (runReaderTNat "hi") :: Reader String :~> Handler
 -- >>> let mainServer = enter nt readerServer :: Server ReaderAPI
 --

servant-server/src/Servant/Server/Internal.hs

@@ -15,8 +15,8 @@
 
 module Servant.Server.Internal
   ( module Servant.Server.Internal
-  , module Servant.Server.Internal.Context
   , module Servant.Server.Internal.BasicAuth
+  , module Servant.Server.Internal.Context
   , module Servant.Server.Internal.Handler
   , module Servant.Server.Internal.Router
   , module Servant.Server.Internal.RoutingApplication
@@ -32,6 +32,7 @@ import           Data.Maybe                 (fromMaybe, mapMaybe)
 import           Data.Either                (partitionEithers)
 import           Data.String                (fromString)
 import           Data.String.Conversions    (cs, (<>))
+import           Data.Tagged                (Tagged, untag)
 import qualified Data.Text                  as T
 import           Data.Typeable
 import           GHC.TypeLits               (KnownNat, KnownSymbol, natVal,
@@ -429,7 +430,7 @@ instance (KnownSymbol sym, HasServer api context)
 -- > server = serveDirectory "/var/www/images"
 instance HasServer Raw context where
 
-  type ServerT Raw m = Application
+  type ServerT Raw m = Tagged m Application
 
   route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do
     -- note: a Raw application doesn't register any cleanup
@@ -439,7 +440,7 @@ instance HasServer Raw context where
     liftIO $ go r request respond
 
     where go r request respond = case r of
-            Route app   -> app request (respond . Route)
+            Route app   -> untag app request (respond . Route)
             Fail a      -> respond $ Fail a
             FailFatal e -> respond $ FailFatal e
 

servant-server/src/Servant/Utils/StaticFiles.hs

@@ -18,7 +18,7 @@ module Servant.Utils.StaticFiles
 import           Data.ByteString                (ByteString)
 import           Network.Wai.Application.Static
 import           Servant.API.Raw                (Raw)
-import           Servant.Server                 (Server)
+import           Servant.Server                 (Server, Tagged (..))
 import           System.FilePath                (addTrailingPathSeparator)
 #if !MIN_VERSION_wai_app_static(3,1,0)
 import           Filesystem.Path.CurrentOS      (decodeString)
@@ -48,27 +48,27 @@ import WaiAppStatic.Storage.Filesystem          (ETagLookup)
 --
 -- Corresponds to the `defaultWebAppSettings` `StaticSettings` value.
 serveDirectoryWebApp :: FilePath -> Server Raw
-serveDirectoryWebApp = staticApp . defaultWebAppSettings . fixPath
+serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath
 
 -- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`.
 serveDirectoryFileServer :: FilePath -> Server Raw
-serveDirectoryFileServer = staticApp . defaultFileServerSettings . fixPath
+serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath
 
 -- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'.
 serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> Server Raw
 serveDirectoryWebAppLookup etag =
-  staticApp . flip webAppSettingsWithLookup etag . fixPath
+  serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath
 
 -- | Uses 'embeddedSettings'.
 serveDirectoryEmbedded :: [(FilePath, ByteString)] -> Server Raw
-serveDirectoryEmbedded files = staticApp (embeddedSettings files)
+serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files)
 
 -- | Alias for 'staticApp'. Lets you serve a directory
 --   with arbitrary 'StaticSettings'. Useful when you want
 --   particular settings not covered by the four other
 --   variants. This is the most flexible method.
 serveDirectoryWith :: StaticSettings -> Server Raw
-serveDirectoryWith = staticApp
+serveDirectoryWith = Tagged . staticApp
 
 -- | Same as 'serveDirectoryFileServer'. It used to be the only
 --   file serving function in servant pre-0.10 and will be kept

servant-server/test/Servant/ServerSpec.hs

@@ -47,7 +47,7 @@ import           Servant.API                ((:<|>) (..), (:>), AuthProtect,
                                              Raw, RemoteHost, ReqBody,
                                              StdMethod (..), Verb, addHeader)
 import           Servant.API.Internal.Test.ComprehensiveAPI
-import           Servant.Server             (Server, Handler, err401, err403,
+import           Servant.Server             (Server, Handler, Tagged (..), err401, err403,
                                              err404, serve, serveWithContext,
                                              Context((:.), EmptyContext))
 import           Test.Hspec                 (Spec, context, describe, it,
@@ -210,7 +210,7 @@ captureSpec = do
 
     with (return (serve
         (Proxy :: Proxy (Capture "captured" String :> Raw))
-        (\ "captured" request_ respond ->
+        (\ "captured" -> Tagged $ \request_ respond ->
             respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
       it "strips the captured path snippet from pathInfo" $ do
         get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
@@ -262,7 +262,7 @@ captureAllSpec = do
 
     with (return (serve
         (Proxy :: Proxy (CaptureAll "segments" String :> Raw))
-        (\ _captured request_ respond ->
+        (\ _captured -> Tagged $ \request_ respond ->
             respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
       it "consumes everything from pathInfo" $ do
         get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))
@@ -494,8 +494,9 @@ type RawApi = "foo" :> Raw
 rawApi :: Proxy RawApi
 rawApi = Proxy
 
-rawApplication :: Show a => (Request -> a) -> Application
+rawApplication :: Show a => (Request -> a) -> Tagged m Application
-rawApplication f request_ respond = respond $ responseLBS ok200 []
+rawApplication f = Tagged $ \request_ respond ->
+    respond $ responseLBS ok200 []
         (cs $ show $ f request_)
 
 rawSpec :: Spec
@@ -651,7 +652,7 @@ basicAuthApi = Proxy
 basicAuthServer :: Server BasicAuthAPI
 basicAuthServer =
   const (return jerry) :<|>
-  (\ _ respond -> respond $ responseLBS imATeaPot418 [] "")
+  (Tagged $ \ _ respond -> respond $ responseLBS imATeaPot418 [] "")
 
 basicAuthContext :: Context '[ BasicAuthCheck () ]
 basicAuthContext =
@@ -696,7 +697,7 @@ genAuthApi = Proxy
 
 genAuthServer :: Server GenAuthAPI
 genAuthServer = const (return tweety)
-           :<|> (\ _ respond -> respond $ responseLBS imATeaPot418 [] "")
+           :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeaPot418 [] "")
 
 type instance AuthServerData (AuthProtect "auth") = ()
 

servant/servant.cabal

@@ -66,6 +66,7 @@ library
     , natural-transformation >= 0.4 && < 0.5
     , mtl                   >= 2.0  && < 2.3
     , mmorph                >= 1    && < 1.1
+    , tagged                >= 0.7.3 && < 0.9
     , text                  >= 1    && < 1.3
     , string-conversions    >= 0.3  && < 0.5
     , network-uri           >= 2.6  && < 2.7

servant/src/Servant/Utils/Enter.hs

@@ -22,9 +22,9 @@ import qualified Control.Monad.State.Lazy    as LState
 import qualified Control.Monad.State.Strict  as SState
 import qualified Control.Monad.Writer.Lazy   as LWriter
 import qualified Control.Monad.Writer.Strict as SWriter
+import           Data.Tagged                 (Tagged, retag)
 import           Prelude                     ()
 import           Prelude.Compat
-
 import           Servant.API
 
 -- | Helper type family to state the 'Enter' symmetry.
@@ -32,6 +32,7 @@ type family Entered m n api where
     Entered m n (a -> api)       = a -> Entered m n api
     Entered m n (m a)            = n a
     Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2
+    Entered m n (Tagged m a)     = Tagged n a
 
 class
     ( Entered m n typ ~ ret
@@ -62,6 +63,13 @@ instance
 
 -- ** Leaf instances
 
+instance
+    ( Entered m n (Tagged m a) ~ Tagged n a
+    , Entered n m (Tagged n a) ~ Tagged m a
+    ) => Enter (Tagged m a) m n (Tagged n a)
+  where
+    enter _ = retag
+
 instance
     ( Entered m n (m a) ~ n a
     , Entered n m (n a) ~ m a