Tests.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Blackbox.Tests
  ( tests
  , remove
  , removeDir
  ) where

------------------------------------------------------------------------------
import           Control.Exception              (catch, finally, throwIO)
import           Control.Monad
import           Control.Monad.Trans
import qualified Data.ByteString.Char8          as S
import qualified Data.ByteString.Lazy.Char8     as L
import           Data.Monoid
import           Data.Text.Lazy                 (Text)
import qualified Data.Text.Lazy                 as T
import qualified Data.Text.Lazy.Encoding        as T
import           Network.Http.Client
import           Prelude                        hiding (catch)
import           System.Directory
import           System.FilePath
import           Test.Framework                 (Test, testGroup)
import           Test.Framework.Providers.HUnit
import           Test.HUnit                     hiding (Test, path)
------------------------------------------------------------------------------


------------------------------------------------------------------------------
testServer :: String
testServer = "http://127.0.0.1"


------------------------------------------------------------------------------
testPort :: String
testPort = "9753"


------------------------------------------------------------------------------
-- | The server uri, without the leading slash.
testServerUri :: String
testServerUri = testServer ++ ":" ++ testPort


------------------------------------------------------------------------------
-- | The server url, with the leading slash.
testServerUrl :: String
testServerUrl = testServerUri ++ "/"


                            --------------------
                            --  TEST LOADER   --
                            --------------------

------------------------------------------------------------------------------
tests :: Test
tests = testGroup "non-cabal-tests"
    [ requestTest "hello" "hello world"
    , requestTest "index" "index page\n"
    , requestTest "" "index page\n"
    , requestTest "splicepage" "splice page contents of the app splice\n"
    , requestTest "routeWithSplice" "routeWithSplice: foo snaplet data stringz"
    , requestTest "routeWithConfig" "routeWithConfig: topConfigValue"
    , requestTest "foo/foopage" "foo template page\n"
    , requestTest "foo/fooConfig" "fooValue"
    , requestTest "foo/fooRootUrl" "foo"
    , requestTest "barconfig" "barValue"
    , requestTest "bazpage" "baz template page <barsplice></barsplice>\n"
    , requestTest "bazpage2" "baz template page contents of the bar splice\n"
    , requestTest "bazpage3" "baz template page <barsplice></barsplice>\n"
    , requestTest "bazpage4" "baz template page <barsplice></barsplice>\n"
    , requestTest "barrooturl" "url"
    , requestExpectingErrorPrefix "bazbadpage" 500 "A web handler threw an exception. Details:\nTemplate \"cpyga\" not found."
    , requestTest "foo/fooSnapletName" "foosnaplet"

    , fooConfigPathTest

    -- Test the embedded snaplet
    , requestTest "embed/heist/embeddedpage" "embedded snaplet page <asplice></asplice>\n"
    , requestTest "embed/aoeuhtns" "embedded snaplet page splice value42\n"
    , requestTest "embed/heist/onemoredir/extra" "This is an extra template\n"

    -- This set of tests highlights the differences in the behavior of the
    -- get... functions from MonadSnaplet.
    , fooHandlerConfigTest
    , barHandlerConfigTest
    , bazpage5Test
    , bazConfigTest
    , requestTest "sessionDemo" "[(\"foo\",\"bar\")]\n"
    , reloadTest
    ]


------------------------------------------------------------------------------
testName :: String -> String
testName uri = "internal/" ++ uri
--testName = id

------------------------------------------------------------------------------
requestTest :: String -> Text -> Test
requestTest url desired = testCase (testName url) $ requestTest' url desired


------------------------------------------------------------------------------
requestTest' :: String -> Text -> IO ()
requestTest' url desired = do
    actual <- get (S.pack $ testServerUrl ++ url) concatHandler
    assertEqual url desired (T.decodeUtf8 $ L.fromChunks [actual])


------------------------------------------------------------------------------
requestExpectingErrorPrefix :: String -> Int -> Text -> Test
requestExpectingErrorPrefix url status desired =
    testCase (testName url) $ requestExpectingErrorPrefix' url status desired


