{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Application(test) where import Test.Tasty(TestTree, testGroup) import Test.Tasty.HUnit(testCase) import Control.Monad(when) import Control.Monad.Identity(Identity(..)) import Web.Apiary import Control.Monad.Apiary.Action import Network.Wai(Request) import qualified Network.Wai.Test as WT import qualified Network.Wai as Wai import qualified Network.HTTP.Types as HTTP import System.Directory (removeFile) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S import Data.Word (Word64) import qualified Data.Aeson as JSON import qualified Data.Aeson.TH as JSON testReq :: String -> (Request -> IO ()) -> TestTree testReq str f = let (meth, other) = break (== ' ') str (p, version) = break (== ' ') (tail other) in testCase str $ f (WT.setPath (setVersion version $ (WT.defaultRequest { Wai.requestMethod = S.pack meth })) (S.pack p)) where setVersion [] r = r setVersion v r | v == " HTTP/1.0" = r { Wai.httpVersion = HTTP.http10 } | v == " HTTP/0.9" = r { Wai.httpVersion = HTTP.http09 } | otherwise = r { Wai.httpVersion = HTTP.http11 } -------------------------------------------------------------------------------- assertSRequest :: Int -- ^ expected status code -> Maybe S.ByteString -- ^ expected content type -> L.ByteString -- ^ expected request body -> Application -> WT.SRequest -> IO () assertSRequest sc ct body app req = flip WT.runSession app $ do res <- WT.srequest req WT.assertBody body res WT.assertStatus sc res maybe (return ()) (flip WT.assertContentType res) ct assertRequest :: Int -- ^ expected status code -> Maybe S.ByteString -- ^ expected content type -> L.ByteString -- ^ expected request body -> Application -> Request -> IO () assertRequest sc ct body app req = assertSRequest sc ct body app (WT.SRequest req "") assertPlain200 :: L.ByteString -> Application -> Request -> IO () assertPlain200 = assertRequest 200 (Just "text/plain") assertHtml200 :: L.ByteString -> Application -> Request -> IO () assertHtml200 = assertRequest 200 (Just "text/html") assertJson200 :: L.ByteString -> Application -> Request -> IO () assertJson200 = assertRequest 200 (Just "application/json") assert404 :: Application -> Request -> IO () assert404 = assertRequest 404 (Just "text/plain") "404 Page Notfound.\n" -------------------------------------------------------------------------------- runApp :: ApiaryT '[] '[] IO Identity () -> Application runApp = runIdentity . runApiary return def -------------------------------------------------------------------------------- helloWorldApp :: Application helloWorldApp = runApp $ action $ do contentType "text/plain" bytes "hello" helloWorldAllTest :: TestTree helloWorldAllTest = testGroup "helloWorld" $ map ($ helloWorldApp) [ testReq "GET /" . assertPlain200 "hello" , testReq "GET /foo" . assert404 , testReq "POST /" . assertPlain200 "hello" ] -------------------------------------------------------------------------------- methodFilterApp :: Application methodFilterApp = runApp $ do method "GET" . action $ contentType "text/plain" >> bytes "GET" method POST . action $ contentType "text/plain" >> bytes "POST" methodFilterTest :: TestTree methodFilterTest = testGroup "methodFilter" $ map ($ methodFilterApp) [ testReq "GET /" . assertPlain200 "GET" , testReq "POST /" . assertPlain200 "POST" , testReq "GET /foo" . assert404 , testReq "DELETE /" . assert404 ] -------------------------------------------------------------------------------- httpVersionApp :: Application httpVersionApp = runApp $ do http09 . action $ contentType "text/plain" >> bytes "09" http10 . action $ contentType "text/plain" >> bytes "10" http11 . action $ contentType "text/plain" >> bytes "11" httpVersionTest :: TestTree httpVersionTest = testGroup "httpVersionFilter" $ map ($ httpVersionApp) [ testReq "GET / HTTP/0.9" . assertPlain200 "09" , testReq "GET / HTTP/1.0" . assertPlain200 "10" , testReq "GET / HTTP/1.1" . assertPlain200 "11" ] -------------------------------------------------------------------------------- rootFilterApp :: Application rootFilterApp = runApp . root . action $ do contentType "text/html" bytes "root" rootFilterTest :: TestTree rootFilterTest = testGroup "rootFilter" $ map ($ rootFilterApp) [ testReq "GET /" . assertHtml200 "root" , testReq "POST /" . assertHtml200 "root" , testReq "GET /neko" . assert404 , testReq "GET /index.html" . assertHtml200 "root" ] -------------------------------------------------------------------------------- restFilterApp :: Application restFilterApp = runApp $ do [capture|/test/**rest|] . action $ contentType "text/plain" >> param [key|rest|] >>= showing [capture|/test/neko|] . action $ contentType "text/plain" >> bytes "nyan" restFilterTest :: TestTree restFilterTest = testGroup "rest capture" $ map ($ restFilterApp) [ testReq "GET /" . assert404 , testReq "GET /test" . assertPlain200 "[]" , testReq "GET /test/foo" . assertPlain200 "[\"foo\"]" , testReq "GET /test/foo/bar" . assertPlain200 "[\"foo\",\"bar\"]" , testReq "GET /test/neko" . assertPlain200 "nyan" ] -------------------------------------------------------------------------------- captureApp :: Application captureApp = runApp $ do [capture|/foo|] . action $ contentType "text/plain" >> bytes "foo" [capture|/int::Int|] . method GET . action $ contentType "text/plain" >> bytes "Int " >> param [key|int|] >>= appendShowing [capture|/d::Double|] . action $ contentType "text/plain" >> bytes "Double " >> param [key|d|] >>= appendShowing [capture|/bar/s::L.ByteString/i::Int|] . action $ contentType "text/plain" >> param [key|s|] >>= lazyBytes >> appendChar ' ' >> param [key|i|] >>= appendShowing [capture|/s::L.ByteString|] . action $ contentType "text/plain" >> bytes "fall " >> param [key|s|] >>= appendLazyBytes captureTest :: TestTree captureTest = testGroup "capture" $ map ($ captureApp) [ testReq "GET /foo" . assertPlain200 "foo" , testReq "GET /12" . assertPlain200 "Int 12" , testReq "GET /12.4" . assertPlain200 "Double 12.4" , testReq "POST /12" . assertPlain200 "Double 12.0" , testReq "GET /bar" . assertPlain200 "fall bar" , testReq "GET /baz" . assertPlain200 "fall baz" , testReq "GET /bar/nyan/12" . assertPlain200 "nyan 12" , testReq "GET /bar/nyan/12/other" . assert404 ] -------------------------------------------------------------------------------- queryApp f g h = runApp $ do _ <- (f [key|foo|] pInt) . action $ contentType "text/plain" >> bytes "foo Int " >> param [key|foo|] >>= appendShowing _ <- (g [key|foo|] pString) . action $ contentType "text/plain" >> bytes "foo String " >> param [key|foo|] >>= appendShowing (h [key|foo|] (pMaybe pString)) . action $ contentType "text/plain" >> bytes "foo Maybe String " >> param [key|foo|] >>= appendShowing queryOptionalApp :: Application queryOptionalApp = runApp $ do ([key|foo|] =?!: (5 :: Int)) . action $ contentType "text/plain" >> bytes "foo Int " >> param [key|foo|] >>= appendShowing ([key|foo|] =?!: ("bar" :: String)) . action $ contentType "text/plain" >> bytes "foo String " >> param [key|foo|] >>= appendShowing ([key|foo|] =?!: (Just "baz" :: Maybe String)) . action $ contentType "text/plain" >> bytes "foo Maybe String " >> param [key|foo|] >>= appendShowing queryFirstTest :: TestTree queryFirstTest = testGroup "First" $ map ($ queryApp (=:) (=:) (=:)) [ testReq "GET /" . assert404 , testReq "GET /?foo" . assertPlain200 "foo Maybe String Nothing" , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String Nothing" , testReq "GET /?foo=12" . assertPlain200 "foo Int 12" , testReq "GET /?foo=a" . assertPlain200 "foo String \"a\"" , testReq "GET /?foo=12&foo=23" . assertPlain200 "foo Int 12" , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo Int 12" ] queryOneTest :: TestTree queryOneTest = testGroup "One" $ map ($ queryApp (=!:) (=!:) (=!:)) [ testReq "GET /" . assert404 , testReq "GET /?foo" . assertPlain200 "foo Maybe String Nothing" , testReq "GET /?foo&foo=3" . assert404 , testReq "GET /?foo=12" . assertPlain200 "foo Int 12" , testReq "GET /?foo=a" . assertPlain200 "foo String \"a\"" , testReq "GET /?foo=12&foo=23" . assert404 , testReq "GET /?foo=12&foo=b" . assert404 ] queryOptionTest :: TestTree queryOptionTest = testGroup "Option" $ map ($ queryApp (=?:) (=?:) (=?:)) [ testReq "GET /" . assertPlain200 "foo Int Nothing" , testReq "GET /?foo" . assertPlain200 "foo Maybe String Just Nothing" , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String Just Nothing" , testReq "GET /?foo=12" . assertPlain200 "foo Int Just 12" , testReq "GET /?foo=a" . assertPlain200 "foo String Just \"a\"" , testReq "GET /?foo=12&foo=23" . assertPlain200 "foo Int Just 12" , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo Int Just 12" ] queryOptionalTest :: TestTree queryOptionalTest = testGroup "Optional" $ map ($ queryOptionalApp) [ testReq "GET /" . assertPlain200 "foo Int 5" , testReq "GET /?foo" . assertPlain200 "foo Maybe String Nothing" , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String Nothing" , testReq "GET /?foo=12" . assertPlain200 "foo Int 12" , testReq "GET /?foo=a" . assertPlain200 "foo String \"a\"" , testReq "GET /?foo=12&foo=23" . assertPlain200 "foo Int 12" , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo Int 12" ] queryManyTest :: TestTree queryManyTest = testGroup "Many" $ map ($ queryApp (=*:) (=*:) (=*:)) [ testReq "GET /" . assertPlain200 "foo Int []" , testReq "GET /?foo" . assertPlain200 "foo Maybe String [Nothing]" , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String [Nothing,Just \"3\"]" , testReq "GET /?foo=12" . assertPlain200 "foo Int [12]" , testReq "GET /?foo=a" . assertPlain200 "foo String [\"a\"]" , testReq "GET /?foo=12&foo=23" . assertPlain200 "foo Int [12,23]" , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo String [\"12\",\"b\"]" ] querySomeTest :: TestTree querySomeTest = testGroup "Some" $ map ($ queryApp (=+:) (=+:) (=+:)) [ testReq "GET /" . assert404 , testReq "GET /?foo" . assertPlain200 "foo Maybe String [Nothing]" , testReq "GET /?foo&foo=3" . assertPlain200 "foo Maybe String [Nothing,Just \"3\"]" , testReq "GET /?foo=12" . assertPlain200 "foo Int [12]" , testReq "GET /?foo=a" . assertPlain200 "foo String [\"a\"]" , testReq "GET /?foo=12&foo=23" . assertPlain200 "foo Int [12,23]" , testReq "GET /?foo=12&foo=b" . assertPlain200 "foo String [\"12\",\"b\"]" ] switchQueryApp :: Application switchQueryApp = runApp $ do switchQuery [key|foo|] . switchQuery [key|bar|] . action $ do contentType "text/plain" param [key|foo|] >>= showing param [key|bar|] >>= appendShowing switchQueryTest :: TestTree switchQueryTest = testGroup "switch" $ map ($ switchQueryApp) [ testReq "GET /" . assertPlain200 "FalseFalse" , testReq "GET /?foo" . assertPlain200 "TrueFalse" , testReq "GET /?foo&bar" . assertPlain200 "TrueTrue" , testReq "GET /?foo=true" . assertPlain200 "TrueFalse" , testReq "GET /?foo=false" . assertPlain200 "FalseFalse" , testReq "GET /?foo=false&bar=true" . assertPlain200 "FalseTrue" , testReq "GET /?foo&bar=true" . assertPlain200 "TrueTrue" , testReq "GET /?foo=1&bar=0" . assertPlain200 "TrueFalse" ] queryTest :: TestTree queryTest = testGroup "query" [ queryFirstTest , queryOneTest , queryOptionTest , queryOptionalTest , queryManyTest , querySomeTest , switchQueryTest ] -------------------------------------------------------------------------------- stopApp :: Application stopApp = runApp $ do [capture|/a/i::Int|] . action $ do i <- param [key|i|] contentType "text/plain" when (i == 1) $ bytes "one\n" if i `mod` 2 == 0 then appendBytes "even\n" else appendBytes "odd\n" when (i == 2) stop appendBytes "after stop" stopTest :: TestTree stopTest = testGroup "stop" $ map ($ stopApp) [ testReq "GET /a/0" . assertPlain200 "even\nafter stop" , testReq "GET /a/1" . assertPlain200 "one\nodd\nafter stop" , testReq "GET /a/2" . assertPlain200 "even\n" , testReq "GET /a/3" . assertPlain200 "odd\nafter stop" ] -------------------------------------------------------------------------------- acceptApp :: Application acceptApp = runApp $ [capture|/|] $ do accept "application/json" . action $ bytes "json" accept "text/html;prm=t" . action $ bytes "html+prm" accept "text/html" . action $ bytes "html" action $ bytes "other" acceptTest :: TestTree acceptTest = testGroup "accept" $ map ($ acceptApp) [ testReq "GET / application/json" . (\a r -> assertJson200 "json" a $ addA "application/json" r) , testReq "GET / text/html" . (\a r -> assertHtml200 "html" a $ addA "text/html" r) , testReq "GET / text/html;p=a" . (\a r -> assertHtml200 "html" a $ addA "text/html;p=a" r) , testReq "GET / text/html;prm=t" . (\a r -> assertHtml200 "html+prm" a $ addA "text/html;prm=t" r) , testReq "GET / text/plain" . (\a r -> assertRequest 200 Nothing "other" a $ addA "text/plain" r) , testReq "GET / text/*" . (\a r -> assertHtml200 "html" a $ addA "text/*" r) , testReq "GET / text/*;p=a" . (\a r -> assertHtml200 "html" a $ addA "text/*;p=a" r) , testReq "GET / */*" . (\a r -> assertJson200 "json" a $ addA "*/*" r) , testReq "GET /" . assertRequest 200 Nothing "other" ] where addA :: S.ByteString -> Request -> Request addA ct r = r {Wai.requestHeaders = ("Accept", ct) : filter (("Accept" ==) . fst) (Wai.requestHeaders r)} -------------------------------------------------------------------------------- multipleFilter1App :: Application multipleFilter1App = runApp $ do root $ do method GET . action $ contentType "text/plain" >> bytes "GET /" method POST . action $ contentType "text/html" >> bytes "POST /" method DELETE . action $ contentType "text/plain" >> bytes "DELETE ANY" multipleFilter1Test :: TestTree multipleFilter1Test = testGroup "multiple test1: root, method" [ testReq "GET /index.html" $ assertPlain200 "GET /" multipleFilter1App , testReq "POST /" $ assertHtml200 "POST /" multipleFilter1App , testReq "DELETE /" $ assertPlain200 "DELETE ANY" multipleFilter1App , testReq "PUT /" $ assert404 multipleFilter1App ] -------------------------------------------------------------------------------- -- https://github.com/philopon/apiary/issues/17 issue17App :: Application issue17App = runApp $ do root $ do method GET . ([key|foo|] =: pInt) . action $ do foo <- param [key|foo|] showing foo method POST . action $ do ps <- getReqBodyParams showing ps issue17Test :: TestTree issue17Test = testGroup "issue17" $ map ($ issue17App) [ testReq "GET /" . assert404 , testReq "GET /?foo=test" . assert404 , testReq "GET /?foo=12" . assertPlain200 "12" , \app -> testReq "POST /" $ \req -> assertSRequest 200 Nothing "[(\"foo\",\"12\")]" app (WT.SRequest req { Wai.requestHeaders = ("Content-Type", "application/x-www-form-urlencoded") : Wai.requestHeaders req} "foo=12") ] -------------------------------------------------------------------------------- limit :: Word64 limit = 1024 largeReq :: WT.SRequest largeReq = WT.SRequest Wai.defaultRequest { Wai.requestBodyLength = Wai.KnownLength (limit + 1) , Wai.requestMethod = HTTP.methodPut } "some request body" largeReq' :: WT.SRequest largeReq' = WT.SRequest Wai.defaultRequest { Wai.requestBodyLength = Wai.ChunkedBody , Wai.requestMethod = HTTP.methodPost } (L.replicate (fromIntegral (limit + 1)) 'a') assertLargeReq413 :: Application -> WT.SRequest -> IO () assertLargeReq413 app req = flip WT.runSession app $ do respond <- WT.srequest req WT.assertStatus 413 respond tooLargeReqTestApp :: Application tooLargeReqTestApp = runIdentity . runApiary return (def {maxRequestSize = limit}) $ do root $ do method PUT . action $ do b <- getReqBody b `seq` bytes "Test" method POST . action $ do b <- getReqBody b `seq` bytes "Test" tooLargeReqTest :: TestTree tooLargeReqTest = testGroup "large request body" [ testCase "Large request" $ assertLargeReq413 tooLargeReqTestApp largeReq , testCase "Large request" $ assertLargeReq413 tooLargeReqTestApp largeReq' ] -------------------------------------------------------------------------------- dalvikRequest :: IO WT.SRequest dalvikRequest = do bs <- L.readFile "./tests/dalvik-request" return $ WT.SRequest Wai.defaultRequest { Wai.requestBodyLength = Wai.ChunkedBody , Wai.requestMethod = HTTP.methodPost , Wai.requestHeaders = [("Content-Type", "multipart/form-data; boundary=*****")] } bs multiPartTestApp :: Application multiPartTestApp = runIdentity . runApiary return def $ do root $ do method POST . action $ do p <- getReqBodyParams f <- getReqBodyFiles guard (not . null $ p) guard (not . null $ f) case fileContent (head f) of Left lbs -> bytes "lbs file" multiPartTestApp' :: Application multiPartTestApp' = runIdentity . runApiary return (def {uploadFilePath = Just "./"}) $ do root $ do method POST . action $ do p <- getReqBodyParams f <- getReqBodyFiles guard (not . null $ p) guard (not . null $ f) case fileContent (head f) of Right path -> do liftIO $ removeFile path bytes "disk file" multiPartTest :: TestTree multiPartTest = testGroup "multipart request body" [ testCase "multipart test" $ assertSRequest 200 Nothing "lbs file" multiPartTestApp =<< dalvikRequest , testCase "multipart test" $ assertSRequest 200 Nothing "disk file" multiPartTestApp' =<< dalvikRequest ] -------------------------------------------------------------------------------- data Foo = Foo {foo :: Int} deriving Show $(JSON.deriveJSON JSON.defaultOptions ''Foo) jsonRequest :: WT.SRequest jsonRequest = WT.SRequest Wai.defaultRequest { Wai.requestMethod = HTTP.methodPost } "{\"foo\": 123}" jsonReqTestApp :: Application jsonReqTestApp = runIdentity . runApiary return (def {uploadFilePath = Just "./"}) $ do root $ do method POST . (jsonReqBody [key|foo|]) . action $ do f <- param [key|foo|] showing $ foo f jsonReqTestApp' :: Application jsonReqTestApp' = runIdentity . runApiary return (def {uploadFilePath = Just "./"}) $ do root $ do method POST . (jsonReqBody [key|foo|]) . action $ do f <- param [key|foo|] showing $ (f :: Int) jsonReqBodyTest :: TestTree jsonReqBodyTest = testGroup "json request body filter" [ testCase "json request body test" $ assertSRequest 200 Nothing "123" jsonReqTestApp jsonRequest , testCase "json request body test" $ assertSRequest 404 (Just "text/plain") "404 Page Notfound.\n" jsonReqTestApp' jsonRequest ] -------------------------------------------------------------------------------- test :: TestTree test = testGroup "Application" [ helloWorldAllTest , methodFilterTest , httpVersionTest , rootFilterTest , restFilterTest , captureTest , queryTest , stopTest , acceptTest , multipleFilter1Test , issue17Test , tooLargeReqTest , multiPartTest , jsonReqBodyTest ]