Code cleanup, fix a race condition in the tests

test/suite/Blackbox/App.hs

@@ -77,7 +77,7 @@ app = makeSnaplet "app" "Test application" Nothing $ do
     hs <- nestSnaplet "heist" heist $ heistInit "templates"
     fs <- nestSnaplet "foo" foo fooInit
     bs <- nestSnaplet "" bar $ nameSnaplet "baz" $ barInit foo
-    sm <- nestSnaplet "session" session $ 
+    sm <- nestSnaplet "session" session $
           initCookieSessionManager "sitekey.txt" "_session" (Just (30 * 60))
     ns <- embedSnaplet "embed" embedded embeddedInit
     addSplices

test/suite/Blackbox/Tests.hs

@@ -1,41 +1,72 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Blackbox.Tests
   ( tests
   , remove
   , removeDir
   ) where
 
+------------------------------------------------------------------------------
+import           Control.Exception              (catch, throwIO)
 import           Control.Monad
 import           Control.Monad.Trans
-import           Data.Text.Lazy (Text)
-import qualified Data.Text.Lazy.Encoding as T
-import qualified Network.HTTP.Enumerator as HTTP
+import           Data.Text.Lazy                 (Text)
+import qualified Data.Text.Lazy.Encoding        as T
+import qualified Network.HTTP.Enumerator        as HTTP
+import           Prelude                        hiding (catch)
 import           System.Directory
 import           System.FilePath
-import           Test.Framework (Test, testGroup)
+import           Test.Framework                 (Test, testGroup)
 import           Test.Framework.Providers.HUnit
-import           Test.HUnit hiding (Test, path)
+import           Test.HUnit                     hiding (Test, path)
 
 ------------------------------------------------------------------------------
 requestTest :: String -> Text -> Test
 requestTest url desired = testCase ("/"++url) $ requestTest' url desired
 
+
+------------------------------------------------------------------------------
+expect404 :: IO a -> IO ()
+expect404 m = action `catch` h
+  where
+    action = m >> assertFailure "expected 404"
+
+    h e@(HTTP.StatusCodeException c _) | c == 404  = return ()
+                                       | otherwise = throwIO e
+    h e                                            = throwIO e
+
+
+------------------------------------------------------------------------------
+request404Test :: String -> Test
+request404Test url = testCase ("/" ++ url) $
+                     expect404             $
+                     HTTP.simpleHttp       $
+                     "http://127.0.0.1:9753/" ++ url
+
+
+------------------------------------------------------------------------------
 requestTest' :: String -> Text -> IO ()
 requestTest' url desired = do
     actual <- HTTP.simpleHttp $ "http://127.0.0.1:9753/" ++ url
     assertEqual url desired (T.decodeUtf8 actual)
 
+
+------------------------------------------------------------------------------
 requestNoError :: String -> Text -> Test
 requestNoError url desired = testCase ("/"++url) $ requestNoError' url desired
 
+
+------------------------------------------------------------------------------
 requestNoError' :: String -> Text -> IO ()
 requestNoError' url desired = do
     let fullUrl = "http://127.0.0.1:9753/" ++ url
     url' <- HTTP.parseUrl fullUrl
     HTTP.Response _ _ b <- liftIO $ HTTP.withManager $ HTTP.httpLbsRedirect url'
     assertEqual fullUrl desired (T.decodeUtf8 b)
 
