RawServer datatype, for uniformity of Enter

Previously, ServerT raw m ~ Application. Seems reasonable, but has the
unfortunate consequence of making Enter useless for Raw routes.
Attempting to solve the Enter class constraint for a Raw route will run
up to IO ResponseReceived, the tail end of the Wai Application type,
in practical use ultimately demanding something along the lines of:

    Enter (IO ResponseReceived)
          (yourMonad :~> EitherT ServantErr IO)
          (IO ResponseReceived)

There's no need to use Enter on a Raw route anyway, I know, but with
this change, the programmer can treat Raw routes and non-Raw routes
uniformly with respect to Enter.
This commit is contained in:
Alexander Vieth 2015-12-02 15:48:12 -05:00
parent 6dac6e831c
commit 5d40b7787f
5 changed files with 33 additions and 3 deletions

View file

@ -40,6 +40,7 @@ library
Servant.Server.Internal.Router
Servant.Server.Internal.RoutingApplication
Servant.Server.Internal.ServantErr
Servant.Server.Internal.RawServer
Servant.Utils.StaticFiles
build-depends:
base >= 4.7 && < 5

View file

@ -55,6 +55,7 @@ import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr
import Servant.Server.Internal.RawServer
import Web.HttpApiData (FromHttpApiData)
import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe)
@ -565,12 +566,12 @@ instance (KnownSymbol sym, HasServer sublayout)
-- > server = serveDirectory "/var/www/images"
instance HasServer Raw where
type ServerT Raw m = Application
type ServerT Raw m = RawServer m
route Proxy rawApplication = LeafRouter $ \ request respond -> do
r <- runDelayed rawApplication
case r of
Route app -> app request (respond . Route)
Route app -> (getRawServer app) request (respond . Route)
Fail a -> respond $ Fail a
FailFatal e -> respond $ FailFatal e

View file

@ -25,7 +25,9 @@ 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.Typeable
import Data.Coerce
import Servant.API
import Servant.Server.Internal.RawServer (RawServer)
class Enter typ arg ret | typ arg -> ret, typ ret -> arg where
enter :: arg -> typ -> ret
@ -39,6 +41,9 @@ instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2
instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where
enter arg f a = enter arg (f a)
instance Enter (RawServer m) (m :~> n) (RawServer n) where
enter _ = coerce
-- ** Useful instances
-- | A natural transformation from @m@ to @n@. Used to `enter` particular

View file

@ -0,0 +1,22 @@
{-|
Module : Servant.Server.Internal.RawServer
Description : Definition of the RawServer type.
Copyright : (c) Alexander Vieth, 2015
Licence : BSD3
-}
{-# LANGUAGE AutoDeriveTypeable #-}
{-# LANGUAGE KindSignatures #-}
module Servant.Server.Internal.RawServer (
RawServer(..)
) where
import Network.Wai (Application)
-- | A Wai Application, but with a phantom type.
newtype RawServer (m :: * -> *) = RawServer {
getRawServer :: Application
}

View file

@ -12,6 +12,7 @@ import Network.Wai.Application.Static (defaultFileServerSettings,
import Servant.API.Raw (Raw)
import Servant.Server (Server)
import System.FilePath (addTrailingPathSeparator)
import Servant.Server.Internal.RawServer (RawServer(..))
#if !MIN_VERSION_wai_app_static(3,1,0)
import Filesystem.Path.CurrentOS (decodeString)
#endif
@ -37,7 +38,7 @@ import Filesystem.Path.CurrentOS (decodeString)
-- handler in the last position, because /servant/ will try to match the handlers
-- in order.
serveDirectory :: FilePath -> Server Raw
serveDirectory =
serveDirectory = RawServer .
#if MIN_VERSION_wai_app_static(3,1,0)
staticApp . defaultFileServerSettings . addTrailingPathSeparator
#else