Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
117 lines (93 sloc) 3.93 KB
{-# LANGUAGE ScopedTypeVariables #-}
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)
testGeneratedProject :: String -- ^ project name and directory
-> String -- ^ arguments to @snap init@
-> String -- ^ arguments to @cabal install@
-> Int -- ^ port to run http server on
-> IO () -- ^ action to run when the server goes up
-> IO ()
testGeneratedProject projName snapInitArgs cabalInstallArgs httpPort
testAction = bracket initialize cleanup (const testAction)
where
initialize = do
cwd <- getCurrentDirectory
let projectPath = cwd </> projName
flip onException (setCurrentDirectory cwd >>
removeDirectoryRecursive projectPath) $ do
makeWorkDirectory projectPath
putStrLn $ "Changing directory to "++projectPath
setCurrentDirectory projectPath
snapExe <- findSnap
systemOrDie $ snapExe ++ " init " ++ snapInitArgs
snapCoreSrc <- fromEnv "SNAP_CORE_SRC" "../../../snap-core"
snapServerSrc <- fromEnv "SNAP_SERVER_SRC" "../../../snap-server"
xmlhtmlSrc <- fromEnv "XMLHTML_SRC" "../../../xmlhtml"
heistSrc <- fromEnv "HEIST_SRC" "../../../heist"
let snapSrc = "../.."
forM_ [ "snap-core", "snap-server", "xmlhtml", "heist", "snap" ]
(pkgCleanUp sandbox)
forM_ [ snapCoreSrc, snapServerSrc, xmlhtmlSrc, heistSrc
, snapSrc] $ \s ->
systemOrDie $ "cabal-dev " ++ cabalDevArgs
++ " add-source " ++ s
systemOrDie $ "cabal-dev install " ++ args
let cmd = ("." </> "dist" </> "build" </> projName </> projName)
++ " -p " ++ show httpPort
putStrLn $ "Running \"" ++ cmd ++ "\""
pHandle <- runCommand cmd
waitABit
return (cwd, projectPath, pHandle)
fromEnv name def = do
r <- getEnv name `catch` \(_::SomeException) -> return ""
if r == "" then return def else return r
cleanup (cwd, projectPath, pHandle) = do
setCurrentDirectory cwd
terminateProcess pHandle
waitForProcess pHandle
removeDirectoryRecursive projectPath
waitABit = threadDelay $ 2*10^(6::Int)
sandbox = "../test-cabal-dev" </> projName
cabalDevArgs = "-s " ++ sandbox
pkgCleanUp d pkg = do
paths <- globDir1 (compile $ "packages*conf/" ++ pkg ++ "-*") d
forM_ paths
(\x -> (rm x `catch` \(_::SomeException) -> return ()))
where
rm x = do
putStrLn $ "removing " ++ x
removeFile x
args = cabalDevArgs ++ " " ++ cabalInstallArgs
gimmeIfExists p = do
b <- doesFileExist p
if b then return (Just p) else return Nothing
findSnap = do
home <- fromEnv "HOME" "."
p1 <- gimmeIfExists "../../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])
systemOrDie :: String -> IO ()
systemOrDie s = do
putStrLn $ "Running \"" ++ s ++ "\""
system s >>= check
where
check ExitSuccess = return ()
check _ = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'"
makeWorkDirectory :: FilePath -> IO ()
makeWorkDirectory p = do
doesDirectoryExist p >>= flip when (removeDirectoryRecursive p)
createDirectory p
Jump to Line
Something went wrong with that request. Please try again.