Skip to content
Snippets Groups Projects
Commit 73471a0c authored by Michael Hanus's avatar Michael Hanus
Browse files

Some initial modules of CPM

parents
No related branches found
Tags v0.0.1
No related merge requests found
*~
.curry
{
"name": "cpm",
"version": "0.0.1",
"author": "Jonas Oberschweiber, Michael Hanus",
"maintainer": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "Curry Package Manager: a tool to distribute and install Curry libraries and applications",
"category": [ "Package" ],
"dependencies": {
"det-parse": ">= 0.0.1",
"opt-parse": ">= 0.0.3",
"boxes": ">= 0.0.2",
"json": ">= 0.0.2"
},
"source": {
"git": "https://git.ps.informatik.uni-kiel.de/curry-packages/cpm.git",
"tag": "$version"
}
}
--------------------------------------------------------------------------------
--- This module defines the data type for CPM's configuration options, the
--- default values for all options, and functions for reading the user's .cpmrc
--- file and merging its contents into the default options.
--------------------------------------------------------------------------------
module CPM.Config
( Config ( Config, packageInstallDir, binInstallDir, repositoryDir
, packageIndexRepository )
, readConfiguration, defaultConfig) where
import Char (isSpace)
import Directory (doesFileExist, getHomeDirectory, createDirectoryIfMissing)
import FilePath ((</>))
import Function ((***))
import List (splitOn, intersperse)
import Maybe (mapMaybe)
import PropertyFile (readPropertyFile)
import CPM.ErrorLogger
--- The location of the central package index.
packageIndexURI :: String
packageIndexURI =
"https://git.ps.informatik.uni-kiel.de/curry-packages/cpm-index.git"
-- if you have an ssh access to git.ps.informatik.uni-kiel.de:
-- "ssh://git@git.ps.informatik.uni-kiel.de:55055/curry-packages/cpm-index.git"
--- Data type containing the main configuration of CPM.
data Config = Config {
--- The directory where locally installed packages are stored
packageInstallDir :: String
--- The directory where executable of locally installed packages are stored
, binInstallDir :: String
--- Directory where the package repository is stored
, repositoryDir :: String
--- URL to the package index repository
, packageIndexRepository :: String
}
--- CPM's default configuration values. These are used if no .cpmrc file is found
--- or a new value for the option is not specified in the .cpmrc file.
defaultConfig :: Config
defaultConfig = Config
{ packageInstallDir = "$HOME/.cpm/packages"
, binInstallDir = "$HOME/.cpm/bin"
, repositoryDir = "$HOME/.cpm/index"
, packageIndexRepository = packageIndexURI }
--- 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.
readConfiguration :: IO (Either String Config)
readConfiguration = 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
case mergedSettings of
Left e -> return $ Left e
Right s' -> replaceHome s' >>= \s'' -> createDirectories s'' >>
return (Right s'')
replaceHome :: Config -> IO Config
replaceHome cfg = do
homeDir <- getHomeDirectory
return $ cfg {
packageInstallDir = replaceHome' homeDir (packageInstallDir cfg)
, binInstallDir = replaceHome' homeDir (binInstallDir cfg)
, repositoryDir = replaceHome' homeDir (repositoryDir cfg)
}
where
replaceHome' h s = concat $ intersperse h $ splitOn "$HOME" s
createDirectories :: Config -> IO ()
createDirectories cfg = do
createDirectoryIfMissing True (packageInstallDir cfg)
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.
---
--- @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
where
setters = mapMaybe id $ map maybeApply props
maybeApply (k, v) = case lookup k keySetters of
Nothing -> Nothing
Just s -> Just $ s v
--- Removes leading and trailing whitespace from option keys and values.
---
--- @param opts - the options
stripProps :: [(String, String)] -> [(String, String)]
stripProps = map (strip *** strip)
where
strip s = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace s
--- 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 =
[ ("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})
]
--- Sequentially applies a list of functions that transform a value to a value
--- of that type (i.e. a fold). Each function can error out with a Left, in
--- which case no further applications are done and the Left is returned from
--- the overall application of applyEither.
---
--- @param fs - the list of functions
--- @param v - the initial value
applyEither :: [a -> Either c a] -> a -> Either c a
applyEither [] z = Right z
applyEither (f:fs) z = case f z of
Left err -> Left err
Right z' -> applyEither fs z'
--------------------------------------------------------------------------------
--- Contains combinators for chaining IO actions that can fail and log messages.
--------------------------------------------------------------------------------
module CPM.ErrorLogger
( ErrorLogger
, LogEntry
, LogLevel (..)
, logLevelOf
, levelGte
, getLogLevel, setLogLevel
, (|>=)
, (|>)
, (|->)
, mapEL
, foldEL
, succeedIO
, failIO
, log
, showLogEntry
) where
import Global
import Pretty
import Profile -- for show run-time
infixl 0 |>=
infixl 0 |>
-- Should the current time be shown with every log information?
withShowTime :: Bool
withShowTime = False
--- An error logger.
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
| Error
| Critical
--- The global value for the log level.
logLevel :: Global LogLevel
logLevel = global Info Temporary
--- Gets the global log level. Messages below this level will not be printed.
getLogLevel :: IO LogLevel
getLogLevel = readGlobal logLevel
--- Sets the global log level. Messages below this level will not be printed.
setLogLevel :: LogLevel -> IO ()
setLogLevel level = writeGlobal logLevel level
--- Chains two actions passing the result from the first to the second.
(|>=) :: IO (ErrorLogger a) -> (a -> IO (ErrorLogger b)) -> IO (ErrorLogger b)
a |>= f = do
(msgs, err) <- a
mapIO showLogEntry msgs
case err of
Right v -> do
(msgs', err') <- f v
return $ (msgs', err')
Left m -> return $ ([], Left m)
--- Chains two actions ignoring the result of the first.
(|>) :: IO (ErrorLogger a) -> IO (ErrorLogger b) -> IO (ErrorLogger b)
a |> f = do
(msgs, err) <- a
mapIO showLogEntry msgs
case err of
Right _ -> do
(msgs', err') <- f
return $ (msgs', err')
Left m -> return $ ([], Left m)
--- Chains two actions ignoring the result of the second.
(|->) :: IO (ErrorLogger a) -> IO (ErrorLogger b) -> IO (ErrorLogger a)
a |-> b = do
(msgs, err) <- a
mapIO showLogEntry msgs
case err of
Right _ -> do
(msgs', _) <- b
return $ (msgs', err)
Left m -> return $ ([], Left m)
--- Maps an action over a list of values. Fails if one of the actions fails.
mapEL :: (a -> IO (ErrorLogger b)) -> [a] -> IO (ErrorLogger [b])
mapEL _ [] = succeedIO []
mapEL f (x:xs) = do
(msgs, err) <- f x
mapIO showLogEntry msgs
case err of
Right v -> do
(msgs', xs') <- mapEL f xs
case xs' of
Right xs'' -> succeedIO (v:xs'')
Left m' -> return $ (msgs', Left m')
Left m -> return $ ([], Left m)
--- Folds a list of values using an action. Fails if one of the actions fails.
foldEL :: (a -> b -> IO (ErrorLogger a)) -> a -> [b] -> IO (ErrorLogger a)
foldEL _ z [] = succeedIO z
foldEL f z (x:xs) = do
(msgs, err) <- f z x
mapIO showLogEntry msgs
case err of
Right v -> foldEL f v xs
Left m -> return $ ([], Left m)
--- Renders a log entry.
showLogEntry :: LogEntry -> IO ()
showLogEntry (LogEntry lvl msg) = do
minLevel <- getLogLevel
if levelGte lvl minLevel
then putStrLn $ pPrint $ lvlText <+> (text msg)
else return ()
where
lvlText = case lvl of
Info -> text "INFO "
Debug -> green $ text "DEBUG "
Critical -> red $ text "CRITICAL "
Error -> red $ text "ERROR "
--- Compares two log levels.
levelGte :: LogLevel -> LogLevel -> Bool
levelGte Debug Debug = True
levelGte Debug Info = False
levelGte Debug Error = False
levelGte Debug Critical = False
levelGte Info Debug = True
levelGte Info Info = True
levelGte Info Error = False
levelGte Info Critical = False
levelGte Error Debug = True
levelGte Error Info = True
levelGte Error Error = True
levelGte Error Critical = True
levelGte Critical Debug = True
levelGte Critical Info = True
levelGte Critical Error = True
levelGte Critical Critical = True
--- Create an action that always succeeds.
succeed :: a -> ErrorLogger a
succeed v = ([], Right v)
--- Create an IO action that always succeeds.
succeedIO :: a -> IO (ErrorLogger a)
succeedIO v = return $ succeed v
--- Create an action that always fails.
fail :: String -> ErrorLogger a
fail msg = ([logMsg], Left logMsg) where logMsg = LogEntry Critical msg
--- Create an IO action that always fails.
failIO :: String -> IO (ErrorLogger a)
failIO msg = return $ fail msg
--- Create an IO action that logs a message.
log :: LogLevel -> String -> IO (ErrorLogger ())
log lvl msg =
if withShowTime
then do
runtime <- getProcessInfos >>= return . maybe 0 id . lookup ElapsedTime
return $ ([LogEntry lvl (showTime runtime ++ ' ':msg)], Right ())
else
return $ ([LogEntry lvl msg], Right ())
where
showTime t = show (t `div` 1000) ++ "." ++ show ((t `mod` 1000) `div` 10)
\ No newline at end of file
--------------------------------------------------------------------------------
--- Some utilities for deailing with files and directories
--- for the Curry Package Manager.
--------------------------------------------------------------------------------
module CPM.FileUtil
( joinSearchPath
, copyDirectory
, createSymlink
, removeSymlink
, isSymlink
, linkTarget
, copyDirectoryFollowingSymlinks
, fileInPath
, tempDir
, inTempDir
, inDirectory
, recreateDirectory
, removeDirectoryComplete
) where
import Directory ( doesFileExist, getCurrentDirectory, setCurrentDirectory
, getTemporaryDirectory, doesDirectoryExist, createDirectory
, createDirectoryIfMissing)
import System (system, getEnviron)
import IOExts (evalCmd)
import FilePath (FilePath, replaceFileName, (</>), searchPathSeparator)
import List (intercalate, splitOn)
--- Joins a list of directories into a search path.
joinSearchPath :: [FilePath] -> String
joinSearchPath dirs = intercalate [searchPathSeparator] dirs
--- Recursively copies a directory structure.
copyDirectory :: String -> String -> IO ()
copyDirectory src dst = do
retCode <- system $ "cp -pR \"" ++ src ++ "\" \"" ++ dst ++ "\""
if retCode /= 0
then error $ "Copy failed with " ++ (show retCode)
else return ()
--- Recursively copies a directory structure following symlinks, i.e. links
--- get replaced by copies in the destination.
copyDirectoryFollowingSymlinks :: String -> String -> IO ()
copyDirectoryFollowingSymlinks src dst = do
retCode <- system $ "cp -pLR \"" ++ src ++ "\" \"" ++ dst ++ "\""
if retCode /= 0
then error $ "Copy failed with " ++ (show retCode)
else return ()
--- Creates a new symlink.
createSymlink :: String -> String -> IO Int
createSymlink from to = system $ "ln -s " ++ (quote from) ++ " " ++ (quote to)
--- Deletes a symlink.
removeSymlink :: String -> IO Int
removeSymlink link = system $ "rm " ++ (quote link)
--- Tests whether a file is a symlink.
isSymlink :: String -> IO Bool
isSymlink link = do
(code, _, _) <- evalCmd "readlink" ["-n", link] ""
return $ code == 0
--- Gets the target of a symlink.
linkTarget :: String -> IO String
linkTarget link = do
(rc, out, _) <- evalCmd "readlink" ["-n", link] ""
if rc == 0
then return $ replaceFileName link out
else return ""
quote :: String -> String
quote s = "\"" ++ s ++ "\""
--- Checks whether a file exists in one of the directories on the PATH.
fileInPath :: String -> IO Bool
fileInPath file = do
path <- getEnviron "PATH"
dirs <- return $ splitOn ":" path
(liftIO (any id)) $ mapIO (doesFileExist . (</> file)) dirs
--- Gets CPM's temporary directory.
tempDir :: IO String
tempDir = do
t <- getTemporaryDirectory
return (t </> "cpm")
--- Executes an IO action with the current directory set to CPM's temporary
--- directory.
inTempDir :: IO b -> IO b
inTempDir b = do
t <- getTemporaryDirectory
exists <- doesDirectoryExist (t </> "cpm")
if exists
then return ()
else createDirectory (t </> "cpm")
inDirectory (t </> "cpm") b
--- Executes an IO action with the current directory set to a specific
--- directory.
inDirectory :: String -> IO b -> IO b
inDirectory dir b = do
previous <- getCurrentDirectory
setCurrentDirectory dir
b' <- b
setCurrentDirectory previous
return b'
--- Recreates a directory. Deletes its contents if it already exists.
recreateDirectory :: String -> IO ()
recreateDirectory dir = do
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
This diff is collapsed.
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment