apiary-2.0.0: tests/Application.hs

{-# 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
    ]