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.Router
Servant.Server.Internal.RoutingApplication Servant.Server.Internal.RoutingApplication
Servant.Server.Internal.ServantErr Servant.Server.Internal.ServantErr
Servant.Server.Internal.RawServer
Servant.Utils.StaticFiles Servant.Utils.StaticFiles
build-depends: build-depends:
base >= 4.7 && < 5 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.Router
import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr import Servant.Server.Internal.ServantErr
import Servant.Server.Internal.RawServer
import Web.HttpApiData (FromHttpApiData) import Web.HttpApiData (FromHttpApiData)
import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe) import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe)
@ -565,12 +566,12 @@ instance (KnownSymbol sym, HasServer sublayout)
-- > server = serveDirectory "/var/www/images" -- > server = serveDirectory "/var/www/images"
instance HasServer Raw where instance HasServer Raw where
type ServerT Raw m = Application type ServerT Raw m = RawServer m
route Proxy rawApplication = LeafRouter $ \ request respond -> do route Proxy rawApplication = LeafRouter $ \ request respond -> do
r <- runDelayed rawApplication r <- runDelayed rawApplication
case r of case r of
Route app -> app request (respond . Route) Route app -> (getRawServer app) request (respond . Route)
Fail a -> respond $ Fail a Fail a -> respond $ Fail a
FailFatal e -> respond $ FailFatal e 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.Lazy as LWriter
import qualified Control.Monad.Writer.Strict as SWriter import qualified Control.Monad.Writer.Strict as SWriter
import Data.Typeable import Data.Typeable
import Data.Coerce
import Servant.API import Servant.API
import Servant.Server.Internal.RawServer (RawServer)
class Enter typ arg ret | typ arg -> ret, typ ret -> arg where class Enter typ arg ret | typ arg -> ret, typ ret -> arg where
enter :: arg -> typ -> ret 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 instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where
enter arg f a = enter arg (f a) enter arg f a = enter arg (f a)
instance Enter (RawServer m) (m :~> n) (RawServer n) where
enter _ = coerce
-- ** Useful instances -- ** Useful instances
-- | A natural transformation from @m@ to @n@. Used to `enter` particular -- | 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.API.Raw (Raw)
import Servant.Server (Server) import Servant.Server (Server)
import System.FilePath (addTrailingPathSeparator) import System.FilePath (addTrailingPathSeparator)
import Servant.Server.Internal.RawServer (RawServer(..))
#if !MIN_VERSION_wai_app_static(3,1,0) #if !MIN_VERSION_wai_app_static(3,1,0)
import Filesystem.Path.CurrentOS (decodeString) import Filesystem.Path.CurrentOS (decodeString)
#endif #endif
@ -37,7 +38,7 @@ import Filesystem.Path.CurrentOS (decodeString)
-- handler in the last position, because /servant/ will try to match the handlers -- handler in the last position, because /servant/ will try to match the handlers
-- in order. -- in order.
serveDirectory :: FilePath -> Server Raw serveDirectory :: FilePath -> Server Raw
serveDirectory = serveDirectory = RawServer .
#if MIN_VERSION_wai_app_static(3,1,0) #if MIN_VERSION_wai_app_static(3,1,0)
staticApp . defaultFileServerSettings . addTrailingPathSeparator staticApp . defaultFileServerSettings . addTrailingPathSeparator
#else #else