Merge pull request #31 from haskell-servant/fix-content-type

Fix duplicate import of headers from raw request

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

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.

src/Servant/Server/Internal.hs

@@ -497,7 +497,7 @@ instance HasServer Raw context m where
   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
 

src/Servant/Server/Internal/RoutingApplication.hs

@@ -6,30 +6,33 @@
 {-# 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 =
@@ -49,36 +52,8 @@ data RouteResult a =
 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 @@ instance (Monad m, MonadSnap m) => Alternative (DelayedM m) where
     respA <- runDelayedM a req
     case respA of
       Route a' -> return $ Route a'
-      _ -> runDelayedM b req
+      _        -> runDelayedM b req
 
 
 instance MonadTrans DelayedM where

src/Servant/Server/Internal/SnapShims.hs

@@ -12,16 +12,11 @@ import           Snap.Core
 
 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
-
 applicationToSnap :: MonadSnap m => Application m -> m ()
 applicationToSnap app = do
   req      <- getRequest

test/Servant/ServerSpec.hs

@@ -193,7 +193,6 @@ verbSpec = do
                   (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 @@ queryParamSpec = do
   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 @@ reqBodySpec = do
   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