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