servant-snap 0.8.3.1 → 0.8.3.2
raw patch · 7 files changed
+1181/−7 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−0
- servant-snap.cabal +5/−1
- src/Servant/Server/Internal/RoutingApplication.hs +4/−5
- src/Servant/Server/Internal/SnapShims.hs +2/−1
- test/Servant/ServerSpec.hs +937/−0
- test/Servant/StreamingSpec.hs +158/−0
- test/Servant/Utils/StaticFilesSpec.hs +70/−0
CHANGELOG.md view
@@ -1,3 +1,8 @@+0.8.3.2+-----++Include the changes intended for 0.8.3.1 in git and the release sdist+ 0.8.3.1 -----
servant-snap.cabal view
@@ -1,5 +1,5 @@ name: servant-snap-version: 0.8.3.1+version: 0.8.3.2 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.@@ -105,6 +105,10 @@ default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs+ other-modules:+ Servant.ServerSpec+ Servant.StreamingSpec+ Servant.Utils.StaticFilesSpec build-depends: base == 4.* , aeson
src/Servant/Server/Internal/RoutingApplication.hs view
@@ -49,10 +49,9 @@ toApplication :: forall m. MonadSnap m => RoutingApplication m -> Application m toApplication ra request respond = do - snapReq <- getRequest- r <- ra request routingRespond- snapResp <- getResponse- rspnd <- respond (r `addHeaders` headers snapResp)+ snapReq <- getRequest+ r <- ra (request `addHeaders` headers snapReq) routingRespond+ rspnd <- respond r -- liftIO $ putStrLn $ unlines [ -- "----------"@@ -71,7 +70,7 @@ -- , "rspnd" -- , show rspnd -- ]- + return rspnd -- snapReq <- getRequest
src/Servant/Server/Internal/SnapShims.hs view
@@ -24,7 +24,8 @@ applicationToSnap :: MonadSnap m => Application m -> m () applicationToSnap app = do req <- getRequest- r <- app req return+ snapResp <- getResponse+ r <- fmap (`addHeaders` headers snapResp) $ app req return putResponse r addHeaders :: HasHeaders a => a -> Headers -> a
+ test/Servant/ServerSpec.hs view
@@ -0,0 +1,937 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+++module Servant.ServerSpec where+++-------------------------------------------------------------------------------+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 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 qualified Network.HTTP.Types+import Snap.Core hiding (Headers, addHeader)+import qualified Snap.Core as SC+import Snap.CORS+import Snap.Snaplet+import qualified Snap.Snaplet.Test as SST+import qualified Snap.Test as ST+-------------------------------------------------------------------------------+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.Server.Internal.BasicAuth+import Servant.Server.Internal.Context+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"++-------------------------------------------------------------------------------+++-- * Specs++spec :: Spec+spec = do+ verbSpec+ captureSpec+ captureAllSpec+ queryParamSpec+ reqBodySpec+ headerSpec+ rawSpec+ alternativeSpec+ responseHeadersSpec+ miscCombinatorSpec+ fallthroughSpec+ basicAuthSpec++------------------------------------------------------------------------------+-- * verbSpec {{{+------------------------------------------------------------------------------++type VerbApi method status+ = Verb method status '[JSON] Person+ :<|> "noContent" :> Verb method status '[JSON] NoContent+ :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)+ :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)+ :<|> "accept" :> ( Verb method status '[JSON] Person+ :<|> Verb method status '[PlainText] String+ )+++verbSpec :: Spec+verbSpec = do+ let server :: Server (VerbApi method status) '[] AppHandler+ server = return alice+ :<|> return NoContent+ :<|> return (addHeader 5 alice)+ :<|> return (addHeader 10 NoContent)+ :<|> (return alice :<|> return "B")+ get200 = Proxy :: Proxy (VerbApi 'V.GET 200)+ post210 = Proxy :: Proxy (VerbApi 'V.POST 210)+ put203 = Proxy :: Proxy (VerbApi 'V.PUT 203)+ delete280 = Proxy :: Proxy (VerbApi 'V.DELETE 280)+ patch214 = Proxy :: Proxy (VerbApi 'V.PATCH 214)+ wrongMethod m = if m == SC.PUT then SC.POST else SC.PUT+ test (desc :: String) api verbRoutes (method :: SC.Method) (status :: Int) =+ describe ("Servant.API.Verb " ++ desc) $ do++ -- This group is run with hspec-snap+ snap (route verbRoutes) app $ do++ -- HEAD should not return body+ when (method == SC.HEAD) $+ it "HEAD returns no content body" $ do+ response <- runRequest $ mkRequest method "/" "" [] ""+ liftIO $ bodyIs response "" `shouldBe` True++ it "throws 405 on wrong method " $ do+ response <- runRequest $ mkRequest (wrongMethod method) "/" "" [] ""+ liftIO $ statusIs response 405 `shouldBe` True++ it "handles trailing '/' gracefully" $ do+ response <- runRequest $ mkRequest method "/headerNC/" "" [] ""+ liftIO $ statusIs response status `shouldBe` True++ it "returns 406 if the Accept header is not supported" $ do+ response <- runRequest $ mkRequest method "" ""+ [(hAccept, "crazy/mime")] ""+ liftIO $ statusIs response 406 `shouldBe` True++ it "responds if the Accept header is supported" $ do+ response <- runRequest $ mkRequest method "" ""+ [(hAccept, "application/json;charset=utf-8")] ""+ liftIO $ statusIs response status `shouldBe` True++ let sInit = app' verbRoutes+ runUrl p = SST.runHandler Nothing+ (mkRequest method p "" [] "")+ (serveSnap api server) sInit++ -- This group is run with hspec directly++ -- HEAD and 214/215 need not return bodies+ unless (status `elem` [214, 215] || method == SC.HEAD) $+ it "returns the person" $ do+ resp <- runUrl "/"+ resp `shouldDecodeTo` alice+ resp `shouldHaveStatus` status++ it "returns no content on NoContent" $ do+ resp <- runUrl "/noContent"+ resp `shouldHaveStatus` status+ resp `shouldHaveBody` ""++ it "returs headers" $ do+ resp <- SST.runHandler Nothing+ (mkRequest method "/header" "" [] "")+ (serveSnap api server) sInit+ shouldHaveHeaders resp [("H","5")]++ it "returs CORS headers" $ do+ (_, snapm, _) <- runSnaplet Nothing sInit+ resp <- fmap Right $ ST.runHandler (mkRequest method "/noContent" "" [("Origin", "http://example.com")] "") snapm+ shouldHaveHeaders resp [("access-control-allow-origin"+ ,"http://example.com")]++ it "sets the content-type header" $ do+ resp <- SST.runHandler Nothing (mkRequest method "" "" [] "")+ (serveSnap api server) sInit+ resp `shouldHaveHeaders` [("Content-Type", "application/json;charset=utf-8")]++ unless (status `elem` [214, 215] || method == SC.HEAD) $+ it "allows modular specification of supported content types" $ do+ resp <- SST.runHandler Nothing+ (mkRequest method "/accept" ""+ [(hAccept, "text/plain")] "")+ (serveSnap api server) sInit+ resp `shouldHaveStatus` status+ resp `shouldHaveBody` "B"++ 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+ test "DELETE 280" delete280 (routes delete280 EmptyContext server) SC.DELETE 280+ test "PATCH 214" patch214 (routes patch214 EmptyContext server) SC.PATCH 214+ test "GET 200 with HEAD" get200 (routes get200 EmptyContext server) SC.HEAD 200++-- }}}++------------------------------------------------------------------------------+-- * captureSpec {{{+------------------------------------------------------------------------------++type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal+captureApi :: Proxy CaptureApi+captureApi = Proxy+captureServer :: Integer -> AppHandler Animal+captureServer legs = case legs of+ 4 -> return jerry+ 2 -> return tweety+ _ -> throwError err404++type CaptureApi2 = Capture "captured" String :> Raw++captureApi2 :: Proxy CaptureApi2+captureApi2 = Proxy++captureServer2 :: Server CaptureApi2 '[] AppHandler+captureServer2 _ = do+ rq <- getRequest+ writeBS (SC.rqPathInfo rq) ++captureSpec :: Spec+captureSpec = do -- snap (route (routes captureApi captureServer)) app $ ++ let ( sInit , _ ) = mkInitAndServer captureApi EmptyContext captureServer+ ( sInit2, _ ) = mkInitAndServer captureApi2 EmptyContext captureServer2+ runReq r method api serv i =+ SST.runHandler Nothing (mkRequest method r "" [] "")+ (serveSnap api serv) i++ describe "Servant.API.Capture" $ do++ it "can capture parts of the 'pathInfo'" $ do+ runReq "/2" SC.GET captureApi captureServer sInit >>=+ (`shouldDecodeTo` tweety)++ it "returns 400 if the decoding fails" $ do+ runReq "/notAnInt" SC.GET captureApi captureServer sInit >>=+ (`shouldHaveStatus` 400)++ it "strips the captured path snippet from pathInfo" $ do+ runReq "/captured/foo" SC.GET captureApi2 captureServer2 sInit2 >>=+ (`shouldHaveBody` "foo")++-- }}}+------------------------------------------------------------------------------+-- * captureAllSpec {{{+------------------------------------------------------------------------------++type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal+captureAllApi :: Proxy CaptureAllApi+captureAllApi = Proxy+captureAllServer :: [Integer] -> AppHandler Animal+captureAllServer legs = case sum legs of+ 4 -> return jerry+ 2 -> return tweety+ 0 -> return beholder+ _ -> throwError err404++captureAllSpec :: Spec+captureAllSpec = do+ describe "Servant.API.CaptureAll" $ do++ let runUrl u = runReqOnApi captureAllApi EmptyContext captureAllServer SC.GET u "" [] ""+ it "can capture a single element of the 'pathInfo'" $ do+ runUrl "/2" >>= (`shouldDecodeTo` tweety)+ -- liftIO $ decodesTo response tweety `shouldBe` True++ it "can capture multiple elements of the 'pathInfo'" $ do+ runUrl "/2/2" >>= (`shouldDecodeTo` jerry)+ -- liftIO $ decodesTo response jerry `shouldBe` True++ it "can capture arbitrarily many elements of the 'pathInfo'" $ do+ runUrl "/1/1/0/1/0/1" >>= (`shouldDecodeTo` jerry)+ -- liftIO $ decodesTo response jerry `shouldBe` True++ it "can capture when there are no elements in 'pathInfo'" $ do+ runUrl "/" >>= (`shouldDecodeTo` beholder)+ -- liftIO $ decodesTo response jerry `shouldBe` True++ it "returns 400 if the decoding fails" $ do+ runUrl "/notAnInt" >>= (`shouldHaveStatus` 400)+ -- liftIO $ statusIs response 400 `shouldBe` True++ it "returns 400 if the decoding fails, regardless of which element" $ do+ runUrl "/1/0/0/notAnInt/3/" >>= (`shouldHaveStatus` 400)+ -- liftIO $ statusIs response 400 `shouldBe` True++ it "returns 400 if the decoding fails, even when it's multiple elements" $ do+ runUrl "/1/0/0/notAnInt/3/orange/" >>= (`shouldHaveStatus` 400)+ -- liftIO $ statusIs response 400 `shouldBe` True++ it "consumes everything from pathInfo" $ do+ let api' = (Proxy :: Proxy (CaptureAll "segments" String :> Raw))+ srv' = (\_ -> getRequest >>= writeBS . rqPathInfo)+ req <- runReqOnApi api' EmptyContext srv' SC.GET "/captured/foo/bar/baz" "" [] ""+ req `shouldHaveBody` ""++ -- (\ _captured request_ respond ->+ -- respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do+ -- get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))+++-- }}}+------------------------------------------------------------------------------+-- * queryParamSpec {{{+------------------------------------------------------------------------------++type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person+ :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person+ :<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person++queryParamApi :: Proxy QueryParamApi+queryParamApi = Proxy++qpServer :: Server QueryParamApi '[] AppHandler+qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize++ where qpNames (_:name2:_) = return alice { name = name2 }+ qpNames _ = return alice++ qpCapitalize False = return alice+ qpCapitalize True = return alice { name = map toUpper (name alice) }++ queryParamServer (Just name_) = return alice{name = name_}+ queryParamServer Nothing = return alice++queryParamSpec :: Spec+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")] ""++ it "allows retrieving simple GET parameters" $+ runTest "" "?name=bob" >>= (`shouldDecodeTo` alice {name="bob"})++{-+(flip runSession) (serve queryParamApi qpServer) $ do+ let params1 = "?name=bob"+ response1 <- Network.Wai.Test.request defaultRequest{+ rawQueryString = params1,+ queryString = parseQuery params1+ }+ liftIO $ do+ decode' (simpleBody response1) `shouldBe` Just alice{+ name = "bob"+ }+-}++ it "allows retrieving lists in GET parameters" $+ runTest "a" "?names[]=bob&names[]=john" >>= (`shouldDecodeTo` alice{name="john"})++{-+ (flip runSession) (serve queryParamApi qpServer) $ do+ let params2 = "?names[]=bob&names[]=john"+ response2 <- Network.Wai.Test.request defaultRequest{+ rawQueryString = params2,+ queryString = parseQuery params2,+ pathInfo = ["a"]+ }+ liftIO $+ decode' (simpleBody response2) `shouldBe` Just alice{+ name = "john"+ }+-}+++ it "allows retrieving value-less GET parameters" $ do+ runTest "b" "?capitalize" >>= (`shouldDecodeTo` alice{name="ALICE"})++{-+ (flip runSession) (serve queryParamApi qpServer) $ do+ let params3 = "?capitalize"+ response3 <- Network.Wai.Test.request defaultRequest{+ rawQueryString = params3,+ queryString = parseQuery params3,+ pathInfo = ["b"]+ }+ liftIO $+ decode' (simpleBody response3) `shouldBe` Just alice{+ name = "ALICE"+ }+-}++ -- let params3' = "?capitalize="+ runTest "b" "?capitalize=" >>= (`shouldDecodeTo` alice{name="ALICE"})+{-+ response3' <- Network.Wai.Test.request defaultRequest{+ rawQueryString = params3',+ queryString = parseQuery params3',+ pathInfo = ["b"]+ }+ liftIO $+ decode' (simpleBody response3') `shouldBe` Just alice{+ name = "ALICE"+ }+-}++ -- let params3'' = "?unknown="+ runTest "b" "?unknown=" >>= (`shouldDecodeTo` alice{name="Alice"})+{-+ response3'' <- Network.Wai.Test.request defaultRequest{+ rawQueryString = params3'',+ queryString = parseQuery params3'',+ pathInfo = ["b"]+ }+ liftIO $+ decode' (simpleBody response3'') `shouldBe` Just alice{+ name = "Alice"+ }+-}++-- }}}+------------------------------------------------------------------------------+-- * reqBodySpec {{{+------------------------------------------------------------------------------+type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person+ :<|> "blah" :> ReqBody '[JSON] Person :> Put '[JSON] Integer++reqBodyApi :: Proxy ReqBodyApi+reqBodyApi = Proxy++reqBodySpec :: Spec+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"+ badCT = "application/nonsense"++ it "passes the argument to the handler" $ do+ -- response <- mkReq post "" (encode alice)+ runTest SC.POST "" goodCT (BL.toStrict $ A.encode alice) >>=+ (`shouldDecodeTo` alice)+ -- liftIO $ decodesTo response alice `shouldBe` True++ it "rejects invalid request bodies with status 400" $ do+ -- runReqOnApi reqBodyApi server SC.PUT "/blah"+ runTest SC.PUT "/blah" goodCT "some invalid body" >>= (`shouldHaveStatus` 400)+ -- mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400++ it "responds with 415 if the request body media type is unsupported" $ do+ runTest SC.POST "/" badCT ""+ >>= (`shouldHaveStatus` 415)+ -- post "/"+ -- [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415++ where server :: Server ReqBodyApi '[] AppHandler+ server = return :<|> return . age+ -- mkReq handler method x = mkRequest x+ -- [(hContentType, "application/json;charset=utf-8")] ""+++-- }}}+------------------------------------------------------------------------------+-- * headerSpec {{{+------------------------------------------------------------------------------++type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] NoContent+headerApi :: Proxy (HeaderApi a)+headerApi = Proxy+++headerSpec :: Spec+headerSpec = describe "Servant.API.Header" $ do++ let expectsInt :: Maybe Int -> AppHandler NoContent+ expectsInt (Just x) = do+ when (x /= 5) $ error "Expected 5"+ return NoContent+ expectsInt Nothing = error "Expected an int"++ let expectsString :: Maybe String -> AppHandler NoContent+ expectsString (Just x) = do+ when (x /= "more from you") $ error "Expected more from you"+ return NoContent+ expectsString Nothing = error "Expected a string"++ --with (return (serve headerApi expectsInt)) $ do+ -- let delete' x = delete x [("MyHeader", "5")]++ -- TODO: Fix this+ -- it "passes the header to the handler (Int)" $ do+ -- runReqOnApi headerApi EmptyContext expectsInt SC.DELETE "/" "" [("MyHeader","5")] "" >>= (`shouldHaveStatus` 200)+ -- --delete' "/" "" `shouldRespondWith` 200++ -- with (return (serve headerApi expectsString)) $ do+ -- let delete' x = delete x [("MyHeader", "more from you")]++ -- TODO: Fix this+ -- it "passes the header to the handler (String)" $ do+ -- runReqOnApi headerApi EmptyContext expectsString SC.DELETE "/" "" [("MyHeader","more from you")] "" >>= (`shouldHaveStatus` 200)+ -- -- delete' "/" "" `shouldRespondWith` 200+ return ()+++-- }}}+------------------------------------------------------------------------------+-- * rawSpec {{{+------------------------------------------------------------------------------++type RawApi = "foo" :> Raw++rawApi :: Proxy RawApi+rawApi = Proxy++rawServer :: Show a => (Request -> a) -> AppHandler ()+rawServer f = do+ (writeBS . B8.pack . show . f) =<< getRequest++rawSpec :: Spec+rawSpec = do+ describe "Servant.API.Raw" $ do++ it "runs applications" $ do+ runReqOnApi rawApi EmptyContext (rawServer (const (42 :: Integer))) SC.GET "foo" "" [] "" >>= (`shouldHaveBody` "42")++{-+ (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do+ response <- Network.Wai.Test.request defaultRequest{+ pathInfo = ["foo"]+ }+ liftIO $ do+ simpleBody response `shouldBe` "42"+-}++ it "gets the pathInfo modified" $ do+ runReqOnApi rawApi EmptyContext (rawServer rqPathInfo) SC.GET "foo/bar" "" [] "" >>=+ (`shouldHaveBody` (T.pack (show ("bar" :: B8.ByteString))))++{-+ (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do+ response <- Network.Wai.Test.request defaultRequest{+ pathInfo = ["foo", "bar"]+ }+ liftIO $ do+ simpleBody response `shouldBe` cs (show ["bar" :: String])+-}++-- }}}+------------------------------------------------------------------------------+-- * alternativeSpec {{{+------------------------------------------------------------------------------+type AlternativeApi =+ "foo" :> Get '[JSON] Person+ :<|> "bar" :> Get '[JSON] Animal+ :<|> "foo" :> Get '[PlainText] T.Text+ :<|> "bar" :> Post '[JSON] Animal+ :<|> "bar" :> Put '[JSON] Animal+ :<|> "bar" :> Delete '[JSON] NoContent++alternativeApi :: Proxy AlternativeApi+alternativeApi = Proxy++alternativeServer :: Server AlternativeApi '[] AppHandler+alternativeServer =+ return alice+ :<|> return jerry+ :<|> return "a string"+ :<|> return jerry+ :<|> return jerry+ :<|> return NoContent++alternativeSpec :: Spec+alternativeSpec = do+ describe "Servant.API.Alternative" $ do++ it "unions endpoints" $ do+ -- response <- get "/foo"+ response <- runReqOnApi alternativeApi EmptyContext alternativeServer SC.GET "/foo" "" [] ""+ response `shouldDecodeTo` alice+ -- liftIO $ do+ -- decodesTo response alice `shouldBe` True+ -- response_ <- get "/bar"+ response_ <- runReqOnApi alternativeApi EmptyContext alternativeServer SC.GET "/bar" "" [] ""+ response_ `shouldDecodeTo` jerry+ -- liftIO $ do+ -- decodesTo response_ jerry `shouldBe`+ -- True++ it "checks all endpoints before returning 415" $ do+ -- response <- get "/foo"+ response <- runReqOnApi alternativeApi EmptyContext alternativeServer SC.GET "/foo" "" [] ""+ response `shouldHaveStatus` 200+ -- liftIO $ statusIs response 200 `shouldBe` True++ it "returns 404 if the path does not exist" $ do+ -- response <- get "/nonexistent"+ response <- runReqOnApi alternativeApi EmptyContext alternativeServer SC.GET "/nonexistent" "" [] ""+ response `shouldHaveStatus` 404+ -- liftIO $ statusIs response 404 `shouldBe` True+-- }}}+------------------------------------------------------------------------------+-- * responseHeaderSpec {{{+------------------------------------------------------------------------------+type ResponseHeadersApi =+ Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)+ :<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)+ :<|> Put '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)+ :<|> Patch '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)++responseHeadersApi :: Proxy ResponseHeadersApi+responseHeadersApi = Proxy++responseHeadersServer :: Server ResponseHeadersApi '[] AppHandler+responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"+ in h :<|> h :<|> h :<|> h+++responseHeadersSpec :: Spec+responseHeadersSpec = describe "ResponseHeaders" $ do++ let methods = [SC.GET, SC.POST, SC.PUT, SC.PATCH]++ it "includes the headers in the response" $+ forM_ methods $ \method -> do+ req <- runReqOnApi responseHeadersApi EmptyContext responseHeadersServer method "/" "" [] ""+ req `shouldHaveStatus` 200+ req `shouldHaveHeaders` [("H1","5"),("H2","kilroy")]++{-+ method "/" [] ""+ `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]+ , matchStatus = 200+ }+-}++ it "responds with not found for non-existent endpoints" $+ forM_ methods $ \method ->+ runReqOnApi responseHeadersApi EmptyContext responseHeadersServer method "blahblah" "" [] "" >>= (`shouldHaveStatus` 404)+ -- method "blahblah" [] ""+ -- `shouldRespondWith` 404++ it "returns 406 if the Accept header is not supported" $+ forM_ methods $ \method ->+ runReqOnApi responseHeadersApi EmptyContext responseHeadersServer method "" "" [(hAccept, "crazy/mime")] "" >>= (`shouldHaveStatus` 406)+ -- method "" [(hAccept, "crazy/mime")] ""+ -- `shouldRespondWith` 406+++-- }}}+------------------------------------------------------------------------------+-- * miscCombinatorSpec {{{+------------------------------------------------------------------------------++type MiscCombinatorsAPI+ = "version" :> HttpVersion :> Get '[JSON] HttpVersion+ :<|> "secure" :> IsSecure :> Get '[JSON] String+ :<|> "host" :> RemoteHost :> Get '[PlainText] String++miscApi :: Proxy MiscCombinatorsAPI+miscApi = Proxy++miscServ :: Server MiscCombinatorsAPI '[] AppHandler+miscServ = versionHandler+ :<|> secureHandler+ :<|> hostHandler++ where versionHandler = return :: HttpVersion -> AppHandler HttpVersion+ secureHandler :: IsSecure -> AppHandler String+ secureHandler Secure = return "secure"+ secureHandler NotSecure = return "not secure"+ hostHandler = return . B8.unpack :: B8.ByteString -> AppHandler String++miscCombinatorSpec :: Spec+miscCombinatorSpec = do+ describe "Misc. combinators for request inspection" $ do+ it "Successfully gets the HTTP version specified in the request" $+ go "/version" (T.decodeUtf8 . BL.toStrict $+ A.encode ((1,1) :: HttpVersion))++ it "Checks that hspec-wai uses HTTP, not HTTPS" $+ go "/secure" "\"not secure\""++ it "Checks that hspec-wai issues request from 0.0.0.0" $+ go "/host" "localhost"++ where go path res = do+ runReqOnApi miscApi EmptyContext miscServ SC.GET path "" [] "" >>=+ (`shouldHaveBody` res)++-- }}}++type FFApi1 = "1" :> Get '[JSON] Int+p1 = Proxy :: Proxy FFApi1+ffServe1 = return 1+type FFApi2 = "2" :> Get '[JSON] Int+p2 = Proxy :: Proxy FFApi2+ffServe2 = return 2++fallthroughSpec :: Spec+fallthroughSpec = do+ describe "Allow multiple servant apis in the same snap router" $ do+ let rts = [("", serveSnap p1 ffServe1)+ ,("", serveSnap p2 ffServe2)+ ]+ sInit = makeSnaplet "servantsnap" "test" Nothing $ do+ addRoutes rts+ return App+ expectRoute r b =+ SST.runHandler Nothing (mkRequest GET r "" [] "") (route rts) sInit+ >>= b+ it "Successfully matches" $ expectRoute "1" (`shouldHaveBody` "1")+ it "Successfully falls through" $ expectRoute "2" (`shouldHaveBody` "2")+ it "404s when expected" $ expectRoute "3" (`shouldHaveStatus` 404)+++------------------------------------------------------------------------------+-- * BasicAuthCombinatorSpec {{{+------------------------------------------------------------------------------++type BasicAuthAPI = "secret" :> BasicAuth "realm" () :> Get '[JSON] Int++baApi :: Proxy BasicAuthAPI+baApi = Proxy++baServ :: Server BasicAuthAPI '[BasicAuthCheck AppHandler ()] AppHandler+baServ () = return 1337++basicAuthSpec :: Spec+basicAuthSpec = do+ let baCheck :: BasicAuthCheck AppHandler ()+ baCheck = BasicAuthCheck $ \_ -> return (Authorized ())++ getSecret :: () -> AppHandler Int+ getSecret () = return 1337++ 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++ it "returns 200 when logged in" $ do+ response <- runReqOnApi baApi (baCheck :. EmptyContext) getSecret SC.GET "/secret" ""+ [("Authorization", authHeader testLogin testPassword)] ""+ response `shouldHaveBody` "1337"++-- }}}+------------------------------------------------------------------------------+-- * Test data types {{{+------------------------------------------------------------------------------++data Person = Person {+ name :: String,+ age :: Integer+ }+ deriving (Eq, Show, Generic)++instance ToJSON Person+instance FromJSON Person++alice :: Person+alice = Person "Alice" 42++data Animal = Animal {+ species :: String,+ numberOfLegs :: Integer+ }+ deriving (Eq, Show, Generic)++instance ToJSON Animal+instance FromJSON Animal++jerry :: Animal+jerry = Animal "Mouse" 4++tweety :: Animal+tweety = Animal "Bird" 2++beholder :: Animal+beholder = Animal "Beholder" 0+-- }}}+++------------------------------------------------------------------------------+-- * hspec-snap helpers+------------------------------------------------------------------------------++getStatus :: TestResponse -> Maybe Int+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++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++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++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)]
+ test/Servant/StreamingSpec.hs view
@@ -0,0 +1,158 @@+{-# 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+ }+-}
+ test/Servant/Utils/StaticFilesSpec.hs view
@@ -0,0 +1,70 @@+{-# 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"