Commit c8a58047 authored by Michael Hanus 's avatar Michael Hanus

Setting of exit codes improved

parent 350b017e
......@@ -6,6 +6,8 @@ module CPM.ErrorLogger
( ErrorLogger
, LogEntry
, LogLevel (..)
, logLevelOf
, levelGte
, setLogLevel
, (|>=)
, (|>)
......@@ -30,6 +32,9 @@ type ErrorLogger a = ([LogEntry], Either LogEntry a)
--- A log entry.
data LogEntry = LogEntry LogLevel String
logLevelOf :: LogEntry -> LogLevel
logLevelOf (LogEntry ll _) = ll
--- A log level.
data LogLevel = Info
| Debug
......
......@@ -11,6 +11,7 @@ module CPM.FileUtil
, inTempDir
, inDirectory
, recreateDirectory
, removeDirectoryComplete
) where
import Directory ( doesFileExist, getCurrentDirectory, setCurrentDirectory
......@@ -104,7 +105,12 @@ inDirectory dir b = do
--- Recreates a directory. Deletes its contents if it already exists.
recreateDirectory :: String -> IO ()
recreateDirectory dir = do
exists <- doesDirectoryExist dir
when exists $ system ("rm -Rf " ++ quote dir) >> done
removeDirectoryComplete dir
createDirectoryIfMissing True dir
--- Deletes a directory and its contents, if it exists, otherwise nothing
--- is done.
removeDirectoryComplete :: String -> IO ()
removeDirectoryComplete dir = do
exists <- doesDirectoryExist dir
when exists $ system ("rm -Rf " ++ quote dir) >> done
......@@ -80,10 +80,10 @@ runWithArgs opts = do
then do
putStrLn "Problems while reading the package index:"
mapIO putStrLn repoErrors
return ()
exitWith 1
else return ()
setLogLevel $ optLogLevel opts
result <- case optCommand opts of
(msgs, result) <- case optCommand opts of
NoCommand -> failIO "NoCommand"
Deps -> deps config repo globalCache
PkgInfo o -> info o config repo globalCache
......@@ -100,8 +100,10 @@ runWithArgs opts = do
Upgrade o -> upgrade o config repo globalCache
Link o -> link o config repo globalCache
New -> newPackage
case result of
(msgs, _) -> mapIO showLogEntry msgs >> return ()
mapIO showLogEntry msgs
let allOk = all (levelGte Info) (map logLevelOf msgs) &&
either (\le -> levelGte Info (logLevelOf le)) (const True) result
exitWith (if allOk then 0 else 1)
data Options = Options
{ optLogLevel :: LogLevel
......@@ -458,13 +460,13 @@ checkout (CheckoutOptions pkg Nothing pre) cfg repo gc =
case findLatestVersion repo pkg pre of
Nothing -> failIO $ "Package '" ++ pkg ++
"' not found in package repository."
Just p -> acquireAndInstallPackageWithDependencies cfg repo gc p >>
Just p -> acquireAndInstallPackageWithDependencies cfg repo gc p |>
checkoutPackage cfg repo gc p
checkout (CheckoutOptions pkg (Just ver) _) cfg repo gc =
case findVersion repo pkg ver of
Nothing -> failIO $ "Package '" ++ pkg ++ "-" ++ showVersion ver ++
"' not found in package repository."
Just p -> acquireAndInstallPackageWithDependencies cfg repo gc p >>
Just p -> acquireAndInstallPackageWithDependencies cfg repo gc p |>
checkoutPackage cfg repo gc p
install :: InstallOptions -> Config -> Repository -> GlobalCache
......
......@@ -32,8 +32,8 @@ import System (system)
import CPM.Config (Config, packageInstallDir)
import CPM.ErrorLogger
import CPM.FileUtil (copyDirectory, inTempDir, recreateDirectory, inDirectory
, tempDir)
import CPM.FileUtil ( copyDirectory, inTempDir, recreateDirectory, inDirectory
, removeDirectoryComplete, tempDir)
import CPM.Package
--- The global package cache.
......@@ -137,8 +137,9 @@ installFromSource cfg pkg (Git url rev) = do
in checkoutGitRef pkgDir tag |>
log Info ("Package " ++ (packageId pkg) ++
" installed")
else failIO $ "Failed to clone repository from '" ++ url ++
"', return code " ++ (show c)
else removeDirectoryComplete pkgDir >>
failIO ("Failed to clone repository from '" ++ url ++
"', return code " ++ show c)
where
pkgDir = (packageInstallDir cfg) </> (packageId pkg)
cloneCommand = "git clone " ++ (quote url) ++ " " ++ (quote $ packageId pkg)
......@@ -155,7 +156,8 @@ installFromSource cfg pkg (FileSource zip) = do
" " ++ (quote absZip)
if c == 0
then log Info $ "Installed " ++ (packageId pkg)
else failIO $ "Failed to unzip package " ++ (show c)
else removeDirectoryComplete pkgDir >>
failIO ("Failed to unzip package, return code " ++ show c)
where
pkgDir = (packageInstallDir cfg) </> (packageId pkg)
......@@ -205,7 +207,8 @@ checkoutGitRef dir ref = do
c <- inDirectory dir $ system $ "git checkout " ++ ref
if c == 0
then succeedIO ()
else failIO $ "Failed to check out " ++ ref ++ ", return code " ++ (show c)
else removeDirectoryComplete dir >>
failIO ("Failed to check out " ++ ref ++ ", return code " ++ show c)
--- Installs a package's missing dependencies.
installMissingDependencies :: Config -> GlobalCache -> [Package]
......@@ -234,7 +237,7 @@ checkoutPackage cfg _ _ pkg = do
then log Error $ "Package '" ++ pkgId ++ "' already checked out."
else if sexists
then copyDirectory pkgDir pkgId >> log Info logMsg
else log Info $ "Package '" ++ pkgId ++ "' is not installed."
else log Error $ "Package '" ++ pkgId ++ "' is not installed."
where
pkgDir = (packageInstallDir cfg) </> pkgId
pkgId = packageId pkg
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment