Commit 3b105260 authored by Michael Hanus 's avatar Michael Hanus

Option -d / --define added

parent 2f4c10b2
......@@ -7,7 +7,7 @@
module CPM.Config
( Config ( Config, packageInstallDir, binInstallDir, repositoryDir
, packageIndexRepository )
, readConfiguration, defaultConfig) where
, readConfiguration, readConfigurationWithDefault, defaultConfig ) where
import Char (isSpace)
import Directory (doesFileExist, getHomeDirectory, createDirectoryIfMissing)
......@@ -49,17 +49,25 @@ defaultConfig = Config
--- Reads the .cpmrc file from the user's home directory (if present) and merges
--- its contents into the default configuration. Resolves the $HOME variable
--- after merging and creates any missing directories. May return an error using
--- Left.
--- after merging and creates any missing directories.
--- May return an error using Left.
readConfiguration :: IO (Either String Config)
readConfiguration = do
readConfiguration = readConfigurationWithDefault []
--- Reads the .cpmrc file from the user's home directory (if present) and merges
--- its contents and some given default settings into the default configuration.
--- Resolves the $HOME variable after merging and creates
--- any missing directories. May return an error using Left.
readConfigurationWithDefault :: [(String,String)] -> IO (Either String Config)
readConfigurationWithDefault defsettings = do
home <- getHomeDirectory
configFile <- return $ home </> ".cpmrc"
exists <- doesFileExist configFile
settingsFromFile <- if exists
then readPropertyFile configFile >>= \p -> return $ stripProps p
else return []
mergedSettings <- return $ mergeConfigFile defaultConfig settingsFromFile
let mergedSettings = mergeConfigSettings defaultConfig
(settingsFromFile ++ stripProps defsettings)
case mergedSettings of
Left e -> return $ Left e
Right s' -> replaceHome s' >>= \s'' -> createDirectories s'' >>
......@@ -82,18 +90,20 @@ createDirectories cfg = do
createDirectoryIfMissing True (binInstallDir cfg)
createDirectoryIfMissing True (repositoryDir cfg)
--- Merges configuration options from a configuration file into a configuration
--- record. May return an error using Left.
--- Merges configuration options from a configuration file or argument options
--- into a configuration record. May return an error using Left.
---
--- @param cfg - the configuration record to merge into
--- @param opts - the options to merge
mergeConfigFile :: Config -> [(String, String)] -> Either String Config
mergeConfigFile cfg props = applyEither setters cfg
mergeConfigSettings :: Config -> [(String, String)] -> Either String Config
mergeConfigSettings cfg props = applyEither setters cfg
where
setters = mapMaybe id $ map maybeApply props
setters = map maybeApply props
maybeApply (k, v) = case lookup k keySetters of
Nothing -> Nothing
Just s -> Just $ s v
Nothing -> \_ -> Left $ "Unknown .cpmrc property: " ++ k ++ "\n\n" ++
"The following .cpmrc properties are allowed:\n" ++
unlines (map fst keySetters)
Just s -> \c -> Right $ s v c
--- Removes leading and trailing whitespace from option keys and values.
---
......@@ -105,11 +115,11 @@ stripProps = map (strip *** strip)
--- A map from option names to functions that will update a configuration
--- record with a value for that option.
keySetters :: [(String, String -> Config -> Either String Config)]
keySetters :: [(String, String -> Config -> Config)]
keySetters =
[ ("repository_path" , \v c -> Right $ c { repositoryDir = v })
, ("package_install_path", \v c -> Right $ c { packageInstallDir = v})
, ("bin_install_path" , \v c -> Right $ c { binInstallDir = v})
[ ("repository_path" , \v c -> c { repositoryDir = v })
, ("package_install_path", \v c -> c { packageInstallDir = v})
, ("bin_install_path" , \v c -> c { binInstallDir = v})
]
--- Sequentially applies a list of functions that transform a value to a value
......
......@@ -17,13 +17,14 @@ module CPM.FileUtil
, inDirectory
, recreateDirectory
, removeDirectoryComplete
, safeReadFile
, safeReadFile, checkAndGetDirectoryContents
) where
import Directory ( doesFileExist, getCurrentDirectory, setCurrentDirectory
import Directory ( doesFileExist, doesDirectoryExist, getCurrentDirectory
, setCurrentDirectory, getDirectoryContents
, getTemporaryDirectory, doesDirectoryExist, createDirectory
, createDirectoryIfMissing)
import System ( system, getEnviron )
import System ( system, getEnviron, exitWith )
import IOExts ( evalCmd, readCompleteFile )
import FilePath ( FilePath, replaceFileName, (</>), searchPathSeparator )
import List ( intercalate, splitOn )
......@@ -127,3 +128,12 @@ safeReadFile :: String -> IO (Either IOError String)
safeReadFile fname = do
catch (readCompleteFile fname >>= return . Right)
(return . Left)
--- Returns the list of all entries in a directory and terminates with
--- an error message if the directory does not exist.
checkAndGetDirectoryContents :: FilePath -> IO [FilePath]
checkAndGetDirectoryContents dir = do
exdir <- doesDirectoryExist dir
if exdir then getDirectoryContents dir
else do putStrLn $ "ERROR: Directory '" ++ dir ++ "' does not exist!"
exitWith 1
......@@ -23,10 +23,10 @@ import OptParse
import CPM.ErrorLogger
import CPM.FileUtil ( fileInPath, joinSearchPath, safeReadFile )
import CPM.Config ( Config (packageInstallDir, binInstallDir)
, readConfiguration)
, readConfigurationWithDefault )
import CPM.PackageCache.Global ( GlobalCache, readInstalledPackagesFromDir
, installFromZip, checkoutPackage
, uninstallPackage)
, uninstallPackage )
import CPM.Package
import CPM.Resolution ( showResult )
import CPM.Repository ( Repository, readRepository, findVersion, listPackages
......@@ -55,7 +55,7 @@ main = do
exitWith 1
Right r -> case applyParse r of
Left err -> do putStrLn cpmBanner
printUsage "cpm" 80 optionParser
--printUsage "cpm" 80 optionParser
putStrLn err
exitWith 1
Right opts -> runWithArgs opts
......@@ -68,8 +68,9 @@ runWithArgs opts = do
"(they are required for cpm to work):\n" ++
intercalate ", " missingExecutables
exitWith 1
config <- readConfiguration >>= \c -> case c of
Left err -> do putStrLn $ "Error reading .cpmrc file: " ++ err
config <- readConfigurationWithDefault (optDefConfig opts) >>= \c ->
case c of
Left err -> do putStrLn $ "Error reading .cpmrc settings: " ++ err
exitWith 1
Right c' -> return c'
let getGC = getGlobalCache config
......@@ -123,8 +124,9 @@ getRepository config = do
exitWith 1
data Options = Options
{ optLogLevel :: LogLevel
, optCommand :: Command }
{ optLogLevel :: LogLevel
, optDefConfig :: [(String,String)]
, optCommand :: Command }
data Command
= Deps
......@@ -260,6 +262,12 @@ readLogLevel s = if s == "debug"
then Right $ Debug
else Right $ Info
readRcOption :: String -> Either String (String,String)
readRcOption s =
let (option,value) = break (=='=') s
in if null value then Left $ "Error in option definition: '=' missing"
else Right $ (option, tail value)
readVersion' :: String -> Either String Version
readVersion' s = case readVersion s of
Nothing -> Left $ "'" ++ s ++ "' is not a valid version"
......@@ -274,7 +282,7 @@ applyEither (f:fs) z = case f z of
applyParse :: [Options -> Either String Options] -> Either String Options
applyParse fs = applyEither fs defaultOpts
where
defaultOpts = Options Info NoCommand
defaultOpts = Options Info [] NoCommand
(>.>) :: Either String a -> (a -> b) -> Either String b
a >.> f = case a of
......@@ -288,10 +296,16 @@ optionParser = optParser
<> short "v"
<> metavar "LEVEL"
<> help "Log level for the application. Valid values are 'info' and 'debug'." )
<.> option (\s a -> readRcOption s >.> \kv ->
a { optDefConfig = optDefConfig a ++ [kv] })
( long "define"
<> short "d"
<> metavar "DEFINITION"
<> help "Overwrite definition of cpmrc file with 'option=value'." )
<.> commands (metavar "COMMAND")
( command "checkout" (help "Checkout a package.") Right --(\a -> Right $ a { optCommand = Checkout (checkoutOpts a) })
( command "checkout" (help "Checkout a package.") Right
( arg (\s a -> Right $ a { optCommand = Checkout
(checkoutOpts a) { coPackage = s } })
(checkoutOpts a) { coPackage = s } })
( metavar "PACKAGE"
<> help "A package name or the path to a file" )
<.> arg (\s a -> readVersion' s >.> \v -> a { optCommand = Checkout (checkoutOpts a) { coVersion = Just v } })
......
......@@ -33,7 +33,8 @@ import System (system)
import CPM.Config (Config, packageInstallDir)
import CPM.ErrorLogger
import CPM.FileUtil ( copyDirectory, inTempDir, recreateDirectory, inDirectory
, removeDirectoryComplete, tempDir)
, removeDirectoryComplete, tempDir
, checkAndGetDirectoryContents )
import CPM.Package
--- The global package cache.
......@@ -268,7 +269,7 @@ tryFindPackage gc name ver = case findVersion gc name ver of
readInstalledPackagesFromDir :: String -> IO (Either String GlobalCache)
readInstalledPackagesFromDir path = do
debugMessage $ "Reading global package cache from '" ++ path ++ "'..."
pkgDirs <- getDirectoryContents path
pkgDirs <- checkAndGetDirectoryContents path
pkgPaths <- return $ map (path </>) $ filter (not . isPrefixOf ".") pkgDirs
specPaths <- return $ map (</> "package.json") pkgPaths
specs <- mapIO readPackageSpecFromFile specPaths
......
......@@ -29,7 +29,7 @@ import System (system)
import CPM.Config (Config, repositoryDir, packageIndexRepository)
import CPM.ErrorLogger
import CPM.Package
import CPM.FileUtil (inDirectory)
import CPM.FileUtil ( checkAndGetDirectoryContents, inDirectory )
data Repository = Repository [Package]
......@@ -111,9 +111,9 @@ readRepository cfg = readRepositoryFrom (repositoryDir cfg)
readRepositoryFrom :: String -> IO (Repository, [String])
readRepositoryFrom path = do
debugMessage $ "Reading repository index from '" ++ path ++ "'..."
pkgDirs <- getDirectoryContents path
pkgDirs <- checkAndGetDirectoryContents path
pkgPaths <- return $ map (path </>) $ filter dirOrSpec pkgDirs
verDirs <- mapIO getDirectoryContents pkgPaths
verDirs <- mapIO checkAndGetDirectoryContents pkgPaths
verPaths <- return $ concat $ map (\(d, p) -> map (d </>) (filter dirOrSpec p)) $ zip pkgPaths verDirs
specPaths <- return $ map (</> "package.json") verPaths
specs <- mapIO readPackageFile specPaths
......
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