diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +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. + 0.8 ------- 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 +version: 0.8.0.1 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. @@ -117,6 +117,7 @@ , time , hspec-snap >= 1.0.0.2 && < 1.1 , hspec-core >= 2.4.3 && < 2.5 + , snap-cors , http-types , HUnit >= 1.4 , mtl 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 @@ -1,16 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-} @@ -48,7 +48,7 @@ parseUrlPieceMaybe, parseUrlPieces) import Snap.Core hiding (Headers, Method, - getResponse, headers, route, + getResponse, route, method, withRequest) import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture, @@ -167,12 +167,12 @@ processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method -> Maybe [(HeaderName, B.ByteString)] -> Request -> RouteResult Response -processMethodRouter handleA status method headers request = case handleA of +processMethodRouter handleA status method rHeaders request = case handleA of Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does Just (contentT, body) -> Route $ responseLBS status hdrs bdy where bdy = if allowedMethodHead method request then "" else body - hdrs = (hContentType, cs contentT) : fromMaybe [] headers + hdrs = (hContentType, cs contentT) : fromMaybe [] rHeaders methodCheck :: MonadSnap m => Method -> Request -> DelayedM m () methodCheck method request @@ -219,9 +219,9 @@ in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH ) env request respond $ \ output -> do - let headers = getHeaders output + let hdrs = getHeaders output handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) - processMethodRouter handleA status method (Just headers) request + processMethodRouter handleA status method (Just hdrs) request instance {-# OVERLAPPABLE #-} (AllCTRender ctypes a, diff --git a/src/Servant/Server/Internal/BasicAuth.hs b/src/Servant/Server/Internal/BasicAuth.hs --- a/src/Servant/Server/Internal/BasicAuth.hs +++ b/src/Servant/Server/Internal/BasicAuth.hs @@ -1,13 +1,19 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif {-# LANGUAGE ScopedTypeVariables #-} module Servant.Server.Internal.BasicAuth where +#if __GLASGOW_HASKELL__ < 710 +import Data.Functor ((<$>)) +#endif import Control.Monad (guard) -import Control.Monad.Trans (liftIO) import qualified Data.ByteString as BS import Data.ByteString.Base64 (decodeLenient) import Data.CaseInsensitive (CI(..)) diff --git a/src/Servant/Server/Internal/Context.hs b/src/Servant/Server/Internal/Context.hs --- a/src/Servant/Server/Internal/Context.hs +++ b/src/Servant/Server/Internal/Context.hs @@ -1,9 +1,14 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif +{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} 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 @@ -48,8 +48,39 @@ toApplication :: forall m. MonadSnap m => RoutingApplication m -> Application m toApplication ra request respond = do - r <- ra request routingRespond - respond r + + snapReq <- getRequest + r <- ra request routingRespond + snapResp <- getResponse + rspnd <- respond (r `addHeaders` headers snapResp) + + -- 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 + where routingRespond (Fail err) = case errHTTPCode err of 404 -> pass 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 @@ -3,8 +3,9 @@ module Servant.Server.Internal.SnapShims where import qualified Data.ByteString.Char8 as B -import Network.HTTP.Types (Status(..)) +import Data.List (foldl') import Data.IORef +import Network.HTTP.Types (Status(..)) import Snap.Core @@ -25,6 +26,9 @@ req <- getRequest r <- app req return putResponse r + +addHeaders :: HasHeaders a => a -> Headers -> a +addHeaders a hs = foldl' (\xs (k,v) -> addHeader k v xs) a (listHeaders hs) unSnapMethod :: Method -> B.ByteString unSnapMethod = B.pack . show