------------------------------------------------------------------------------
requestExpectingErrorPrefix' :: String -> Int -> Text -> IO ()
requestExpectingErrorPrefix' url status desired = do
    let fullUrl = testServerUrl ++ url
    get (S.pack fullUrl) $ \resp is -> do
      assertEqual ("Status code: "++fullUrl) status
                  (getStatusCode resp)
      res <- concatHandler resp is
      assertBool fullUrl $ desired `T.isPrefixOf` (T.decodeUtf8 $ L.fromChunks [res])


------------------------------------------------------------------------------
fooConfigPathTest :: Test
fooConfigPathTest = testCase (testName "foo/fooFilePath") $ do
    b <- liftM L.unpack $ grab "/foo/fooFilePath"
    assertRelativelyTheSame b "snaplets/foosnaplet"


------------------------------------------------------------------------------
assertRelativelyTheSame :: FilePath -> FilePath -> IO ()
assertRelativelyTheSame p expected = do
    b <- makeRelativeToCurrentDirectory p
    assertEqual ("expected " ++ expected) expected b


------------------------------------------------------------------------------
grab :: MonadIO m => String -> m L.ByteString
grab path = liftIO $ liftM (L.fromChunks . (:[])) $
  get (S.pack $ testServerUri ++ path) concatHandler


------------------------------------------------------------------------------
testWithCwd :: String
            -> (String -> L.ByteString -> Assertion)
            -> Test
testWithCwd uri f = testCase (testName uri) $
                    testWithCwd' uri f


------------------------------------------------------------------------------
testWithCwd' :: String
             -> (String -> L.ByteString -> Assertion)
             -> Assertion
testWithCwd' uri f = do
    b   <- grab slashUri
    cwd <- getCurrentDirectory

    f cwd b

  where
    slashUri = '/' : uri


------------------------------------------------------------------------------
fooHandlerConfigTest :: Test
fooHandlerConfigTest = testWithCwd "foo/handlerConfig" $ \cwd b -> do
    let response = L.fromChunks [ "([\"app\"],\""
                                , S.pack cwd
                                , "/snaplets/foosnaplet\","
                                , "Just \"foosnaplet\",\"A demonstration "
                                , "snaplet called foo.\",\"foo\")" ]
    assertEqual "" response b


------------------------------------------------------------------------------
barHandlerConfigTest :: Test
barHandlerConfigTest = testWithCwd "bar/handlerConfig" $ \cwd b -> do
    let response = L.fromChunks [ "([\"app\"],\""
                                , S.pack cwd
                                , "/snaplets/baz\","
                                , "Just \"baz\",\"An example snaplet called "
                                , "bar.\",\"\")" ]
    assertEqual "" response b


------------------------------------------------------------------------------
-- bazpage5 uses barsplice bound by renderWithSplices at request time
bazpage5Test :: Test
bazpage5Test = testWithCwd "bazpage5" $ \cwd b -> do
    let response = L.fromChunks [ "baz template page ([\"app\"],\""
                                , S.pack cwd
                                , "/snaplets/baz\","
                                , "Just \"baz\",\"An example snaplet called "
                                , "bar.\",\"\")\n" ]
    assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b)


------------------------------------------------------------------------------
-- bazconfig uses two splices, appconfig and fooconfig. appconfig is bound with
-- the non type class version of addSplices in the main app initializer.
-- fooconfig is bound by addSplices in fooInit.
bazConfigTest :: Test
bazConfigTest = testWithCwd "bazconfig" $ \cwd b -> do
    let response = L.fromChunks [
                     "baz config page ([],\""
                   , S.pack cwd
                   , "\",Just \"app\"," -- TODO, right?
                   , "\"Test application\",\"\") "
                   , "([\"app\"],\""
                   , S.pack cwd
                   , "/snaplets/foosnaplet\","
                   , "Just \"foosnaplet\",\"A demonstration snaplet "
                   , "called foo.\",\"foo\")\n"
                   ]

    assertEqual "" (T.decodeUtf8 response) (T.decodeUtf8 b)


