diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 8d6beac4..482d5283 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -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 diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 4200d052..174ff74d 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -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 diff --git a/servant-server/src/Servant/Server/Internal/Enter.hs b/servant-server/src/Servant/Server/Internal/Enter.hs index 5bcebe9d..d3491917 100644 --- a/servant-server/src/Servant/Server/Internal/Enter.hs +++ b/servant-server/src/Servant/Server/Internal/Enter.hs @@ -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 diff --git a/servant-server/src/Servant/Server/Internal/RawServer.hs b/servant-server/src/Servant/Server/Internal/RawServer.hs new file mode 100644 index 00000000..b616e0be --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/RawServer.hs @@ -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 + } diff --git a/servant-server/src/Servant/Utils/StaticFiles.hs b/servant-server/src/Servant/Utils/StaticFiles.hs index 08d01ada..5b97bcf6 100644 --- a/servant-server/src/Servant/Utils/StaticFiles.hs +++ b/servant-server/src/Servant/Utils/StaticFiles.hs @@ -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