|
sourcecode:
|
module CPM.Manage ( main )
where
import Control.Monad ( when, unless )
import Data.List ( (\\), groupBy, isPrefixOf, intercalate, intersect
, isSuffixOf, nub, nubBy, partition, sort, sortBy
, sum, union )
import System.Environment ( getArgs )
import System.IO ( hPutStr, hPutStrLn, stderr )
import Data.GraphViz
import Data.Time ( CalendarTime, compareCalendarTime, ctDay, ctMonth
, ctYear, getLocalTime, toDayString )
import HTML.Base
import HTML.Styles.Bootstrap4
import Language.Curry.Resources ( curryPackagesDocURL )
import System.CurryPath ( curryModulesInDirectory, stripCurrySuffix )
import System.Directory ( createDirectoryIfMissing, doesDirectoryExist
, doesFileExist, getAbsolutePath, getCurrentDirectory
, getDirectoryContents, getTemporaryDirectory
, setCurrentDirectory )
import System.FilePath ( (</>) )
import System.IOExts ( evalCmd, readCompleteFile )
import System.Process ( getPID, exitWith, system )
import Text.CSV ( readCSV, showCSV, writeCSVFile )
import CPM.Config ( Config, repositoryDir, packageInstallDir
, readConfigurationWith, showConfiguration )
import CPM.ErrorLogger
import CPM.FileUtil ( cleanTempDir, copyDirectory, inDirectory
, inTempDir, quote, recreateDirectory
, removeDirectoryComplete, tempDir )
import CPM.Package
import CPM.PackageCache.Global ( acquireAndInstallPackageFromSource
, checkoutPackage )
import CPM.Package.Helpers ( renderPackageInfo )
import CPM.Repository ( allPackages, listPackages
, readPackageFromRepository )
import CPM.Repository.Update ( addPackageToRepository, updateRepository )
import CPM.Repository.Select ( getBaseRepository, getPackageVersion )
import CPM.Resolution ( isCompatibleToCompiler )
import CPM.Package.HTML
------------------------------------------------------------------------------
-- Some configurations (might be necessary to adapt).
-- Banner of the CPM manage tool:
banner :: String
banner = unlines [bannerLine, bannerText, bannerLine]
where
bannerText = "cpm-manage (Version of 24/03/2025)"
bannerLine = take (length bannerText) (repeat '-')
--- Subdirectory containing HTML files for each package
--- generated by `cpm-manage genhtml`.
packageHtmlDir :: String
packageHtmlDir = "pkgs"
--- Directory with documentations for Currygle.
currygleDocDir :: String
currygleDocDir = "currygledocs"
------------------------------------------------------------------------------
-- Main operation to parse arguments and invoke the various manager commands.
main :: IO ()
main = do
allargs <- getArgs
let (rcdefs, args) = readRcOptions allargs
config <- readConfiguration rcdefs
case args of
["genhtml"] -> writePackageIndexAsHTML config "CPM"
["genhtml",d] -> writePackageIndexAsHTML config d
["genhtml",d,p,v] -> writePackageVersionAsHTML config d p v
["genreadme"] -> writeReadmeFiles config "CPM"
["genreadme",d] -> writeReadmeFiles config d
["gendocs"] -> generateDocsOfAllPackages config rcdefs packageDocDir
["gendocs",d] -> getAbsolutePath d >>=
generateDocsOfAllPackages config rcdefs
["gentar"] -> genTarOfAllPackages config packageTarDir
["gentar",d] -> getAbsolutePath d >>= genTarOfAllPackages config
["testall"] -> testAllPackages config rcdefs ""
["testall",d] -> getAbsolutePath d >>= testAllPackages config rcdefs
["sumcsv",d] -> do ad <- getAbsolutePath d
sumCSVStatsOfPkgs ad "SUM.csv"
["showgraph"] -> visualizePackageDependencies config ""
["showgraph",p] -> visualizePackageDependencies config p
["packagelist"] -> getPackageDependencies config >>= putStrLn . showCSV
["writeall"] -> writeAllPackages config
["writedeps"] -> writeAllPackageDependencies config
["writemods"] -> writeAllPackageModules config rcdefs
["copydocs"] -> copyPackageDocumentations config packageDocDir
["copydocs",d] -> getAbsolutePath d >>= copyPackageDocumentations config
["config"] -> printConfig config
["--help"] -> putStrLn helpText
["-h"] -> putStrLn helpText
_ -> do putStrLn $ "Illegal arguments: " ++ unwords args
putStrLn helpText
exitWith 1
-- Reads given RC options of the form `-dDEF` or `--define DEF`,
-- where `DEF` has the form `option=value`, from a given list
-- of arguments.
readRcOptions :: [String] -> ([(String,String)], [String])
readRcOptions [] = ([], [])
readRcOptions (arg:args)
| "--define" `isPrefixOf` arg
= case args of
[] -> error "Illegal argument: '--define' without argument"
(a:as) -> let (remopts, remargs) = readRcOptions as
in (readOpt "--define " a : remopts, remargs)
| "-d" `isPrefixOf` arg
= let (remopts, remargs) = readRcOptions args
in (readOpt "-d" (drop 2 arg) : remopts, remargs)
| otherwise
= let (remopts, remargs) = readRcOptions args
in (remopts, arg : remargs)
where
readOpt p s =
let (option,value) = break (=='=') s
in if null value
then error $ "Illegal option definition: '=' missing in\n" ++ p ++ s
else (option, tail value)
helpText :: String
helpText = banner ++ unlines
[ "Options:", ""
, "-d, --define option=value : Overwrite definition of cpmrc file"
, "-h, --help : show usage information"
, ""
, "Commands:", ""
, "config : show current configuration"
, "genhtml [<d>] : generate HTML pages for all packages into <d>"
, " (default: 'CPM')"
, "genhtml <d> <p> <v>: generate HTML pages for package <p> / version <v>"
, " into directory <d>"
, "genreadme [<d>]: generate README.html files for all packages into <d>"
, " (default: 'CPM') if they are not already present"
, "gendocs [<d>] : generate HTML documentations of all packages into <d>"
, " (default: '" ++ packageDocDir ++ "')"
, "gentar [<d>] : generate tar.gz files of all packages into <d>"
, " (default: '" ++ packageTarDir ++ "')"
, "testall [<d>] : test all packages and write test statistics into"
, " directory <d> if it is provided"
, "sumcsv [<d>] : sum up all CSV package statistic files in <d>"
, "showgraph : visualize all package dependencies as a dot graph"
, "showgraph <p> : visualize dependencies for package <p> as a dot graph"
, "packagelist : show list of all packages ordered by dependencies (CSV)"
, "writeall : write all versions of all packages into 'allpkgs.csv'"
, "writedeps : write all package dependencies as CSV file 'pkgdeps.csv'"
, "writemods : write modules exported by package into 'pkgmods.csv'"
, "copydocs [<d> ]: copy latest package documentations"
, " from <d> (default: '" ++ packageDocDir ++ "')"
, " to '" ++ currygleDocDir ++ "'"
]
--- The default directory for package documentations generated by
--- the commands `cpm-manage gendocs` and `cpm-manage copydics`.
packageDocDir :: String
packageDocDir = "CPM" </> "DOC"
--- The default directory for tar files of packages generated by
--- the command `cpm-manage gentar`.
packageTarDir :: String
packageTarDir = "CPM" </> "PACKAGES"
------------------------------------------------------------------------------
--- Get all packages from the package index.
--- For each package, get the newest version compatible
--- to the current compiler. If there is no compatible version and the
--- second argument is False, get the newest version, otherwise the package
--- is ignored.
--- In addition to this package list (second component),
--- the first component contains the list of all packages grouped by versions
--- (independent of the compiler compatbility).
getAllPackageSpecs :: Config -> Bool -> IO ([[Package]],[Package])
getAllPackageSpecs config compat = do
hPutStr stderr "Reading package index..."
repo <- fromEL $ getBaseRepository config
let allpkgversions = listPackages repo
allcompatpkgs = sortBy (\ps1 ps2 -> name ps1 <= name ps2)
(concatMap (filterCompatPkgs config)
allpkgversions)
hPutStrLn stderr "done"
return (allpkgversions, allcompatpkgs)
where
-- Returns the first package compatible to the current compiler.
-- If `compat` is False and there are no compatible packages,
-- return the first package.
filterCompatPkgs cfg pkgs =
let comppkgs = filter (isCompatibleToCompiler cfg) pkgs
in if null comppkgs
then if compat then [] else take 1 pkgs
else [head comppkgs]
------------------------------------------------------------------------------
-- Generate README files used in the HTML index pages into the
-- documentation directories if they are not already there.
-- Thus, for each package p version v, do the following:
-- If there is a README file in directory PACKAGES/p-v but not
-- README.html in directory DOC/p-v, generate the latter by
-- pandoc -s -t html -o ....
writeReadmeFiles :: Config -> String -> IO ()
writeReadmeFiles cfg cpmindexdir = do
createDirectoryIfMissing True cpmindexdir
inDirectory cpmindexdir $ do
(allpkgversions,_) <- getAllPackageSpecs cfg False
mapM_ genReadmeForPackage
(sortBy (\p1 p2 -> packageId p1 <= packageId p2)
(concat allpkgversions))
genReadmeForPackage :: Package -> IO ()
genReadmeForPackage pkg = do
putStrLn $ "CHECKING PACKAGE: " ++ pkgid
rmfiles <- getReadmeFiles pkgdir
rmexist <- doesFileExist $ docdir </> "README.html"
if null rmfiles || rmexist
then unless rmexist $ putStrLn $ "No README file found"
else do
let readmefile = head rmfiles
formatcmd1 = formatCmd1 (pkgdir </> readmefile)
formatcmd2 = formatCmd2 (pkgdir </> readmefile)
createDirectoryIfMissing True docdir
putStrLn $ "Executing: " ++ formatcmd1
rc1 <- system formatcmd1
putStrLn $ "Executing: " ++ formatcmd2
rc2 <- system formatcmd2
if rc1 == 0 && rc2 == 0
then do
-- make them readable:
system $ unwords ["chmod -f 644 ", quote outfile1, quote outfile2]
return ()
else error $ "Error during execution of commands:\n" ++
formatcmd1 ++ "\n" ++ formatcmd2
where
pkgid = packageId pkg
pkgdir = "PACKAGES" </> pkgid
docdir = "DOC" </> pkgid
getReadmeFiles dir = do
entries <- getDirectoryContents dir
return $ filter ("README" `isPrefixOf`) entries
outfile1 = docdir </> "README.html"
outfile2 = docdir </> "README_I.html"
pandocCmd = "pandoc -f gfm -t html "
formatCmd1 readme = pandocCmd ++ "-s -o " ++ outfile1 ++ " " ++ readme
formatCmd2 readme = pandocCmd ++ "-o " ++ outfile2 ++ " " ++ readme
------------------------------------------------------------------------------
-- Generate main HTML index pages of the CPM repository.
writePackageIndexAsHTML :: Config -> String -> IO ()
writePackageIndexAsHTML config cpmindexdir = do
createDirectoryIfMissing True cpmindexdir
inDirectory cpmindexdir $ do
createDirectoryIfMissing True packageHtmlDir
system $ "chmod 755 " ++ packageHtmlDir
(allpkgversions,newestpkgs) <- getAllPackageSpecs config False
writePackageDependencies config newestpkgs
let stats = pkgStatistics allpkgversions newestpkgs
putStrLn "Reading all package specifications..."
allnpkgs <- fromEL $ mapM (readPackageFromRepository config) newestpkgs
writePackageIndex allnpkgs allnpkgs "index.html" stats 0
allvpkgs <- fromEL $
mapM (readPackageFromRepository config)
(concat
(map reverse
(sortBy (\pg1 pg2 -> name (head pg1) <= name (head pg2))
allpkgversions)))
allvpkgtimes <- mapM (\p -> getUploadTime p >>= \t -> return (p,t)) allvpkgs
let allvpkgsorted = map fst (sortBy comparePkgWithTime allvpkgtimes)
writePackageIndex allvpkgs allvpkgsorted "indexv.html" stats 1
writeCategoryIndexAsHTML allnpkgs
mapM_ (writePackageAsHTML allpkgversions) allvpkgs
--mapM_ (writePackageAsHTML allpkgversions) $ take 3 allnpkgs
return ()
where
comparePkgWithTime (_,mt1) (_,mt2) =
maybe False
(\t1 -> maybe True (\t2 -> compareCalendarTime t1 t2 == GT) mt2)
mt1
writePackageIndex indexpkgs listpkgs indexfile statistics actindex = do
putStrLn $ "Writing '" ++ indexfile ++ "'..."
indextable <- packageInfosAsHtmlTable (actindex/=0) listpkgs
let ptitle = "Curry Packages in the CPM Repository"
refOfPkg = if actindex == 0 then name else packageId
pkglinks = map (\p -> hrefPrimBadge
(packageHtmlDir </> refOfPkg p ++ ".html")
[htxt $ refOfPkg p])
indexpkgs
pindex = if actindex == 0
then [h2 [htxt "Package index:"], par (hitems pkglinks),
h2 [htxt "Packages sorted by name"]]
else [h2 [htxt "All package versions sorted by upload time"]]
pagestring <- cpmIndexPage ptitle (pindex ++ [indextable] ++ statistics)
actindex
writeReadableFile indexfile pagestring
pkgStatistics allpkgversions newestpkgs =
[h4 [htxt "Statistics:"],
par [htxt $ show (length newestpkgs) ++ " packages", breakline,
htxt $ show (length (concat allpkgversions)) ++ " package versions"]]
-- Generate main category index page.
writeCategoryIndexAsHTML :: [Package] -> IO ()
writeCategoryIndexAsHTML allpkgs = do
let allcats = sortBy (<=) . nub . concatMap category $ allpkgs
catpkgs = map (\c -> (c, sortBy pidLeq . nubBy pidEq .
filter (\p -> c `elem` category p) $ allpkgs))
allcats
cattables <- mapM formatCat catpkgs
let catlinks = map (\ (c,_) -> hrefPrimBadge ('#':c) [htxt c]) catpkgs
hcats = concatMap (\ (c,t) -> [anchor c [htxt ""], hrule, h1 [htxt c], t])
cattables
ptitle = "Curry Packages by Category"
pagestring <- cpmIndexPage ptitle
(h2 [htxt "Category index:"] : par (hitems catlinks) :
hcats) 2
let catindexfile = "indexc.html"
putStrLn $ "Writing '" ++ catindexfile ++ "'..."
writeReadableFile catindexfile pagestring
where
pidEq p1 p2 = packageId p1 == packageId p2
pidLeq p1 p2 = packageId p1 <= packageId p2
formatCat (c,ps) = do
pstable <- packageInfosAsHtmlTable False ps
return (c, pstable)
--- Standard HTML page for generated a package index.
cpmIndexPage :: String -> [BaseHtml] -> Int -> IO String
cpmIndexPage title maindoc actindex = do
time <- getLocalTime
let dayversion = " (Version: " ++ toDayString time ++ ")"
btbase = "bt4"
return $ showHtmlPage $
bootstrapPage (favIcon btbase) (cssIncludes btbase) (jsIncludes btbase)
title packagesHomeBrand
(leftTopMenu False actindex)
rightTopMenu 0 []
[h1 [htxt title, smallMutedText dayversion]]
maindoc (curryDocFooter time)
--- Generate HTML page for a package in a given version into a directory.
writePackageVersionAsHTML :: Config -> String -> String -> String -> IO ()
writePackageVersionAsHTML cfg cpmindexdir pname pversion = do
case readVersion pversion of
Nothing -> error $ "'" ++ pversion ++ "' is not a valid version"
Just v -> do
(allpkgs,_) <- getAllPackageSpecs cfg False
mbpkg <- fromEL $ getPackageVersion cfg pname v
case mbpkg of
Nothing ->
error $ "Package '" ++ pname ++ "-" ++ pversion ++ "' not found!"
Just pkg -> do
fullpkg <- fromEL $ readPackageFromRepository cfg pkg
createDirectoryIfMissing True cpmindexdir
putStrLn $ "Changing to directory '" ++ cpmindexdir ++ "'..."
inDirectory cpmindexdir $ do
createDirectoryIfMissing True packageHtmlDir
system $ "chmod 755 " ++ packageHtmlDir
writePackageAsHTML allpkgs fullpkg
--- Write HTML pages for a single package.
writePackageAsHTML :: [[Package]] -> Package -> IO ()
writePackageAsHTML allpkgversions pkg = do
pagestring <- packageToHTML allpkgversions pkg
inDirectory packageHtmlDir $ do
putStrLn $ "Writing '" ++ htmlfile ++ "'..."
writeReadableFile htmlfile pagestring
putStrLn $ "Writing '" ++ htmlsrcfile ++ "'..."
srcdirstring <- directoryContentsPage
(htmlfile, [htxt $ "Package", nbsp,
code [htxt $ name pkg]])
(".." </> "PACKAGES") pkgid
writeReadableFile htmlsrcfile srcdirstring
writeReadableFile metafile (renderPackageInfo True True True pkg)
-- set symbolic link to recent package:
system $ unwords
["/bin/rm", "-f", htmllink, "&&", "ln", "-s", htmlfile, htmllink]
return ()
where
pkgid = packageId pkg
htmlfile = pkgid ++ ".html"
htmlsrcfile = pkgid ++ "-src.html"
htmllink = name pkg ++ ".html"
metafile = pkgid ++ ".txt"
--- Writes a file readable for all:
writeReadableFile :: String -> String -> IO ()
writeReadableFile f s = writeFile f s >> system ("chmod 644 " ++ f) >> return ()
-- Format a list of packages as an HTML table.
-- If the first argument is `True`, the link to the package contains
-- the version number.
packageInfosAsHtmlTable :: Bool -> [Package] -> IO BaseHtml
packageInfosAsHtmlTable withversion pkgs = do
rows <- mapM formatPkgAsRow pkgs
return $ borderedHeadedTable
(map ((:[]) . htxt)
["Name","Executable","Synopsis", "Version", "Upload date"])
rows
where
formatPkgAsRow :: Package -> IO [[BaseHtml]]
formatPkgAsRow pkg = do
ptime <- getUploadTime pkg
return
[ [hrefPrimSmBlock (packageHtmlDir </> pkgref ++ ".html")
[htxt $ name pkg]]
, intercalate [nbsp]
(map (\ (PackageExecutable n _ _) -> [kbdInput [htxt n]])
(executableSpec pkg))
, [htxt $ synopsis pkg]
, [htxt $ showVersion (version pkg)]
, maybe [nbsp] (\t -> [htxt $ toDate t]) ptime
]
where
pkgref = if withversion then packageId pkg else name pkg
toDate ct = show (ctYear ct) ++ show2 (ctMonth ct) ++ show2 (ctDay ct)
where show2 i = '-' : if i < 10 then '0' : show i else show i
------------------------------------------------------------------------------
-- Generate HTML documentation of all packages in the central repository
generateDocsOfAllPackages :: Config -> [(String,String)] -> String -> IO ()
generateDocsOfAllPackages cfg rcdefs packagedocdir = do
(_,allpkgs) <- getAllPackageSpecs cfg True
mapM_ genDocOfPackage allpkgs
where
genDocOfPackage pkg = inEmptyTempDir $ do
let pname = name pkg
pversion = showVersion (version pkg)
putStrLn $ unlines [dline, "Documenting: " ++ pname, dline]
let cpmcall = cpmCall rcdefs
cmd = unwords [ "rm -rf", pname, "&&"
, cpmcall, "checkout", pname, pversion, "&&"
, "cd", pname, "&&"
, cpmcall, "install", "--noexec", "&&"
, cpmcall, "doc", "--docdir", packagedocdir
, "--url", curryPackagesDocURL, "&&"
, "cd ..", "&&"
, "rm -rf", pname
]
putStrLn $ "CMD: " ++ cmd
system cmd
------------------------------------------------------------------------------
-- Run `cypm test` on all packages of the central repository
testAllPackages :: Config -> [(String,String)] -> String -> IO ()
testAllPackages cfg rcdefs statdir = do
(_,allpkgs) <- getAllPackageSpecs cfg True
results <- mapM (checkoutAndTestPackage rcdefs statdir) allpkgs
putStrLn dline
let (incmpt,cmptres) = partition ((<0) . fst) results
unless (null incmpt) $ putStrLn $
"INCOMPATIBLE PACKAGES (NOT TESTED): " ++ unwords (map snd incmpt)
if sum (map fst cmptres) == 0
then putStrLn $ show (length cmptres) ++ " PACKAGES SUCCESSFULLY TESTED!"
else do putStrLn $ "ERRORS OCCURRED IN PACKAGES: " ++
unwords (map snd (filter ((> 0) . fst) cmptres))
exitWith 1
dline :: String
dline = take 78 (repeat '=')
------------------------------------------------------------------------------
-- Generate tar.gz files of all packages (in the current directory)
genTarOfAllPackages :: Config -> String -> IO ()
genTarOfAllPackages cfg tardir = do
createDirectoryIfMissing True tardir
putStrLn $ "Generating tar.gz of all package versions in '" ++ tardir ++
"'..."
(allpkgversions,_) <- getAllPackageSpecs cfg False
allpkgs <- fromEL $ mapM (readPackageFromRepository cfg)
(sortBy (\ps1 ps2 -> packageId ps1 <= packageId ps2)
(concat allpkgversions))
mapM_ writePackageAsTar allpkgs --(take 3 allpkgs)
where
writePackageAsTar pkg = do
let pkgname = name pkg
pkgid = packageId pkg
pkgdir = tardir </> pkgid
tarfile = pkgdir ++ ".tar.gz"
putStrLn $ "Checking out '" ++ pkgid ++ "'..."
let checkoutdir = pkgname
system $ unwords [ "rm -rf", checkoutdir, pkgdir ]
fromEL $ do
acquireAndInstallPackageFromSource cfg pkg
checkoutPackage cfg pkg ""
let cmd = unwords [ "cd", checkoutdir, "&&"
, "tar", "cvzf", tarfile, ".", "&&"
, "chmod", "644", tarfile, "&&"
, "cd", "..", "&&", "mv", checkoutdir, pkgdir, "&&"
, "chmod", "-R", "go+rX", pkgdir
]
putStrLn $ "...with command:\n" ++ cmd
ecode <- system cmd
when (ecode>0) $ error $ "ERROR OCCURED IN PACKAGE '" ++ pkgid ++ "'!"
------------------------------------------------------------------------------
-- Test a specific version of a package by checking it out in a temporary
-- directory, install it (with a local bin dir), and run all tests.
-- Returns the exit code of the package test command and the packaged id.
checkoutAndTestPackage :: [(String,String)] -> String -> Package
-> IO (Int,String)
checkoutAndTestPackage rcdefs statdir pkg = inEmptyTempDir $ do
putStrLn $ unlines [dline, "Testing package: " ++ pkgid, dline]
-- create installation bin dir:
curdir <- getCurrentDirectory
let bindir = curdir </> "pkgbin"
recreateDirectory bindir
let statfile = if null statdir then "" else statdir </> pkgid ++ ".csv"
unless (null statdir) $ createDirectoryIfMissing True statdir
let checkoutdir = pkgname
cpmcall = cpmCall (rcdefs ++ [("bin_install_path",bindir)])
icmd = unwords $
[ "rm -rf", checkoutdir, "&&"
, cpmcall, "checkout", pkgname, showVersion pkgversion, "&&"
, "cd", checkoutdir, "&&"
-- install possible binaries in bindir:
, cpmcall, "install", "&&"
-- compute package load to check for compatible version:
, "echo PACKAGE LOAD PATH:", "&&"
, cpmcall, "deps --path" ]
tcmd = unwords $
[ "cd", checkoutdir, "&&"
, "export PATH=" ++ bindir ++ ":$PATH", "&&"
, cpmcall, "test"] ++
(if null statfile then [] else ["-f", statfile]) ++
[ "&&", cpmcall, "uninstall" ]
putStrLn $ "CHECKOUT AND INSTALL WITH COMMAND:\n" ++ icmd
ecode1 <- system icmd
if ecode1 > 0
then do
putStrLn $ "INCOMPATIBLE PACKAGE '" ++ pkgid ++ "'!"
return (-1,pkgid)
else do
putStrLn $ "TEST WITH COMMAND:\n" ++ tcmd
ecode2 <- system tcmd
when (ecode2 > 0) $ putStrLn $
"ERROR OCCURED IN PACKAGE '" ++ pkgid ++ "'!"
return (ecode2,pkgid)
where
pkgname = name pkg
pkgversion = version pkg
pkgid = packageId pkg
------------------------------------------------------------------------------
-- Combine all CSV statistics files for packages (produced by
-- `cypm test -f ...`) contained in a directory into a result file
-- and sum up the results.
sumCSVStatsOfPkgs :: String -> String -> IO ()
sumCSVStatsOfPkgs dir outfile = do
combineCSVFilesInDir readStats showResult addStats ([],[]) dir outfile
putStrLn $ "All results written to file '" ++ outfile ++ "'."
where
readStats rows =
let [pkgid,ct,rc,total,unit,prop,eqv,io,mods] = rows !! 1
in (rows !! 0,
[ (pkgid, ct,
map (\s -> read s :: Int) [rc,total,unit,prop,eqv,io], mods) ])
showResult (header,rows) =
header :
sortBy (<=)
(map (\(pkgid,ct,nums,mods) -> pkgid : ct : map show nums ++ [mods])
rows) ++
["TOTAL:" : "" :
map show
(foldr1 (\nums1 nums2 -> map (uncurry (+)) (zip nums1 nums2))
(map (\ (_,_,ns,_) -> ns) rows))]
addStats (header,rows1) (_,rows2) = (header, rows1 ++ rows2)
-- Combine all CSV files contained in a directory into one result CSV file
-- according to an operation to read the contents of each CSV file,
-- an operation to write the result into CSV format,
-- an operation to combine the results, and a default value.
combineCSVFilesInDir :: ([[String]] -> a) -> (a -> [[String]]) -> (a -> a -> a)
-> a -> String -> String -> IO ()
combineCSVFilesInDir fromcsv tocsv combine emptycsv statdir outfile = do
dcnts <- getDirectoryContents statdir
let csvfiles = map (statdir </>) (filter (".csv" `isSuffixOf`) dcnts)
stats <- mapM (\f -> readCompleteFile f >>= return . fromcsv . readCSV)
csvfiles
let results = foldr combine emptycsv stats
writeCSVFile outfile (tocsv results)
------------------------------------------------------------------------------
-- Writes the dependencies of packages as an HTML page for each package
-- with a dot graph in SVG.
writePackageDependencies :: Config -> [Package] -> IO ()
writePackageDependencies _ pkgs = do
putStrLn $ "Generating package dependency files in directory '" ++
packageHtmlDir ++ "'..."
inDirectory packageHtmlDir $ mapM_ writeDepsOfPackage (map name pkgs)
where
writeDepsOfPackage pname = do
let dotgraph = packageDependenciesAsGraph pkgs pname
htmldepsfile = pname ++ "-deps.html"
putStrLn $ "Writing '" ++ htmldepsfile ++ "'..."
(_,svgtxt,_) <- evalCmd "/usr/bin/dot" ["-Tsvg"] (showDotGraph dotgraph)
depspage <- subdirHtmlPage ("Dependencies of " ++ pname)
(pname ++ ".html",
[htxt $ "Package", nbsp, code [htxt $ pname]])
[h1 [smallMutedText "Dependencies of ", htxt pname]]
[block [htmlText svgtxt]]
writeReadableFile htmldepsfile depspage
------------------------------------------------------------------------------
-- Get name and version of all packages compatible to current compiler as a
-- list ordered by the dependencies starting from the base package.
-- This is useful for tools processing all packages.
getPackageDependencies :: Config -> IO [[String]]
getPackageDependencies cfg = do
(_,allcompatpkgs) <- getAllPackageSpecs cfg True
return $ map (\p -> [name p, showVersion (version p)])
(psort [] [] allcompatpkgs)
where
psort sorted [] [] = reverse sorted
psort sorted unsorted@(_:_) [] = psort sorted [] unsorted
psort sorted unsorted (p:ps) =
let pdeps = map (\ (Dependency p' _) -> p') (dependencies p)
in if all (`elem` (map name sorted)) pdeps
then psort (p:sorted) unsorted ps
else psort sorted (p:unsorted) ps
------------------------------------------------------------------------------
-- Visualize package dependencies as dot graph.
-- The second argument is the name of the package to be visualized or empty
-- if all packages should be visualized.
visualizePackageDependencies :: Config -> String -> IO ()
visualizePackageDependencies cfg pname = do
(_,pkgs) <- getAllPackageSpecs cfg False
putStrLn "Show dot graph..."
viewDotGraph (packageDependenciesAsGraph pkgs pname)
-- Translate package dependencies into a dot graph.
-- The first argument is the list of all packages.
-- The second argument is the name of the package to be visualized or empty
-- if all packages should be visualized.
packageDependenciesAsGraph :: [Package] -> String -> DotGraph
packageDependenciesAsGraph pkgs pname =
let alldeps = map (\p -> (name p, map (\ (Dependency p' _) -> p')
(dependencies p))) pkgs
deps = if null pname then alldeps
else depsOnPkgs alldeps [pname] [] [] `union`
depsOfPkgs alldeps [pname] [] []
in depsToGraph pname deps
-- Type of package dependencies (based only on package names).
type PkgDeps = [(String, [String])]
--- Computes all transitive dependencies on a list of packages (second arg).
depsOnPkgs :: PkgDeps -> [String] -> [String] -> PkgDeps -> PkgDeps
depsOnPkgs _ [] seenps deps =
map (\ (pn,ds) -> (pn, ds `intersect` seenps)) deps
depsOnPkgs alldeps (p:ps) seenps deps =
let pdeps = filter ((p `elem`) . snd) alldeps
in depsOnPkgs alldeps (ps `union` nub (map fst pdeps \\ seenps))
(p:seenps) (pdeps `union` deps)
--- Computes all transitive dependencies of a list of packages (second arg).
depsOfPkgs :: PkgDeps -> [String] -> [String] -> PkgDeps -> PkgDeps
depsOfPkgs _ [] _ deps = deps
depsOfPkgs alldeps (p:ps) seenps deps =
let pdeps = filter ((==p) . fst) alldeps
in depsOfPkgs alldeps (ps `union` nub (concatMap snd pdeps \\ seenps))
(p:seenps) (pdeps `union` deps)
depsToGraph :: String -> PkgDeps -> DotGraph
depsToGraph pname cpmdeps =
dgraph "Package Dependencies"
(map (\s -> Node s (("URL", s ++ ".html") :
if pname==s then currentPackageStyle else []))
(nub (map fst cpmdeps ++ concatMap snd cpmdeps)))
(map (\ (s,t) -> Edge s t [])
(nub (concatMap (\ (p,ds) -> map (\d -> (p,d)) ds) cpmdeps)))
where
currentPackageStyle = [("style","filled"), ("fillcolor","red")]
------------------------------------------------------------------------------
-- Write infos about all versions of packages into CSV file 'allpkgs.csv'.
-- This can be used to initialize the database of Masala.
writeAllPackages :: Config -> IO ()
writeAllPackages cfg = do
(allpkgs,_) <- getAllPackageSpecs cfg True
putStr "Reading all packages.."
pkginfos <- mapM pkg2csv (sortBy leqP (concat allpkgs))
let outfile = "allpkgs.csv"
writeCSVFile outfile (headline : pkginfos)
putStrLn $ "Infos about all packages written to '" ++ outfile ++ "'"
where
headline = [ "Package name", "Version", "Description", "Upload time"
, "Dependencies", "Exported modules", "Categories"]
leqP p1 p2 = name p1 < name p2 ||
(name p1 == name p2 &&
showVersion (version p1) <= showVersion (version p2))
pkg2csv p = do
putChar '.'
pkg <- fromEL $ readPackageFromRepository cfg p
mbtime <- getUploadTime pkg
return
[ name pkg
, showVersion $ version pkg
, pkg2desc pkg
, show mbtime
, show $ sort $ map (\ (Dependency p' _) -> p') (dependencies pkg)
, show $ sort $ exportedModules pkg
, show $ sort $ category pkg
]
pkg2desc pkg = unwords $ words $ -- to remove leading blanks
maybe (synopsis pkg)
id
(description pkg)
------------------------------------------------------------------------------
-- Write package dependencies into CSV file 'pkgdeps.csv'
writeAllPackageDependencies :: Config -> IO ()
writeAllPackageDependencies cfg = do
(_,pkgs) <- getAllPackageSpecs cfg True
let alldeps = map (\p -> name p : showVersion (version p) :
map (\ (Dependency p' _) -> p') (dependencies p))
pkgs
let outfile = "pkgdeps.csv"
writeCSVFile outfile alldeps
putStrLn $ "Package dependencies written to '" ++ outfile ++ "'"
------------------------------------------------------------------------------
-- For all packages, write the exported modules into CSV file 'pkgmods.csv'.
-- The exported modules are taken either from the package specification or
-- these are modules of a package if such a specificaiton is missing.
writeAllPackageModules :: Config -> [(String,String)] -> IO ()
writeAllPackageModules cfg rcdefs = do
(allpkgversions,allcompatpkgs) <- getAllPackageSpecs cfg True
putStr "Reading packages:"
allmods <- mapM (\p -> expMods p >>= return . showPkgLine p True)
allcompatpkgs
let allpkgs = concatMap (take 1) allpkgversions
incnames = map name allpkgs \\ map name allcompatpkgs
incpkgs = filter (\p -> name p `elem` incnames) allpkgs
incpmods <- mapM (\p -> expMods p >>= return . showPkgLine p False)
(sortBy (\p1 p2 -> name p1 <= name p2) incpkgs)
let headline = ["Package name", "Version", "#modules", "Module", "..."]
writeCSVFile outFile (headline : allmods ++ incpmods)
putStrLn $ "\nPackage dependencies written to '" ++ outFile ++ "'"
cleanTempDir
where
outFile = "pkgmods.csv"
showPkgLine p cmpt mods = -- write a CSV line for a package
name p : withBrackets (showVersion (version p))
: show (length mods) : mods
where
withBrackets s = if cmpt then s else '(' : s ++ ")"
expMods p = do
putStr $ " " ++ name p
pkg <- fromEL $ readPackageFromRepository cfg p
let expmods = exportedModules pkg
if null expmods
then do pkgdir <- checkOutPkgInDir rcdefs (name p) (version p)
dirmods <- mapM curryModulesInDirectory
(map (pkgdir </>) (sourceDirsOf pkg))
return (concat dirmods)
else return expmods
checkOutPkgInDir :: [(String,String)] -> String -> Version -> IO String
checkOutPkgInDir rcdefs pname pvers = inTempDir $ do
cdir <- getCurrentDirectory
let cpmcall = cpmCall rcdefs
codir = cdir </> pname
cmd = unwords $
[ "rm -rf", codir, "&&"
, cpmcall, "-v quiet", "checkout", pname, showVersion pvers ]
putStr "*"
ecode <- system cmd
when (ecode>0) $
error $ "COULD NOT CHECKOUT PACKAGE '" ++ pname ++ "'!"
return codir
------------------------------------------------------------------------------
-- Copy all package documentations from directory `packagedocdir` into
-- the directory `currygleDocDir` so that the documentations
-- can be used by Currygle to generate the documentation index
copyPackageDocumentations :: Config -> String -> IO ()
copyPackageDocumentations cfg packagedocdir = do
allpkgs <- getAllPackages cfg
let pkgs = map sortVersions (groupBy (\a b -> name a == name b) allpkgs)
pkgids = sortBy (\xs ys -> head xs <= head ys) (map (map packageId) pkgs)
putStrLn $ "Number of package documentations: " ++ show (length pkgs)
recreateDirectory currygleDocDir
mapM_ copyPackageDoc pkgids
where
sortVersions ps = sortBy (\a b -> version a `vgt` version b) ps
copyPackageDoc [] = return ()
copyPackageDoc (pid:pids) = do
let pdir = packagedocdir </> pid
exdoc <- doesDirectoryExist pdir
if exdoc
then do putStrLn $ "Copying documentation of " ++ pid ++ "..."
copyDirectory pdir (currygleDocDir </> pid)
else
if null pids
then putStrLn $ "Documentation " ++ pid ++ " does not exist!"
else copyPackageDoc pids
------------------------------------------------------------------------------
--- Returns all packages where in each package
--- the name, version, dependencies, and compilerCompatibility is set.
getAllPackages :: Config -> IO [Package]
getAllPackages config = do
fromEL (getBaseRepository config >>= return . allPackages)
--- Reads to the .cpmrc file from the user's home directory and return
--- the configuration. Terminate in case of some errors.
readConfiguration :: [(String,String)] -> IO Config
readConfiguration rcdefs = do
c <- fromEL $ readConfigurationWith rcdefs
case c of
Left err -> do putStrLn $ "Error reading .cpmrc file: " ++ err
exitWith 1
Right c' -> return c'
--- Prints the current configuration.
printConfig :: Config -> IO ()
printConfig cfg = do
putStr $ unlines [banner, "Current configuration:", "", showConfiguration cfg]
(allpkgversions,allcompatpkgs) <- getAllPackageSpecs cfg True
putStrLn $ "\nNewest packages compatible to compiler version:\n" ++
unwords (map packageId allcompatpkgs)
let allpkgs = concatMap (take 1) allpkgversions
incnames = map name allpkgs \\ map name allcompatpkgs
putStrLn $ "\nPackages with incompatible compiler dependency:\n" ++
unwords (sort incnames)
--- Executes an IO action with the current directory set to a new empty
--- temporary directory. After the execution, the temporary directory
--- is deleted.
inEmptyTempDir :: IO a -> IO a
inEmptyTempDir a = do
tmp <- newTempDir
createDirectoryIfMissing True tmp
r <- inDirectory tmp a
removeDirectoryComplete tmp
return r
--- Returns a new temporary directory.
newTempDir :: IO String
newTempDir = do
t <- getTemporaryDirectory
pid <- getPID
getNewDir (t </> "cpm" ++ show pid) 0
where
getNewDir base i = do
let tmpdir = base ++ show i
exdir <- doesDirectoryExist tmpdir
if exdir then getNewDir base (i+1)
else return tmpdir
------------------------------------------------------------------------------
-- Generates a HTML representation of the contents of a directory.
directoryContentsPage :: (String,[BaseHtml]) -> String -> String -> IO String
directoryContentsPage homebrand base dir = do
maindoc <- directoryContentsAsHTML 1 base dir
subdirHtmlPage ("Browse " ++ dir) homebrand
[h1 [smallMutedText "Contents of ", htxt dir]] maindoc
-- Generates a HTML page in a subdirectory of CPM with a given page title,
-- home brand, header and contents.
subdirHtmlPage :: String -> (String,[BaseHtml]) -> [BaseHtml] -> [BaseHtml]
-> IO String
subdirHtmlPage pagetitle homebrand header maindoc = do
time <- getLocalTime
let btbase = "../bt4"
return $ showHtmlPage $
bootstrapPage (favIcon btbase) (cssIncludes btbase) (jsIncludes btbase)
pagetitle homebrand
(leftTopMenu True (-1)) rightTopMenu 0 []
header
maindoc (curryDocFooter time)
directoryContentsAsHTML :: Int -> String -> String -> IO [BaseHtml]
directoryContentsAsHTML d base dir = do
exdir <- doesDirectoryExist basedir
if exdir
then do
dirfiles <- getDirectoryContents basedir >>= return . filter isReal
if null dirfiles
then return []
else do
ls <- mapM dirElemAsHTML (sortBy (<=) dirfiles)
let (files,dirs) = partition (\hes -> length hes == 1) ls
return [ulist (files ++ dirs) `addAttr` ("style","list-style: none")]
else return []
where
basedir = base </> dir
dirElemAsHTML df = do
isdir <- doesDirectoryExist (basedir </> df)
if isdir && (d < 10) -- to avoid very deep (infinite) dir trees
then do subdir <- directoryContentsAsHTML (d+1) basedir df
return [code [htxt (df ++ "/")], block subdir]
else return [code [href (basedir </> df)
[htxt $ df ++ if isdir then "/" else ""]]]
isReal fn = not ("." `isPrefixOf` fn)
------------------------------------------------------------------------------
-- Generates the call to CPM where the given rc definitions are added.
cpmCall :: [(String,String)] -> String
cpmCall rcdefs =
"cypm" ++ concatMap (\ (k,v) -> " --define " ++ k ++ "=" ++ v) rcdefs
------------------------------------------------------------------------------
--- Transform an error logger action into a standard IO action.
fromEL :: ErrorLogger a -> IO a
fromEL = fromErrorLogger Info False
-- To show debug infos and timings, use:
--fromEL = fromErrorLogger Debug True
------------------------------------------------------------------------------
|