Commit c8a58047 authored by Michael Hanus 's avatar Michael Hanus

Setting of exit codes improved

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