diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,78 +1,86 @@ +0.9.0 (2020-09-07) +----- + + - **BREAKING** Removed `snapToApplication'`. Use `snapToApplication` instead + - Fixed a bug that caused duplication of header values in the request data + used to route requests. See this issue: + [#27](https://github.com/haskell-servant/servant-snap/issues/27) + 0.8.5.0 ----- -Bump dependencies for ghc-8.8.2 + - Bump dependencies for ghc-8.8.2 0.8.4.1 ----- -Drop servant-client and http-client dependencies from snap-greet + - Drop servant-client and http-client dependencies from snap-greet 0.8.4 ----- -Support servant 0.15 and 0.16, which have a new `Stream` combinator -Drop support for servant < 0.15 -Correct the way imperativelly added headers in request/response are managed (fixing CORS issue) -More CORS test coverage + - Support servant 0.15 and 0.16, which have a new `Stream` combinator + - Drop support for servant < 0.15 + - Correct the way imperativelly added headers in request/response are managed (fixing CORS issue) + - More CORS test coverage 0.8.3.2 ----- -Backport the response header fix from 0.8.4 (we can now use it with servant 0.14) + - Backport the response header fix from 0.8.4 (we can now use it with servant 0.14) 0.8.3 ----- -Add support for servant-0.14 -Reorder handling of errors + - Add support for servant-0.14 + - Reorder handling of errors 0.8.2 ------ -Add `HasServer` instances for `StreamGenerator` + - Add `HasServer` instances for `StreamGenerator` 0.8.0.1 ------- -Add headers from MonadSnap state response to the servant-snap computed response -Add a commented-out snap-cors test to the test suite. It doesn't pass, although -manual testing of snap-cors works. + - Add headers from MonadSnap state response to the servant-snap computed response + - Add a commented-out snap-cors test to the test suite. It doesn't pass, although + manual testing of snap-cors works. 0.8 ------- -Copy BasicAuth and Context from servant-server to support basic auth checking + - Copy BasicAuth and Context from servant-server to support basic auth checking 0.7.1 ------- -Call 'Snap.Core.pass' when routing an empty URI path. This allows an entire -served API to fall through, which is more in line with the rest of snap routing, -and allows multiple servant API's to be served under the same path context -from 'Snap.Core.route'. + - Call 'Snap.Core.pass' when routing an empty URI path. This allows an entire + served API to fall through, which is more in line with the rest of snap routing, + and allows multiple servant API's to be served under the same path context + from 'Snap.Core.route'. 0.7.0.5 ------- -Fix throwError bug ignoring ServantError headers + - Fix throwError bug ignoring ServantError headers 0.7.0.4 ------- -Fix throwError bug ignoring ServantError body + - Fix throwError bug ignoring ServantError body 0.7.0.3 ------- -Bump servant upper bound, allow 0.9 + - Bump servant upper bound, allow 0.9 0.7 ---- -Initial release + - Initial release diff --git a/servant-snap.cabal b/servant-snap.cabal --- a/servant-snap.cabal +++ b/servant-snap.cabal @@ -1,5 +1,5 @@ name: servant-snap -version: 0.8.5 +version: 0.9.0 synopsis: A family of combinators for defining webservices APIs and serving them description: Interpret a Servant API as a Snap server, using any Snaplets you like. diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -497,7 +497,7 @@ route Proxy _ rawApplication = RawRouter $ \ env request respond -> do r <- runDelayed rawApplication env request case r of - Route app -> (snapToApplication' app) request (respond . Route) + Route app -> (snapToApplication app) request (respond . Route) Fail a -> respond $ Fail a FailFatal e -> respond $ FailFatal e diff --git a/src/Servant/Server/Internal/RoutingApplication.hs b/src/Servant/Server/Internal/RoutingApplication.hs --- a/src/Servant/Server/Internal/RoutingApplication.hs +++ b/src/Servant/Server/Internal/RoutingApplication.hs @@ -6,32 +6,35 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal.RoutingApplication where -import Control.Applicative (Applicative(..), Alternative(..), (<$>)) -import Control.Monad (ap, liftM) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Applicative (Alternative (..), + Applicative (..), (<$>)) +import Control.Monad (ap, liftM) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Class -import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString.Lazy as BL -import Data.CaseInsensitive (CI) -import qualified Data.List as L -import Data.Proxy (Proxy(..)) -import Network.HTTP.Types (Status(..)) -import qualified System.IO.Streams as Streams -import Servant.Server.Internal.SnapShims -import Servant.Server.Internal.ServantErr +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as BL +import Data.CaseInsensitive (CI) +import qualified Data.List as L +import Data.Proxy (Proxy (..)) +import Network.HTTP.Types (Status (..)) import Snap.Core -import Snap.Internal.Http.Types (setResponseBody) +import Snap.Internal.Http.Types (setResponseBody) +import qualified System.IO.Streams as Streams +import Servant.Server.Internal.ServantErr +import Servant.Server.Internal.SnapShims + + type RoutingApplication m = Request -- ^ the request, the field 'pathInfo' may be modified by url routing -> (RouteResult Response -> m Response) -> m Response @@ -49,36 +52,8 @@ toApplication :: forall m. MonadSnap m => RoutingApplication m -> Application m toApplication ra request respond = do - snapReq <- getRequest - r <- ra (request `addHeaders` headers snapReq) routingRespond - rspnd <- respond r - - -- liftIO $ putStrLn $ unlines [ - -- "----------" - -- , "SNAP REQ" - -- , show snapReq - -- , "----------" - -- , "request" - -- , show request - -- , "----------" - -- , "r" - -- , show r - -- , "----------" - -- , "snapResp" - -- , show snapResp - -- , "----------" - -- , "rspnd" - -- , show rspnd - -- ] - - return rspnd - - -- snapReq <- getRequest - -- r <- ra (request `addHeaders` headers snapReq) routingRespond - -- respond r - - -- r <- ra request routingRespond - -- respond r + r <- ra request routingRespond + respond r where routingRespond (Fail err) = case errHTTPCode err of @@ -160,7 +135,7 @@ respA <- runDelayedM a req case respA of Route a' -> return $ Route a' - _ -> runDelayedM b req + _ -> runDelayedM b req instance MonadTrans DelayedM where diff --git a/src/Servant/Server/Internal/SnapShims.hs b/src/Servant/Server/Internal/SnapShims.hs --- a/src/Servant/Server/Internal/SnapShims.hs +++ b/src/Servant/Server/Internal/SnapShims.hs @@ -12,13 +12,8 @@ type Application m = Request -> (Response -> m Response) -> m Response -snapToApplication :: MonadSnap m => m () -> Application m +snapToApplication :: MonadSnap m => m a -> Application m snapToApplication snapAction req respond = do - putRequest req - snapAction >> getResponse >>= respond - -snapToApplication' :: MonadSnap m => m a -> Application m -snapToApplication' snapAction req respond = do putRequest req snapAction >> getResponse >>= respond diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -193,7 +193,6 @@ (serveSnap api server) sInit shouldHaveHeaders resp [("H","5")] - -- TODO: Why doesn't this test pass? it "returs CORS headers" $ do resp <- testSnaplet sInit (mkRequest method "/noContent" "" [("Origin", "http://example.com")] "") shouldHaveHeaders resp [("access-control-allow-origin" @@ -363,7 +362,7 @@ describe "Servant.API.QueryParam" $ do let runTest :: B8.ByteString -> B8.ByteString -> IO (Either T.Text Response) - runTest p qs = runReqOnApi queryParamApi EmptyContext qpServer SC.GET p qs [(hContentType,"application/json;charset=utf-8")] "" + runTest p qs = runReqOnApi queryParamApi EmptyContext qpServer SC.GET p qs [(hContentType,"application/json")] "" it "allows retrieving simple GET parameters" $ runTest "" "?name=bob" >>= (`shouldDecodeTo` alice {name="bob"}) @@ -459,8 +458,7 @@ describe "Servant.API.ReqBody" $ do let runTest m p ct bod = runReqOnApi reqBodyApi EmptyContext server m p "" [(hContentType,ct)] bod - goodCT = "application/json;charset=utf-8" - -- "application/json" + goodCT = "application/json" badCT = "application/nonsense" it "passes the argument to the handler" $ do