------------------------------------------------------------------------------
expect404 :: String -> IO ()
expect404 url = do
    get (S.pack $ testServerUrl ++ url) $ \resp i -> do
        case getStatusCode resp of
          404 -> return ()
          _   -> assertFailure "expected 404"


------------------------------------------------------------------------------
request404Test :: String -> Test
request404Test url = testCase (testName url) $ expect404 url


remove :: FilePath -> IO ()
remove f = do
    exists <- doesFileExist f
    when exists $ removeFile f


removeDir :: FilePath -> IO ()
removeDir d = do
    exists <- doesDirectoryExist d
    when exists $ removeDirectoryRecursive "snaplets/foosnaplet"


------------------------------------------------------------------------------
reloadTest :: Test
reloadTest = testCase "internal/reload-test" $ do
    let goodTplOrig = "good.tpl"
    let badTplOrig  = "bad.tpl"
    let goodTplNew  = "snaplets"  </> "heist"
                      </> "templates" </> "good.tpl"
    let badTplNew   = "snaplets"  </> "heist"
                      </> "templates" </> "bad.tpl"

    goodExists <- doesFileExist goodTplNew
    badExists  <- doesFileExist badTplNew

    assertBool "good.tpl exists" (not goodExists)
    assertBool "bad.tpl exists"  (not badExists)
    expect404 "bad"

    copyFile badTplOrig badTplNew
    expect404 "good"
    expect404 "bad"

    flip finally (remove badTplNew) $
      testWithCwd' "admin/reload" $ \cwd' b -> do
        let cwd = T.pack cwd'

        let prefix = T.intercalate "\n"
              [ "Error reloading site!"
              , ""
              , "Initializer threw an exception..."
              , T.concat
                [ cwd, "/snaplets/heist/templates/bad.tpl \""
                , cwd, "/snaplets/heist/templates/bad.tpl\" (line 2, column 1):"
                ]
              , "unexpected end of input"
              , "expecting \"=\", \"/\" or \">\""

              -- Building with the latest dependency versions produces the following:
              -- "CallStack (from HasCallStack):"
              -- "  error, called at src/Snap/Snaplet/Heist/Internal.hs:75:35 in main:Snap.Snaplet.Heist.Internal"
              ]

        let suffix = T.intercalate "\n"
              [ "...but before it died it generated the following output:"
              , "Initializing app @ /"
              , "Initializing heist @ /heist"
              , ""
              , ""
              ]

        let response = T.decodeUtf8 b

        assertEqual "admin/reload" prefix (T.take    (T.length prefix) response)
        assertEqual "admin/reload" suffix (T.takeEnd (T.length suffix) response)

    copyFile goodTplOrig goodTplNew

    testWithCwd' "admin/reload" $ \cwd' b -> do  -- TODO/NOTE: Needs cleanup
        let cwd = S.pack cwd'
        let response = L.fromChunks [
              "Initializing app @ /\nInitializing heist @ ",
              "/heist\n...loaded 9 templates from ",
              cwd,
              "/snaplets/heist/templates\nInitializing CookieSession ",
              "@ /session\nInitializing foosnaplet @ /foo\n...adding 1 ",
              "templates from ",
              cwd,
              "/snaplets/foosnaplet/templates with route prefix ",
              "foo/\nInitializing baz @ /\n...adding 2 templates from ",
              cwd,
              "/snaplets/baz/templates with route prefix /\nInitializing ",
              "embedded @ /\nInitializing heist @ /heist\n...loaded ",
              "1 templates from ",
              cwd,
              "/snaplets/embedded/snaplets/heist/templates\n...adding ",
              "1 templates from ",
              cwd,
              "/snaplets/embedded/extra-templates with route prefix ",
              "onemoredir/\n...adding 0 templates from ",
              cwd,
              "/templates with route prefix extraTemplates/\n",
              "Initializing JsonFileAuthManager @ ",
              "/auth\nSite successfully reloaded.\n"
              ]

        assertEqual "admin/reload" response b

    requestTest' "good" "Good template\n"