+
+------------------------------------------------------------------------------
 tests :: Test
 tests = testGroup "non-cabal-tests"
     [ requestTest "hello" "hello world"
@@ -63,7 +94,7 @@ tests = testGroup "non-cabal-tests"
     , 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. 
+    -- get... functions from MonadSnaplet.
     , requestTest "foo/handlerConfig" "([\"app\"],\"snaplets/foosnaplet\",Just \"foosnaplet\",\"A demonstration snaplet called foo.\",\"foo\")"
     , requestTest "bar/handlerConfig" "([\"app\"],\"snaplets/baz\",Just \"baz\",\"An example snaplet called bar.\",\"\")"
 

test/suite/SafeCWD.hs

@@ -1,6 +1,6 @@
 module SafeCWD
   ( inDir
-  , removeDirectoryRecursiveSafe 
+  , removeDirectoryRecursiveSafe
   ) where
 
 import Control.Concurrent.QSem
@@ -25,6 +25,6 @@ inDir startClean dir action = bracket before after (const action)
     after cwd = do
         setCurrentDirectory cwd
         signalQSem sem
-    
+
 removeDirectoryRecursiveSafe p =
     doesDirectoryExist p >>= flip when (removeDirectoryRecursive p)

test/suite/Snap/TestCommon.hs

@@ -2,23 +2,38 @@
 
 module Snap.TestCommon where
 
-import Control.Concurrent
-import Control.Exception
-import Control.Monad (forM_, when)
-import Data.Maybe
-import Data.Monoid
-import Prelude hiding (catch)
-import System.Cmd
-import System.Directory
-import System.Environment
-import System.Exit
-import System.FilePath
-import System.FilePath.Glob
-import System.Process hiding (cwd)
-
+------------------------------------------------------------------------------
+import Control.Concurrent   ( threadDelay                )
+import Control.Exception    ( ErrorCall(..)
+                            , SomeException
+                            , bracket
+                            , catch
+                            , throwIO
+                            )
+import Control.Monad        ( forM_                      )
+import Data.Maybe           ( fromMaybe                  )
+import Data.Monoid          ( First(..), mconcat         )
+import Prelude       hiding ( catch                      )
+import System.Cmd           ( system                     )
+import System.Directory     ( doesFileExist
+                            , getCurrentDirectory
+                            , findExecutable
+                            , removeFile
+                            )
+import System.Environment   ( getEnv                     )
+import System.Exit          ( ExitCode(..)               )
+import System.FilePath      ( joinPath, splitPath, (</>) )
+import System.FilePath.Glob ( compile, globDir1          )
+import System.Process       ( runCommand
+                            , terminateProcess
+                            , waitForProcess
+                            )
+
+------------------------------------------------------------------------------
 import SafeCWD
 
 
+------------------------------------------------------------------------------
 testGeneratedProject :: String  -- ^ project name and directory
                      -> String  -- ^ arguments to @snap init@
                      -> String  -- ^ arguments to @cabal install@
@@ -28,23 +43,25 @@ testGeneratedProject :: String  -- ^ project name and directory
 testGeneratedProject projName snapInitArgs cabalInstallArgs httpPort
                      testAction = do
     cwd <- getCurrentDirectory
-    let segments = reverse $ splitPath cwd
-        projectPath = cwd </> "test-snap-exe" </> projName
-        snapRoot = joinPath $ reverse $ drop 1 segments
-        snapRepos = joinPath $ reverse $ drop 2 segments
-
-        sandbox = cwd </> "test-cabal-dev"
 
+    --------------------------------------------------------------------------
+    let segments     = reverse $ splitPath cwd
+        projectPath  = cwd </> "test-snap-exe" </> projName
+        snapRoot     = joinPath $ reverse $ drop 1 segments
+        snapRepos    = joinPath $ reverse $ drop 2 segments
+        sandbox      = cwd </> "test-cabal-dev"
         cabalDevArgs = "-s " ++ sandbox
+        args         = cabalDevArgs ++ " " ++ cabalInstallArgs
 
-        args = cabalDevArgs ++ " " ++ cabalInstallArgs 
-
+        ----------------------------------------------------------------------
         initialize = do
             snapExe <- findSnap
             systemOrDie $ snapExe ++ " init " ++ snapInitArgs
 
-            snapCoreSrc   <- fromEnv "SNAP_CORE_SRC" $ snapRepos </> "snap-core"
-            snapServerSrc <- fromEnv "SNAP_SERVER_SRC" $ snapRepos </> "snap-server"
+            snapCoreSrc   <- fromEnv "SNAP_CORE_SRC" $
+                             snapRepos </> "snap-core"
+            snapServerSrc <- fromEnv "SNAP_SERVER_SRC" $
+                             snapRepos </> "snap-server"
             xmlhtmlSrc    <- fromEnv "XMLHTML_SRC" $ snapRepos </> "xmlhtml"
             heistSrc      <- fromEnv "HEIST_SRC" $ snapRepos </> "heist"
             let snapSrc   =  snapRoot
@@ -54,8 +71,11 @@ testGeneratedProject projName snapInitArgs cabalInstallArgs httpPort
 
             forM_ [ snapCoreSrc, snapServerSrc, xmlhtmlSrc, heistSrc
                   , snapSrc] $ \s ->
-                systemOrDie $ "cabal-dev " ++ cabalDevArgs
-                                ++ " add-source " ++ s
+                systemOrDie $ concat [ "cabal-dev "
+                                     , cabalDevArgs
+                                     , " add-source "
+                                     , s
+                                     ]
 
             systemOrDie $ "cabal-dev install " ++ args
             let cmd = ("." </> "dist" </> "build" </> projName </> projName)
@@ -65,48 +85,59 @@ testGeneratedProject projName snapInitArgs cabalInstallArgs httpPort
             waitABit
             return pHandle
 
+        ----------------------------------------------------------------------
         findSnap = do
             home <- fromEnv "HOME" "."
-            p1 <- gimmeIfExists $ snapRoot </> "dist" </> "build" </> "snap" </> "snap"
-            p2 <- gimmeIfExists $ home </> ".cabal" </> "bin" </> "snap"
-            p3 <- findExecutable "snap"
+            p1   <- gimmeIfExists $ snapRoot </> "dist" </> "build"
+                                             </> "snap" </> "snap"
+            p2   <- gimmeIfExists $ home </> ".cabal" </> "bin" </> "snap"
+            p3   <- findExecutable "snap"
 
             return $ fromMaybe (error "couldn't find snap executable")
                                (getFirst $ mconcat $ map First [p1,p2,p3])
 
-    putStrLn $ "Changing directory to "++projectPath
+    --------------------------------------------------------------------------
+    putStrLn $ "Changing directory to " ++ projectPath
     inDir True projectPath $ bracket initialize cleanup (const testAction)
     removeDirectoryRecursiveSafe projectPath
-  where
 
+  where
+    --------------------------------------------------------------------------
     fromEnv name def = do
         r <- getEnv name `catch` \(_::SomeException) -> return ""
         if r == "" then return def else return r
 
+    --------------------------------------------------------------------------
     cleanup pHandle = do
         terminateProcess pHandle
         waitForProcess pHandle
 
+    --------------------------------------------------------------------------
     waitABit = threadDelay $ 2*10^(6::Int)
 
+    --------------------------------------------------------------------------
     pkgCleanUp d pkg = do
         paths <- globDir1 (compile $ "packages*conf/" ++ pkg ++ "-*") d
-        forM_ paths
-              (\x -> (rm x `catch` \(_::SomeException) -> return ()))
+        forM_ paths $ \x ->
+            rm x `catch` \(_::SomeException) -> return ()
+
       where
         rm x = do
             putStrLn $ "removing " ++ x
             removeFile x
 
+    --------------------------------------------------------------------------
     gimmeIfExists p = do
         b <- doesFileExist p
         if b then return (Just p) else return Nothing
 
 
+------------------------------------------------------------------------------
 systemOrDie :: String -> IO ()
 systemOrDie s = do
     putStrLn $ "Running \"" ++ s ++ "\""
     system s >>= check
+
   where
     check ExitSuccess = return ()
-    check _ = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'"
+    check _           = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'"