diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,12 +1,10 @@ -0.8.3.2 ------ - -Include the changes intended for 0.8.3.1 in git and the release sdist - -0.8.3.1 +0.8.4 ----- -Backport the response header fix from 0.8.4 (we can now use it with servant 0.14) +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 ----- diff --git a/example/greet.hs b/example/greet.hs --- a/example/greet.hs +++ b/example/greet.hs @@ -15,7 +15,7 @@ import GHC.Generics import qualified Heist.Interpreted as I import Snap.Core hiding (GET) -import Snap.CORS +import Snap.Util.CORS import Snap.Snaplet import Snap.Snaplet.Auth import Snap.Snaplet.Session @@ -25,7 +25,9 @@ import Snap.Http.Server (defaultConfig) import Servant.API +import qualified Servant.API.Stream as Stream import Servant (serveSnap, Server, serveDirectory) +import qualified Servant.Types.SourceT as S -- * Example @@ -37,7 +39,7 @@ instance ToJSON Greet -- API specification -type TestApi m f = +type TestApi = -- GET /hello/:name?capital={true, false} returns a Greet as JSON "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet @@ -52,7 +54,7 @@ -- DELETE /greet/:greetid :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] () - :<|> "stream" :> StreamGet NetstringFraming JSON (f Greet) + :<|> "stream" :> StreamGet NetstringFraming JSON (Stream.SourceIO Greet) :<|> "files" :> Raw :<|> "doraw" :> Raw @@ -71,7 +73,7 @@ type AppHandler = Handler App App -testApi :: Proxy (TestApi AppHandler StreamGenerator) +testApi :: Proxy TestApi testApi = Proxy @@ -82,7 +84,7 @@ -- -- Each handler runs in the 'AppHandler' monad. -server :: Server (TestApi AppHandler StreamGenerator) '[] AppHandler +server :: Server TestApi '[] AppHandler server = helloH :<|> helloH' :<|> postGreetH @@ -107,10 +109,8 @@ deleteGreetH _ = return () - doStream = return $ StreamGenerator $ \sendFirst sendRest -> do - sendFirst (Greet "hi") - sendRest (Greet "tao") - sendRest (Greet "Howareya") + doStream :: Handler App App (Stream.SourceIO Greet) + doStream = return $ S.source [Greet "Hi", Greet "Tao", Greet "Howareya"] doRaw = with auth $ do u <- currentUser 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.3.2 +version: 0.8.4 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. @@ -51,7 +51,6 @@ , bytestring >= 0.10 && < 0.11 , case-insensitive >= 1.2 && < 1.3 , containers >= 0.5 && < 0.7 - , either >= 4.3 && < 5.1 , filepath >= 1 && < 1.5 , http-media >= 0.7.1.2 && < 0.8 , http-types >= 0.8 && < 0.13 @@ -60,13 +59,13 @@ , network-uri >= 2.6 && < 2.7 , mtl >= 2.0 && < 2.3 , mmorph >= 1 && < 1.2 - , servant >= 0.14 && < 0.15 - , string-conversions >= 0.3 && < 0.5 - , text >= 1.2 && < 1.3 + , servant >= 0.15 && < 0.17 , snap >= 1.0 && < 1.2 - , snap-core >= 1.0.2 && < 1.2 + , snap-core >= 1.0 && < 1.1 , snap-server >= 1.0 && < 1.2 + , string-conversions >= 0.3 && < 0.5 , tagged >= 0.8.5 && < 0.9 + , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6 , word8 >= 0.1 && < 0.2 hs-source-dirs: src @@ -82,7 +81,6 @@ aeson , base , bytestring - , either , errors , heist , http-client @@ -90,7 +88,6 @@ , servant , servant-client , servant-snap - , snap-cors , map-syntax , snap , snap-core @@ -106,9 +103,9 @@ hs-source-dirs: test main-is: Spec.hs other-modules: + Servant.Utils.SnapTestUtils Servant.ServerSpec - Servant.StreamingSpec - Servant.Utils.StaticFilesSpec + Servant.Server.CORSSpec build-depends: base == 4.* , aeson @@ -117,17 +114,15 @@ , case-insensitive , containers , directory - , either , exceptions , hspec >= 2.4.3 && < 2.8 + , hspec-core >= 2.4.3 && < 2.8 + , hspec-snap >= 1.0.1.0 && < 1.1 , io-streams , lens , process - , digestive-functors >= 0.8.1.0 && < 0.9 + , digestive-functors >= 0.8.4.0 && < 0.9 , time - , hspec-snap >= 1.0.1.0 && < 1.1 - , hspec-core >= 2.4.3 && < 2.8 - , snap-cors , http-types , HUnit >= 1.4 , mtl diff --git a/src/Servant.hs b/src/Servant.hs --- a/src/Servant.hs +++ b/src/Servant.hs @@ -6,7 +6,7 @@ -- | For implementing servers for servant APIs. module Servant.Server, -- | Utilities on top of the servant core - module Servant.Utils.Links, + module Servant.Links, module Servant.Utils.StaticFiles, -- | Useful re-exports Proxy(..), @@ -15,5 +15,5 @@ import Data.Proxy import Servant.API import Servant.Server -import Servant.Utils.Links +import Servant.Links import Servant.Utils.StaticFiles 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 @@ -10,10 +10,12 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-} @@ -65,18 +67,15 @@ getResponse, route, method, withRequest) import Servant.API ((:<|>) (..), (:>), BasicAuth, - BoundaryStrategy(..), - Capture', CaptureAll, - Description, EmptyAPI, - FramingRender (..), - Header', If, IsSecure(..), - QueryFlag, QueryParam', - QueryParams, Raw, RemoteHost, - ReqBody', ReflectMethod(..), - SBool(..), SBoolI, - Stream, Summary, - ToStreamGenerator (..), Vault, - Verb, getStreamGenerator, sbool) + Capture', + CaptureAll, Description, FramingRender (..), EmptyAPI, + Header', IsSecure(..), If, QueryFlag, IsSecure(..), + QueryParam', QueryParams, Raw, + RemoteHost, ReqBody', + ReflectMethod(..), SBool(..), SBoolI, Stream, Summary, + Verb, sbool + ) +import Servant.API.Stream (ToSourceIO(..)) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), AllMime(..), @@ -86,6 +85,7 @@ RequestArgument, unfoldRequestArgument) import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders, getHeaders) +import qualified Servant.Types.SourceT as S import qualified System.IO.Streams as IOS import Servant.Server.Internal.BasicAuth @@ -289,84 +289,8 @@ -instance {-# OVERLAPPABLE #-} (MimeRender ctype a, - ReflectMethod method, - KnownNat status, - FramingRender framing ctype, - ToStreamGenerator b a) - => HasServer (Stream method status framing ctype b) context m where - type ServerT (Stream method status framing ctype b) context m = m b - hoistServerWithContext _ _ nt s = nt s - route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) - where method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) - -instance {-# OVERLAPPABLE #-} (MimeRender ctype a, - ReflectMethod method, - KnownNat status, - FramingRender framing ctype, - ToStreamGenerator b a, - GetHeaders (Headers h b)) - => HasServer (Stream method status framing ctype (Headers h b)) context m where - - type ServerT (Stream method status framing ctype (Headers h b)) context m = m (Headers h b) - hoistServerWithContext _ _ nt s = nt s - - route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) - where method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) - -streamRouter :: (MimeRender ctype a, - FramingRender framing ctype, - ToStreamGenerator b a, - MonadSnap m - ) => - (c -> ([(HeaderName, B.ByteString)], b)) - -> Method - -> Status - -> Proxy framing - -> Proxy ctype - -> Delayed m env (m c) - -> Router m env -streamRouter splitHeaders method (Status code msg) framingproxy ctypeproxy action = leafRouter $ \env request respond -> - let accH = fromMaybe ct_wildcard $ getHeader hAccept request - cmediatype = NHM.matchAccept [contentType ctypeproxy] accH - accCheck = when (isNothing cmediatype) $ delayedFail err406 - contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype) - in runAction (action `addMethodCheck` methodCheck method request - `addAcceptCheck` accCheck - ) env request respond $ \ output -> - let (headerz, fa) = splitHeaders output - k = getStreamGenerator . toStreamGenerator $ fa in - Route $ setResponseStatus code msg - $ (\r -> foldl' (\r' (h,h') -> addHeader h h' r') r $ contentHeader : headerz) - $ flip setResponseBody emptyResponse $ \outStream -> do - let writeAndFlush bb = IOS.write (Just $ bb <> BB.flush) outStream - writeAndFlush (BB.lazyByteString $ header framingproxy ctypeproxy) - case boundary framingproxy ctypeproxy of - BoundaryStrategyBracket f -> - let go x = let bs = mimeRender ctypeproxy x - (before, after) = f bs - in writeAndFlush ( BB.lazyByteString before - <> BB.lazyByteString bs - <> BB.lazyByteString after) - in k go go - BoundaryStrategyIntersperse sep -> k - (\x -> do - writeAndFlush . BB.lazyByteString $ mimeRender ctypeproxy x - ) - (\x -> do - writeAndFlush . (BB.lazyByteString sep <>) . BB.lazyByteString $ mimeRender ctypeproxy x - ) - BoundaryStrategyGeneral f -> - let go = writeAndFlush . BB.lazyByteString . f . mimeRender ctypeproxy - in k go go - IOS.write (Just . BB.lazyByteString $ trailer framingproxy ctypeproxy) outStream - return outStream - - -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by 'Header'. @@ -726,41 +650,93 @@ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + +-- newtype BasicAuthCheck m usr = +-- BasicAuthCheck { unBasicAuthCheck :: BasicAuthData -> m (BasicAuthResult usr) } +-- deriving (Functor, Generic) + +data BasicAuthResult usr = Unauthorized | BadPassword | NoSuchUser | Authorized usr + deriving (Functor, Eq, Read, Show, Generic) + -- * helpers -- ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP -{- -instance ( MimeRender ctype a, ReflectMethod method, MimeRender ctype a, -- ToStreamGenerator m (f a), - FramingRender framing ctype -- , ToStreamGenerator f a - ) => HasServer (Stream method status framing ctype (f a)) context m where - type ServerT (Stream method status framing ctype (f a)) context m = m (f a) +instance forall ctype chunk method status framing m context a. + ( MimeRender ctype chunk, ReflectMethod method, KnownNat status, + FramingRender framing, MonadSnap m, ToSourceIO chunk a + ) => HasServer (Stream method status framing ctype a) context m where + type ServerT (Stream method status framing ctype a) context m = m a - route Proxy _ action = streamRouter ([],) method (Proxy) (Proxy :: Proxy framing) (Proxy :: Proxy ctype) action + hoistServerWithContext _ _ nt s = nt s + route Proxy _ action = streamRouter ([],) method status + (Proxy :: Proxy framing) + (Proxy :: Proxy ctype) action where method = reflectMethod (Proxy :: Proxy method) - -- status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) -instance ( MimeRender ctype a, ReflectMethod method, MimeRender ctype (f a), -- ToStreamGenerator m (f a), - FramingRender framing ctype, {- ToStreamGenerator f a, -} GetHeaders (Headers h (f a)) - ) => HasServer (Stream method status framing ctype (Headers h (f a))) context m where - type ServerT (Stream method status framing ctype (Headers h (f a))) context m = m (Headers h (f a)) +instance ( MimeRender ctype chunk, ReflectMethod method, MimeRender ctype a, KnownNat status, MonadSnap m, + FramingRender framing, ToSourceIO chunk a, GetHeaders (Headers h a) + ) => HasServer (Stream method status framing ctype (Headers h a)) context m where + type ServerT (Stream method status framing ctype (Headers h a)) context m = m (Headers h a) + hoistServerWithContext _ _ nt s = nt s route Proxy _ action = streamRouter (\x -> (getHeaders x, getResponse x)) method - Proxy + status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) action where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) --- newtype BasicAuthCheck m usr = --- BasicAuthCheck { unBasicAuthCheck :: BasicAuthData -> m (BasicAuthResult usr) } --- deriving (Functor, Generic) +streamRouter :: forall ctype a c chunk env framing m + .(MimeRender ctype chunk, + FramingRender framing, + -- ToSourceIO chunk (m a), + ToSourceIO chunk a, + MonadSnap m + ) => + (c -> ([(HeaderName, B.ByteString)], a)) + -> Method + -> Status + -> Proxy framing + -> Proxy ctype + -> Delayed m env (m c) + -> Router m env +streamRouter splitHeaders method status framingproxy ctypeproxy action = + leafRouter $ \env request respond -> + let accH = fromMaybe ct_wildcard $ getHeader hAccept request + cmediatype = NHM.matchAccept [contentType ctypeproxy] accH + accCheck = when (isNothing cmediatype) $ delayedFail err406 + contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype) + in runAction (action `addMethodCheck` methodCheck method request + `addAcceptCheck` accCheck + ) env request respond $ \ output -> + let (headers', fa) = splitHeaders output + sourceT = toSourceIO fa + S.SourceT kStepLBS = + framingRender framingproxy + (mimeRender ctypeproxy :: chunk -> BL.ByteString) + sourceT + response = setResponseStatus (statusCode status) (statusMessage status) + $ setHeaders (contentHeader:headers') emptyResponse + in + Route $ flip setResponseBody response $ \outStream -> do + let + writeAndFlush bb = IOS.write (Just $ bb <> BB.flush) outStream + justFlush = IOS.write (Just BB.flush) outStream + loop :: S.StepT IO BL.ByteString -> IO (IOS.OutputStream BB.Builder) + loop S.Stop = justFlush >> return outStream + loop (S.Error err) = fail err -- TODO: Provide a better error message + loop (S.Skip s) = loop s + loop (S.Effect ms) = ms >>= loop + loop (S.Yield lbs s) = do + writeAndFlush (BB.lazyByteString lbs) + loop s -data BasicAuthResult usr = Unauthorized | BadPassword | NoSuchUser | Authorized usr - deriving (Functor, Eq, Read, Show, Generic) --} + kStepLBS loop 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 @@ -49,9 +49,9 @@ 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 + snapReq <- getRequest + r <- ra (request `addHeaders` headers snapReq) routingRespond + rspnd <- respond r -- liftIO $ putStrLn $ unlines [ -- "----------" 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 @@ -2,6 +2,7 @@ module Servant.Server.Internal.SnapShims where +import Control.Monad.IO.Class import qualified Data.ByteString.Char8 as B import Data.List (foldl') import Data.IORef @@ -23,7 +24,7 @@ applicationToSnap :: MonadSnap m => Application m -> m () applicationToSnap app = do - req <- getRequest + req <- getRequest snapResp <- getResponse r <- fmap (`addHeaders` headers snapResp) $ app req return putResponse r diff --git a/test/Servant/Server/CORSSpec.hs b/test/Servant/Server/CORSSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Server/CORSSpec.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Server.CORSSpec where + +import Control.Monad.IO.Class (liftIO) +import Data.List (foldl') +import Data.Proxy +import Servant.API ((:<|>) (..), (:>), BasicAuth, + Capture, CaptureAll, Header (..), + Headers, IsSecure (..), JSON, + NoContent (..), NoFraming, + OctetStream, PlainText, QueryFlag, + QueryParam, QueryParams, Raw, + RemoteHost, ReqBody, SourceIO, + Stream, addHeader) +import Servant.API.Verbs (Delete, Get, Patch, Post, Put, + Verb) +import Servant.Server hiding (route) +import Servant.Server.Internal (HasServer) +import Snap +import qualified Snap.Core as SC +import qualified Snap.Test as ST +import qualified Snap.Util.CORS as CORS +import Test.Hspec + +import Servant.Utils.SnapTestUtils + +-- TODO: Cleanup +spec :: Spec +spec = do + corsSanitySpec + +corsSanitySpec :: Spec +corsSanitySpec = do + let handler = CORS.applyCORS CORS.defaultOptions bareEndpoint + bareEndpoint = return () + + servantEndpoint :: Snap () + servantEndpoint = do + let printHeaders m r = liftIO $ putStrLn m >> print (headers r) + respA <- SC.getResponse + serveSnap (Proxy :: Proxy ("int" :> Get '[JSON] Int)) (return 5 :: Snap Int) + + servantSnapletInit :: SnapletInit () () + servantSnapletInit = makeSnaplet "servant-test" "Testing servant" Nothing $ do + addRoutes [ + ("other", SC.writeText "other route") + ,("", servantSnapletHandler) + ] + wrapSite (CORS.applyCORS CORS.defaultOptions) + return () + + servantSnapletHandler :: Handler () () () + servantSnapletHandler = do + let printHeaders m r = liftIO $ putStrLn m >> print (headers r) + respA <- SC.getResponse + serveSnap (Proxy :: Proxy ("int" :> Get '[JSON] Int)) (return 5 :: Handler () () Int) + + forwardHeaders :: Snap () + forwardHeaders = do + req <- SC.getRequest + resp <- SC.getResponse + putResponse $ foldl' (\r (hk, hv) -> SC.setHeader hk hv r) resp (listHeaders req) + + req :: ST.RequestBuilder IO () + req = do + ST.setRequestType $ ST.RequestWithRawBody GET "" + ST.setRequestPath "/" + ST.setHeader "Origin" "http://origin.org" + + req' :: ST.RequestBuilder IO () + req' = do + ST.setRequestType $ ST.RequestWithRawBody GET "" + ST.setRequestPath "int" + ST.setHeader "Origin" "http://origin.org" + + req'' :: ST.RequestBuilder IO () + req'' = do + ST.setRequestType $ ST.RequestWithRawBody GET "" + ST.setRequestPath "other" + ST.setHeader "Origin" "http://origin.org" + + it "Sets CORS and forwards req headers for Snap non-servant handler" $ do + resp <- ST.runHandler req (forwardHeaders >> handler) + Right resp `shouldHaveStatus` 200 + Right resp `shouldHaveHeaders` [("Origin", "http://origin.org") + ,("Access-Control-Allow-Origin", "http://origin.org")] + it "Sets CORS and forwards req headers for Snap handler" $ do + resp <- ST.runHandler req' (CORS.applyCORS CORS.defaultOptions $ forwardHeaders >> servantEndpoint) + Right resp `shouldHaveStatus` 200 + Right resp `shouldDecodeTo` (5 :: Int) + Right resp `shouldHaveHeaders` [("Origin", "http://origin.org") + ,("Access-Control-Allow-Origin", "http://origin.org") + ] + it "Sets CORS and forwards req headers for Snaplet servant handler with wrapSite" $ do + resp <- testSnaplet servantSnapletInit req' + resp `shouldHaveStatus` 200 + resp `shouldDecodeTo` (5 :: Int) + resp `shouldHaveHeaders` [("Access-Control-Allow-Origin", "http://origin.org") + ] + + it "Sets CORS and forwards req headers for Snaplet not-servant handler with wrapSite" $ do + resp <- testSnaplet servantSnapletInit req'' + resp `shouldHaveStatus` 200 + resp `shouldHaveHeaders` [("Access-Control-Allow-Origin", "http://origin.org") + ] diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -17,90 +17,76 @@ ------------------------------------------------------------------------------- -import Control.Lens (makeLenses) -import Control.Monad (forM_, unless, void, when) -import Control.Monad.IO.Class (liftIO) -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Aeson as A -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy as BL -import Data.CaseInsensitive (mk) -import Data.Char (toUpper) -import Data.Functor ((<$>)) -import Data.Maybe (fromMaybe) +import Control.Lens (makeLenses) +import Control.Monad (forM_, unless, + void, when) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as A +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import Data.CaseInsensitive (mk) +import Data.Char (toUpper) +import Data.Functor ((<$>)) +import Data.List (foldl') +import Data.Maybe (fromMaybe) import Data.Monoid -import Data.Proxy (Proxy (Proxy)) -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy.Encoding as TL -import GHC.Generics (Generic) -import Network.HTTP.Types (hAccept, hContentType) +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import GHC.Generics (Generic) +import Network.HTTP.Types (hAccept, + hContentType) import qualified Network.HTTP.Types -import Snap.Core hiding (Headers, addHeader) -import qualified Snap.Core as SC -import Snap.CORS +import Snap.Core hiding (Headers, + addHeader) +import qualified Snap.Core as SC import Snap.Snaplet -import qualified Snap.Snaplet.Test as SST -import qualified Snap.Test as ST +import qualified Snap.Snaplet.Test as SST +import qualified Snap.Test as ST +import qualified Snap.Util.CORS as CORS ------------------------------------------------------------------------------- -import Test.Hspec -import Test.Hspec.Snap hiding (NotFound) -import qualified Test.Hspec.Snap as THS -import qualified Test.HUnit as HU -import Servant.API ((:<|>) (..), (:>), - addHeader, BasicAuth, Capture, - CaptureAll, Header (..), Headers, - IsSecure(..), JSON, NoContent(..), - PlainText, QueryFlag, QueryParam, - QueryParams, Raw, RemoteHost, - ReqBody) -import Servant.API.Verbs (Verb, Get, Post, Put, Delete, - Patch) -import qualified Servant.API.Verbs as V -import Servant.Server hiding (route) -import Servant.Server.Internal (HasServer) +import Servant.API ((:<|>) (..), (:>), + BasicAuth, + Capture, + CaptureAll, + Header (..), + Headers, + IsSecure (..), + JSON, + NoContent (..), + NoFraming, + OctetStream, + PlainText, + QueryFlag, + QueryParam, + QueryParams, Raw, + RemoteHost, + ReqBody, SourceIO, + Stream, addHeader) +import Servant.API.Verbs (Delete, Get, + Patch, Post, Put, + Verb) +import qualified Servant.API.Verbs as V +import Servant.Server hiding (route) +import Servant.Server.Internal (HasServer) import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context +import qualified Servant.Types.SourceT as S +import Servant.Utils.SnapTestUtils import Snap.Snaplet.Auth import Snap.Snaplet.Auth.Backends.JsonFile -import qualified Snap.Util.CORS as CORS import Snap.Snaplet.Session import Snap.Snaplet.Session.Backends.CookieSession - -------------------------------------------------------------------------------- --- * test data types - -data App = App { _auth :: Snaplet (AuthManager App) - , _sess :: Snaplet SessionManager} -makeLenses 'App - -type AppHandler = Handler App App - -app :: SnapletInit App App -app = app' [] - -app' :: [(B8.ByteString, AppHandler ())] -> SnapletInit App App -app' rs = makeSnaplet "servantsnap" "A test app for servant-snap" Nothing $ do - s <- nestSnaplet "sess" sess $ - initCookieSessionManager "site_key.txt" "sess" Nothing (Just 3600) - a <- nestSnaplet "auth" auth $ initJsonFileAuthManager defAuthSettings sess "users.json" - addRoutes rs - wrapSite (\h -> createTestUserIfMissing >> CORS.applyCORS CORS.defaultOptions h) - return (App a s) - -createTestUserIfMissing :: Handler App App () -createTestUserIfMissing = - with auth $ usernameExists testLogin >>= \case - True -> return () - False -> void $ createUser testLogin testPassword - -testLogin = "greg" -testPassword = "p@ssword" - -------------------------------------------------------------------------------- +import qualified Snap.Util.CORS as CORS +import Test.Hspec +import Test.Hspec.Snap hiding (NotFound) +import qualified Test.Hspec.Snap as THS +import qualified Test.HUnit as HU -- * Specs @@ -124,6 +110,7 @@ -- * verbSpec {{{ ------------------------------------------------------------------------------ + type VerbApi method status = Verb method status '[JSON] Person :<|> "noContent" :> Verb method status '[JSON] NoContent @@ -132,6 +119,7 @@ :<|> "accept" :> ( Verb method status '[JSON] Person :<|> Verb method status '[PlainText] String ) + :<|> "stream" :> Stream method status NoFraming OctetStream (SourceIO B8.ByteString) verbSpec :: Spec @@ -142,6 +130,7 @@ :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent) :<|> (return alice :<|> return "B") + :<|> return (S.source ["bytestring"]) get200 = Proxy :: Proxy (VerbApi 'V.GET 200) post210 = Proxy :: Proxy (VerbApi 'V.POST 210) put203 = Proxy :: Proxy (VerbApi 'V.PUT 203) @@ -179,9 +168,10 @@ liftIO $ statusIs response status `shouldBe` True let sInit = app' verbRoutes - runUrl p = SST.runHandler Nothing - (mkRequest method p "" [] "") - (serveSnap api server) sInit + runUrl p = testSnaplet sInit (mkRequest method p "" [] "") + -- runUrl p = SST.runHandler Nothing + -- (mkRequest method p "" [] "") + -- (serveSnap api server) sInit -- This group is run with hspec directly @@ -203,9 +193,9 @@ (serveSnap api server) sInit shouldHaveHeaders resp [("H","5")] + -- TODO: Why doesn't this test pass? it "returs CORS headers" $ do - (_, snapm, _) <- runSnaplet Nothing sInit - resp <- fmap Right $ ST.runHandler (mkRequest method "/noContent" "" [("Origin", "http://example.com")] "") snapm + resp <- testSnaplet sInit (mkRequest method "/noContent" "" [("Origin", "http://example.com")] "") shouldHaveHeaders resp [("access-control-allow-origin" ,"http://example.com")] @@ -223,6 +213,13 @@ resp `shouldHaveStatus` status resp `shouldHaveBody` "B" + unless (method == SC.HEAD) $ it "works for Stream as for Result" $ do + resp <- SST.runHandler Nothing + (mkRequest method "/stream" "" [] "") + (serveSnap api server) sInit + resp `shouldHaveStatus` status + resp `shouldHaveBody` "bytestring" + test "GET 200" get200 (routes get200 EmptyContext server) SC.GET 200 test "POST 210" post210 (routes post210 EmptyContext server) SC.POST 210 test "PUT 203" put203 (routes put203 EmptyContext server) SC.PUT 203 @@ -253,10 +250,10 @@ captureServer2 :: Server CaptureApi2 '[] AppHandler captureServer2 _ = do rq <- getRequest - writeBS (SC.rqPathInfo rq) + writeBS (SC.rqPathInfo rq) captureSpec :: Spec -captureSpec = do -- snap (route (routes captureApi captureServer)) app $ +captureSpec = do -- snap (route (routes captureApi captureServer)) app $ let ( sInit , _ ) = mkInitAndServer captureApi EmptyContext captureServer ( sInit2, _ ) = mkInitAndServer captureApi2 EmptyContext captureServer2 @@ -359,7 +356,7 @@ qpCapitalize True = return alice { name = map toUpper (name alice) } queryParamServer (Just name_) = return alice{name = name_} - queryParamServer Nothing = return alice + queryParamServer Nothing = return alice queryParamSpec :: Spec queryParamSpec = do @@ -696,7 +693,7 @@ where versionHandler = return :: HttpVersion -> AppHandler HttpVersion secureHandler :: IsSecure -> AppHandler String - secureHandler Secure = return "secure" + secureHandler Secure = return "secure" secureHandler NotSecure = return "not secure" hostHandler = return . B8.unpack :: B8.ByteString -> AppHandler String @@ -766,7 +763,7 @@ authHeader un pw = "Basic " <> B64.encode (T.encodeUtf8 un <> ":" <> pw) describe "Checks auth" $ do - + it "returns 401 when not logged in" $ do response <- runReqOnApi baApi (baCheck :. EmptyContext) getSecret SC.GET "/secret" "" [] "" response `shouldHaveStatus` 401 @@ -818,120 +815,22 @@ ------------------------------------------------------------------------------ getStatus :: TestResponse -> Maybe Int -getStatus (Html (RespCode s) _) = Just s -getStatus (Json (RespCode s) _) = Just s -getStatus THS.NotFound = Nothing +getStatus (Html (RespCode s) _) = Just s +getStatus (Json (RespCode s) _) = Just s +getStatus THS.NotFound = Nothing getStatus (Redirect (RespCode s) _) = Just s -getStatus (Other (RespCode s)) = Just s -getStatus Empty = Nothing +getStatus (Other (RespCode s)) = Just s +getStatus Empty = Nothing statusIs :: TestResponse -> Int -> Bool statusIs r s = getStatus r == Just s decodesTo :: (FromJSON a, Eq a) => TestResponse -> a -> Bool decodesTo (Json _ bs) a = A.decode' bs == Just a -decodesTo _ _ = False +decodesTo _ _ = False bodyIs :: TestResponse -> TL.Text -> Bool bodyIs (Html _ t) target = t == TL.toStrict target bodyIs (Json _ b) target = b == TL.encodeUtf8 target -bodyIs _ _ = False - ------------------------------------------------------------------------------- --- * hspec helpers ------------------------------------------------------------------------------- - -shouldHaveBody :: Either T.Text Response -> T.Text -> IO () -shouldHaveBody (Left e) _ = HU.assertFailure $ - "Failed to respond: " ++ T.unpack e -shouldHaveBody (Right r) a = do - bod <- ST.getResponseBody r - bod `shouldBe` T.encodeUtf8 a - -shouldHaveStatus :: Either T.Text Response -> Int -> IO () -shouldHaveStatus (Left e) _ = HU.assertFailure $ - "Failed to respond: " ++ T.unpack e -shouldHaveStatus (Right r) a = do - SC.rspStatus r `shouldBe` a - - -shouldDecodeTo :: (FromJSON a, Eq a, Show a) - => Either T.Text Response - -> a - -> IO () -shouldDecodeTo (Left e) _ = HU.assertFailure $ - "Failed to respond: " ++ T.unpack e -shouldDecodeTo (Right resp) a = do - bod <- ST.getResponseBody resp - case A.decode' $ BL.fromStrict bod of - Just x | x == a -> return () - Just _ -> HU.assertFailure $ - "Failed to decode response to " ++ show a ++ - " from body: " ++ B8.unpack bod - Nothing -> HU.assertFailure $ "Failed to decode respone from body: " ++ - B8.unpack bod ++ "\nResponse: " ++ show resp - -shouldHaveHeaders :: Either T.Text Response - -> [(B8.ByteString, B8.ByteString)] - -> Expectation -shouldHaveHeaders (Left e) _ = expectationFailure $ T.unpack e -shouldHaveHeaders (Right resp) hs = do - let respHs = Set.fromList $ SC.listHeaders resp - hs' = Set.fromList $ (\(k,v) -> (mk k,v)) <$> hs - missing = Set.toList $ Set.difference hs' respHs - case missing of - [] -> return () - _ -> expectationFailure $ - "These expected headers and values were missing: " ++ show missing ++ - " from the response's: " ++ show (Set.toList respHs) - - ------------------------------------------------------------------------------- --- * Assorted Snap helpers ------------------------------------------------------------------------------- - -mkInitAndServer :: (HasServer api context m, m ~ AppHandler) - => Proxy (api :: *) - -> Context context - -> Server api context AppHandler - -> (SnapletInit App App, AppHandler ()) -mkInitAndServer api ctx serv = - let sRoute = serveSnapWithContext api ctx serv - in (app' [("", sRoute)], sRoute) - - -mkRequest :: Method - -> B8.ByteString - -> B8.ByteString - -> [Network.HTTP.Types.Header] - -> B8.ByteString - -> ST.RequestBuilder IO () -mkRequest mth pth qs hds bdy = do - let ct = fromMaybe "" (Prelude.lookup hContentType hds) - ST.postRaw pth ct bdy - ST.setQueryStringRaw qs - unless (mth == SC.POST) $ ST.setRequestType (ST.RequestWithRawBody mth bdy) - forM_ hds (\(k, v) -> unless (k == hContentType) $ ST.addHeader k v) - -- req <- State.get -- Useful for debugging - -- liftIO $ print req - -runReqOnApi :: (HasServer api context m, m ~ AppHandler) - => Proxy (api :: *) - -> Context context - -> Server api context AppHandler - -> Method - -> B8.ByteString - -> B8.ByteString - -> [Network.HTTP.Types.Header] - -> B8.ByteString - -> IO (Either T.Text Response) -runReqOnApi api ctx serv method route qs hds bod = - let (sInit, serv') = mkInitAndServer api ctx serv - in SST.runHandler Nothing (mkRequest method route qs hds bod) serv' sInit +bodyIs _ _ = False -routes :: (HasServer api context m, m ~ AppHandler) - => Proxy (api :: *) - -> Context context - -> Server api context AppHandler - -> [(B8.ByteString, AppHandler ())] -routes p ctx s = [("", serveSnapWithContext p ctx s)] diff --git a/test/Servant/StreamingSpec.hs b/test/Servant/StreamingSpec.hs deleted file mode 100644 --- a/test/Servant/StreamingSpec.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - --- | This module tests whether streaming works from client to server --- with a server implemented with servant-server. -module Servant.StreamingSpec where - -import Control.Concurrent -import Control.Exception hiding (Handler) -import Control.Monad.IO.Class -import qualified Data.ByteString as Strict -import Control.Monad.State (modify) -import qualified Data.ByteString.Lazy as Lazy -import Network.HTTP.Types --- import Network.Wai --- import Network.Wai.Internal -import Prelude --- import Prelude.Compat -import Servant -import Snap.Core -import Snap.Internal.Http.Types -import Snap.Test -import Snap -import qualified System.Timeout -import qualified System.IO.Streams as IOS -import Test.Hspec - -type TestAPI = - ReqBody '[OctetStream] Lazy.ByteString :> Post '[JSON] NoContent - -testAPI :: Proxy TestAPI -testAPI = Proxy - -spec :: Spec -spec = return () --- TODO: This test fails -{- -spec :: Spec -spec = do - -- The idea of this test is this: - -- - -- - The mock client will - -- - send some data in the request body, but not all, - -- - wait for the server to acknowledge (outside of http, through an MVar) - -- that the server received some data, - -- - send the rest of the request body. - -- - The mock server will - -- - receive some data, - -- - notify the client that it received some data, - -- - receive the rest of the data, - -- - respond with an empty result. - it "client to server can stream lazy ByteStrings" $ timeout $ do - serverReceivedFirstChunk <- newWaiter - - -- - streams some test data - -- - waits for serverReceivedFirstChunk - -- - streams some more test data - streamTestData <- do - mvar :: MVar [IO Strict.ByteString] <- newMVar $ - map return (replicate 1000 "foo") ++ - (waitFor serverReceivedFirstChunk >> return "foo") : - map return (replicate 1000 "foo") - return $ modifyMVar mvar $ \ actions -> case actions of - (a : r) -> (r, ) <$> a - [] -> return ([], "") - - rqStream <- IOS.makeInputStream (Just <$> streamTestData) - rqStream2 <- IOS.makeInputStream (return (Just "foo")) - let makeRequest :: RequestBuilder IO () - makeRequest = do - postRaw @IO "/" "application/octet-stream" "barbar" - -- transformRequestBody $ \inStream -> return rqStream - -- modify $ \rq -> rq { rqBody = rqStream } - - -- - receives the first chunk - -- - notifies serverReceivedFirstChunk - -- - receives the rest of the request - let handler :: Lazy.ByteString -> Snap NoContent - handler input = do - liftIO $ putStrLn $ "handler Hello1" - -- rq <- getRequest - -- putRequest (rq { rqBody = rqStream }) - -- transformRequestBody $ \_ -> return rqStream2 - liftIO $ putStrLn $ "handler Hello2" - liftIO $ do - print "handler Hello3" - let prefix = Lazy.take 3 input - prefix `shouldBe` "foo" - print "handler Hello4" - notify serverReceivedFirstChunk () - print "handler Hello5" - input `shouldBe` mconcat (replicate 2001 "foo") - return NoContent - - app = serveSnap testAPI handler - putStrLn "Hello1" - response <- executeRequest rqStream makeRequest app - rspStatus response `shouldBe` 200 - -executeRequest :: IOS.InputStream Strict.ByteString -> RequestBuilder IO () -> Snap () -> IO Response -executeRequest rqStream makeRequest act = do - responseMVar <- newEmptyMVar - putStrLn "Hello2" - -- evalHandler (buildRequest get (Lazy.replicate "foo" 2001)) (act >> putMVar responseMVar response) - -- evalHandler makeRequest (act >> get >>= \r -> liftIO (putMVar responseMVar r)) - evalHandler makeRequest $ do - liftIO $ putStrLn "Hello3" - -- rq <- getRequest - liftIO $ putStrLn "Hello3.5" - -- putRequest (rq { rqBody = rqStream }) - transformRequestBody $ \_ -> return rqStream - liftIO $ putStrLn "Hello3.7" - act - liftIO $ putStrLn "Hello4" - r <- Snap.getResponse - liftIO (putMVar responseMVar r) - - -- (act >> get >>= \r -> liftIO (putMVar responseMVar r)) - -- let respond response = do - -- putMVar responseMVar response - -- return ResponseReceived - -- ResponseReceived <- app request respond - takeMVar responseMVar - --- executeRequest :: Application -> Request -> IO Response --- executeRequest app request = do --- responseMVar <- newEmptyMVar --- let respond response = do --- putMVar responseMVar response --- return ResponseReceived --- ResponseReceived <- app request respond --- takeMVar responseMVar - -timeout :: IO a -> IO a -timeout action = do - result <- System.Timeout.timeout 1000000 action - maybe (throwIO $ ErrorCall "timeout") return result - --- * waiter - -data Waiter a - = Waiter { - notify :: a -> IO (), - waitFor :: IO a - } - -newWaiter :: IO (Waiter a) -newWaiter = do - mvar <- newEmptyMVar - return $ Waiter { - notify = putMVar mvar, - waitFor = readMVar mvar - } --} diff --git a/test/Servant/Utils/SnapTestUtils.hs b/test/Servant/Utils/SnapTestUtils.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Utils/SnapTestUtils.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Servant.Utils.SnapTestUtils where + +import Control.Lens (makeLenses) +import Control.Monad (forM_, unless, + void, when) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson +import qualified Data.Aeson as A +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import Data.CaseInsensitive (mk) +import Data.List (foldl') +import Data.Maybe (fromMaybe) +import Data.Proxy +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Types (hAccept, + hContentType) +import qualified Network.HTTP.Types +import Servant.API ((:<|>) (..), (:>), + BasicAuth, + Capture, + CaptureAll, + Header (..), + Headers, + IsSecure (..), + JSON, + NoContent (..), + NoFraming, + OctetStream, + PlainText, + QueryFlag, + QueryParam, + QueryParams, Raw, + RemoteHost, + ReqBody, SourceIO, + Stream, addHeader) +import Servant.API.Verbs (Delete, Get, + Patch, Post, Put, + Verb) +import Servant.Server hiding (route) +import Servant.Server.Internal (HasServer) +import Snap +import qualified Snap.Core as SC +import Snap.Snaplet +import Snap.Snaplet.Auth +import Snap.Snaplet.Auth.Backends.JsonFile +import Snap.Snaplet.Session +import Snap.Snaplet.Session.Backends.CookieSession +import qualified Snap.Test as ST +import qualified Snap.Util.CORS as CORS +import Test.Hspec +import qualified Test.HUnit as HU + + +data App = App { _auth :: Snaplet (AuthManager App) + , _sess :: Snaplet SessionManager} +makeLenses 'App + +type AppHandler = Handler App App + +app :: SnapletInit App App +app = app' [] + +app' :: [(B8.ByteString, AppHandler ())] -> SnapletInit App App +app' rs = makeSnaplet "servantsnap" "A test app for servant-snap" Nothing $ do + s <- nestSnaplet "sess" sess $ + initCookieSessionManager "site_key.txt" "sess" Nothing (Just 3600) + a <- nestSnaplet "auth" auth $ initJsonFileAuthManager defAuthSettings sess "users.json" + addRoutes rs + wrapSite (\h -> createTestUserIfMissing >> CORS.applyCORS CORS.defaultOptions h) + return (App a s) + +createTestUserIfMissing :: Handler App App () +createTestUserIfMissing = + with auth $ usernameExists testLogin >>= \case + True -> return () + False -> void $ createUser testLogin testPassword + +testLogin = "greg" +testPassword = "p@ssword" +------------------------------------------------------------------------------ +-- * Assorted Snap helpers +------------------------------------------------------------------------------ + + +mkInitAndServer :: (HasServer api context m, m ~ AppHandler) + => Proxy (api :: *) + -> Context context + -> Server api context (AppHandler) + -> (SnapletInit App App, AppHandler ()) +mkInitAndServer api ctx serv = + let sRoute = serveSnapWithContext api ctx serv + in (app' [("", sRoute)], sRoute) + + +mkRequest :: Method + -> B8.ByteString + -> B8.ByteString + -> [Network.HTTP.Types.Header] + -> B8.ByteString + -> ST.RequestBuilder IO () +mkRequest mth pth qs hds bdy = do + let ct = fromMaybe "" (Prelude.lookup hContentType hds) + ST.postRaw pth ct bdy + ST.setQueryStringRaw qs + unless (mth == SC.POST) $ ST.setRequestType (ST.RequestWithRawBody mth bdy) + forM_ hds (\(k, v) -> unless (k == hContentType) $ ST.addHeader k v) + -- req <- State.get -- Useful for debugging + -- liftIO $ print req + +runReqOnApi :: (HasServer api context m, m ~ AppHandler) + => Proxy (api :: *) + -> Context context + -> Server api context AppHandler + -> Method + -> B8.ByteString + -> B8.ByteString + -> [Network.HTTP.Types.Header] + -> B8.ByteString + -> IO (Either T.Text Response) +runReqOnApi api ctx serv method route qs hds bod = + let (sInit, serv') = mkInitAndServer api ctx serv + -- in SST.runHandler Nothing (mkRequest method route qs hds bod) serv' sInit + in testSnaplet sInit (mkRequest method route qs hds bod) + +routes :: (HasServer api context m, m ~ AppHandler) + => Proxy (api :: *) + -> Context context + -> Server api context (AppHandler) + -> [(B8.ByteString, AppHandler ())] +routes p ctx s = [("", serveSnapWithContext p ctx s)] + +testSnaplet :: SnapletInit b b -> ST.RequestBuilder IO () -> IO (Either T.Text Response) +testSnaplet snapletInit req = do + (_, snapm, _) <- runSnaplet Nothing snapletInit + fmap Right $ ST.runHandler req snapm + +------------------------------------------------------------------------------ +-- * hspec helpers +------------------------------------------------------------------------------ + +shouldHaveBody :: Either T.Text Response -> T.Text -> IO () +shouldHaveBody (Left e) _ = HU.assertFailure $ + "Failed to respond: " ++ T.unpack e +shouldHaveBody (Right r) a = do + bod <- ST.getResponseBody r + bod `shouldBe` T.encodeUtf8 a + +shouldHaveStatus :: Either T.Text Response -> Int -> IO () +shouldHaveStatus (Left e) _ = HU.assertFailure $ + "Failed to respond: " ++ T.unpack e +shouldHaveStatus (Right r) a = do + SC.rspStatus r `shouldBe` a + + +shouldDecodeTo :: (FromJSON a, Eq a, Show a) + => Either T.Text Response + -> a + -> IO () +shouldDecodeTo (Left e) _ = HU.assertFailure $ + "Failed to respond: " ++ T.unpack e +shouldDecodeTo (Right resp) a = do + bod <- ST.getResponseBody resp + case A.decode' $ BL.fromStrict bod of + Just x | x == a -> return () + Just _ -> HU.assertFailure $ + "Failed to decode response to " ++ show a ++ + " from body: " ++ B8.unpack bod + Nothing -> HU.assertFailure $ "Failed to decode respone from body: " ++ + B8.unpack bod ++ "\nResponse: " ++ show resp + +shouldHaveHeaders :: Either T.Text Response + -> [(B8.ByteString, B8.ByteString)] + -> Expectation +shouldHaveHeaders (Left e) _ = expectationFailure $ T.unpack e +shouldHaveHeaders (Right resp) hs = do + let respHs = Set.fromList $ SC.listHeaders resp + hs' = Set.fromList $ (\(k,v) -> (mk k,v)) <$> hs + missing = Set.toList $ Set.difference hs' respHs + case missing of + [] -> return () + _ -> expectationFailure $ + "These expected headers and values were missing: " ++ show missing ++ + " from the response's: " ++ show (Set.toList respHs) + diff --git a/test/Servant/Utils/StaticFilesSpec.hs b/test/Servant/Utils/StaticFilesSpec.hs deleted file mode 100644 --- a/test/Servant/Utils/StaticFilesSpec.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Servant.Utils.StaticFilesSpec where - -import Control.Exception (bracket) -import Control.Monad.IO.Class (liftIO) -import Data.Proxy (Proxy(Proxy)) -import Snap.Core (route) -import Snap.Snaplet (Handler, SnapletInit, makeSnaplet) -import System.Directory (getCurrentDirectory, setCurrentDirectory, createDirectory) -import System.IO.Temp (withSystemTempDirectory) -import Test.Hspec (Spec, describe, it, around_, shouldBe) -import Test.Hspec.Snap (get, snap, TestResponse(..), RespCode(..)) - -import Servant.API (JSON) -import Servant.API.Alternative ((:<|>)((:<|>))) -import Servant.API.Capture (Capture) -import Servant.API.Verbs -import Servant.API.Raw (Raw) -import Servant.API.Sub ((:>)) -import Servant.Server (Server, serveSnap) -import Servant.ServerSpec (Person(Person)) -import Servant.Utils.StaticFiles (serveDirectory) - -type Api = - "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person - :<|> "static" :> Raw - -type AppHandler = Handler () () - -api :: Proxy Api -api = Proxy - -app :: SnapletInit () () -app = makeSnaplet "servantsnap" "A test for servant-snap" Nothing (return ()) - -server :: Server Api '[] AppHandler -server = - (\ name_ -> return (Person name_ 42)) - :<|> serveDirectory "static" - -withStaticFiles :: IO () -> IO () -withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir -> - bracket (setup tmpDir) teardown (const action) - where - setup tmpDir = do - outer <- getCurrentDirectory - setCurrentDirectory tmpDir - createDirectory "static" - writeFile "static/foo.txt" "bar" - writeFile "static/index.html" "index" - return outer - - teardown outer = do - setCurrentDirectory outer - -spec :: Spec -spec = do - around_ withStaticFiles $ snap (route ([("", serveSnap api server)])) app $ do - describe "serveDirectory" $ do - it "successfully serves files" $ do - response <- get "/static/foo.txt" - liftIO $ response `shouldBe` Html (RespCode 200) "bar" - - it "serves the contents of index.html when requesting the root of a directory" $ do - response <- get "/static/" - liftIO $ response `shouldBe` Html (RespCode 200) "index"