servant-snap 0.8 → 0.8.0.1
raw patch · 7 files changed
+76/−22 lines, 7 filesdep +snap-corsdep ~basePVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependencies added: snap-cors
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Servant.Server.Internal.SnapShims: addHeaders :: HasHeaders a => a -> Headers -> a
Files
- CHANGELOG.md +7/−0
- servant-snap.cabal +2/−1
- src/Servant/Server/Internal.hs +17/−17
- src/Servant/Server/Internal/BasicAuth.hs +7/−1
- src/Servant/Server/Internal/Context.hs +5/−0
- src/Servant/Server/Internal/RoutingApplication.hs +33/−2
- src/Servant/Server/Internal/SnapShims.hs +5/−1
CHANGELOG.md view
@@ -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 -------
servant-snap.cabal view
@@ -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
src/Servant/Server/Internal.hs view
@@ -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,
src/Servant/Server/Internal/BasicAuth.hs view
@@ -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(..))
src/Servant/Server/Internal/Context.hs view
@@ -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 #-}
src/Servant/Server/Internal/RoutingApplication.hs view
@@ -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
src/Servant/Server/Internal/SnapShims.hs view
@@ -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