------------------------------------------------------------------------------ --- This module implements tools to manage the central repository: --- --- Run "cpm-manage -h" to see all options. --- ------------------------------------------------------------------------------ module CPM.Manage ( main ) where import Directory ( copyFile, doesFileExist, doesDirectoryExist , createDirectoryIfMissing, getCurrentDirectory ) import FilePath ( (), replaceExtension ) import IOExts ( evalCmd ) import List ( findIndex, nub, replace, sortBy, sum, union ) import System ( getArgs, exitWith, system ) import Time ( getLocalTime, toDayString ) import CPM.Config ( Config, repositoryDir, packageInstallDir , readConfigurationWith ) import CPM.ErrorLogger import CPM.FileUtil ( inDirectory, inTempDir, recreateDirectory ) import CPM.Package import CPM.PackageCopy ( renderPackageInfo ) import CPM.Repository ( allPackages, listPackages, readRepository , readPackageFromRepository, cleanRepositoryCache ) import CPM.Resolution ( isCompatibleToCompiler ) import HTML.Base import ShowDotGraph --- Base URL of CPM documentations cpmBaseURL :: String cpmBaseURL = "http://www.informatik.uni-kiel.de/~curry/cpm/DOC/" --- Directory of CPM documentations cpmHtmlDir :: String cpmHtmlDir = "/net/medoc/home/mh/public_html/curry/cpm" main :: IO () main = do args <- getArgs case args of ["genhtml"] -> writeAllPackagesAsHTML ["gendocs"] -> generateDocsOfAllPackages ["testall"] -> testAllPackages ["add"] -> addNewPackage ["update"] -> updatePackage ["showgraph"] -> showAllPackageDependencies ["--help"] -> putStrLn helpText ["-h"] -> putStrLn helpText _ -> do putStrLn $ "Wrong arguments!\n\n" ++ helpText exitWith 1 helpText :: String helpText = unlines $ [ "Options:", "" , "add : add this package version to the central repository" , "update : tag git repository of local package with current version" , " and update central index with current package specification" , "genhtml : generate HTML pages of central repository (in directory" , " '" ++ cpmHtmlDir ++ "')" , "gendocs : generate HTML documentations of all packages (in directory" , " '" ++ cpmHtmlDir "DOC" ++ "')" , "testall : test all packages of the central repository" , "showgraph : visualize all package dependencies as dot graph" ] ------------------------------------------------------------------------------ --- Get all packages. For each package, get the newest version compatible --- to the current compiler. If there is no compatible version and the --- first argument is False, get the newest version, otherwise the package --- is ignored. getAllPackageSpecs :: Bool -> IO (Config,[Package]) getAllPackageSpecs compat = do config <- readConfigurationWith [] >>= \c -> case c of Left err -> do putStrLn $ "Error reading .cpmrc settings: " ++ err exitWith 1 Right c' -> return c' putStrLn "Reading repository..." repo <- readRepository config True let allpkgs = sortBy (\ps1 ps2 -> name ps1 <= name ps2) (concatMap (filterCompatPkgs config) (listPackages repo)) return (config,allpkgs) 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 web pages of the central repository writeAllPackagesAsHTML :: IO () writeAllPackagesAsHTML = inDirectory cpmHtmlDir $ do (config,repopkgs) <- getAllPackageSpecs False putStrLn "Reading all package specifications..." allpkgs <- mapIO (fromErrorLogger . readPackageFromRepository config) repopkgs let indexfile = "index.html" ltime <- getLocalTime putStrLn $ "Writing '" ++ indexfile ++ "'..." writeReadableFile indexfile $ showHtmlPage $ cpmHtmlPage "Curry Packages in the CPM Repository" $ [h1 [htxt "Curry Packages in the ", href "http://www.curry-language.org/tools/cpm" [htxt "CPM"] `addAttr` ("target","_blank"), htxt $ " Repository (" ++ toDayString ltime ++ ")"], packageInfosAsHtmlTable allpkgs] mapIO_ writePackageAsHTML allpkgs system "rm -f allpkgs.csv" >> done where writePackageAsHTML pkg = do let pname = name pkg htmlfile = pname ++ ".html" putStrLn $ "Writing '" ++ htmlfile ++ "'..." let pkginfo = renderPackageInfo True True True pkg manref = manualRef pkg False writeReadableFile htmlfile $ showHtmlPage $ cpmTitledHtmlPage ("Curry Package '"++pname++"'") $ [blockstyle "reference" $ apiRef pkg False] ++ (if null manref then [] else [blockstyle "reference" manref]) ++ [blockstyle "metadata" [h3 [htxt "Package metadata:"], verbatim pkginfo]] --- Writes a file readable for all: writeReadableFile :: String -> String -> IO () writeReadableFile f s = writeFile f s >> system ("chmod 644 " ++ f) >> done --- API reference of a package: apiRef :: Package -> Bool -> [HtmlExp] apiRef pkg small = let title = if small then "API" else "API documentation" addArrow he = if small then he else addClass he "arrow" in [addArrow $ href (cpmBaseURL ++ packageId pkg) [htxt title]] --- Manual reference of a package: manualRef :: Package -> Bool -> [HtmlExp] manualRef pkg small = let title = if small then "PDF" else "Manual (PDF)" addArrow he = if small then he else addClass he "arrow" in case documentation pkg of Nothing -> [] Just (PackageDocumentation _ docmain _) -> [addArrow $ href (cpmBaseURL ++ packageId pkg replaceExtension docmain ".pdf") [htxt title]] -- Format a list of packages as an HTML table packageInfosAsHtmlTable :: [Package] -> HtmlExp packageInfosAsHtmlTable pkgs = headedTable $ [map ((:[]) . htxt) ["Name", "API", "Doc","Executable","Synopsis", "Version"] ] ++ map formatPkg pkgs where formatPkg pkg = [ [href (name pkg ++ ".html") [htxt $ name pkg]] , apiRef pkg True , let manref = manualRef pkg True in if null manref then [nbsp] else manref , [htxt $ maybe "" (\ (PackageExecutable n _ _) -> n) (executableSpec pkg)] , [htxt $ synopsis pkg] , [htxt $ showVersion (version pkg)] ] --- Standard HTML page with a title for CPM generated docs. cpmHtmlPage :: String -> [HtmlExp] -> HtmlPage cpmHtmlPage title hexps = page title hexps `addPageParam` pageCSS "css/cpm.css" --- Standard HTML page with a title (included in the body) --- for CPM generated docs: cpmTitledHtmlPage :: String -> [HtmlExp] -> HtmlPage cpmTitledHtmlPage title hexps = cpmHtmlPage title (h1 [htxt title] : hexps) ------------------------------------------------------------------------------ -- Generate HTML documentation of all packages in the central repository generateDocsOfAllPackages :: IO () generateDocsOfAllPackages = do (_,allpkgs) <- getAllPackageSpecs True mapIO_ genDocOfPackage allpkgs system "rm -f allpkgs.csv" >> done where genDocOfPackage pkg = inTempDir $ do let pname = name pkg pversion = showVersion (version pkg) putStrLn $ unlines [dline, "Documenting: " ++ pname, dline] let cmd = unwords [ "rm -rf", pname, "&&" , "cypm","checkout", pname, pversion, "&&" , "cd", pname, "&&" , "cypm", "install", "--noexec", "&&" , "cypm", "doc", "--docdir", cpmHtmlDir "DOC" , "--url", cpmBaseURL, "&&" , "cd ..", "&&" , "rm -rf", pname ] putStrLn $ "CMD: " ++ cmd system cmd ------------------------------------------------------------------------------ -- Run `cypm test` on all packages of the central repository testAllPackages :: IO () testAllPackages = do (_,allpkgs) <- getAllPackageSpecs True results <- mapIO checkoutAndTestPackage allpkgs if sum (map fst results) == 0 then putStrLn $ show (length allpkgs) ++ " PACKAGES SUCCESSFULLY TESTED!" else do putStrLn $ "ERRORS OCCURRED IN PACKAGES: " ++ unwords (map snd (filter ((> 0) . fst) results)) exitWith 1 system "rm -f allpkgs.csv" >> done dline :: String dline = take 78 (repeat '=') ------------------------------------------------------------------------------ -- Add a new package where the name of the package description file -- is given as a parameter. addNewPackage :: IO () addNewPackage = do config <- readConfigurationWith [] >>= \c -> case c of Left err -> do putStrLn $ "Error reading .cpmrc file: " ++ err exitWith 1 Right c' -> return c' pkg <- fromErrorLogger (loadPackageSpec ".") setTagInGit pkg let pkgName = name pkg pkgVersion = version pkg pkgIndexDir = pkgName showVersion pkgVersion pkgRepositoryDir = repositoryDir config pkgIndexDir expkgdir <- doesDirectoryExist pkgRepositoryDir when expkgdir (error $ "Package repository directory '" ++ pkgRepositoryDir ++ "' already exists!") putStrLn $ "Create directory: " ++ pkgRepositoryDir createDirectoryIfMissing True pkgRepositoryDir copyFile packageSpecFile (pkgRepositoryDir packageSpecFile) cleanRepositoryCache config putStrLn $ "Package repository directory '" ++ pkgRepositoryDir ++ "' added." (ecode,_) <- checkoutAndTestPackage pkg when (ecode>0) $ do system $ "rm -rf " ++ pkgRepositoryDir system $ "rm -rf " ++ packageInstallDir config packageId pkg cleanRepositoryCache config putStrLn "Unable to checkout, package deleted in repository directory!" exitWith 1 putStrLn $ "\nEverything looks fine..." putStrLn $ "\nTo publish the new repository directory, run command:\n" putStrLn $ "pushd " ++ repositoryDir config ++ " && git add " ++ pkgIndexDir packageSpecFile ++ " && git commit -m\"" ++ pkgIndexDir ++ " added\" " ++ " && git push origin master && popd" -- Test a specific version of a package by checking it out in temp dir, -- 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 :: Package -> IO (Int,String) checkoutAndTestPackage pkg = do -- create installation bin dir: curdir <- inTempDir getCurrentDirectory let bindir = curdir "pkgbin" recreateDirectory bindir let pkgname = name pkg pkgversion = version pkg pkgid = packageId pkg putStrLn $ unlines [dline, "Testing package: " ++ pkgid, dline] let checkoutdir = pkgname cmd = unwords [ "rm -rf", checkoutdir, "&&" , "cypm", "checkout", pkgname, showVersion pkgversion, "&&" , "cd", checkoutdir, "&&" -- install possible binaries in bindir: , "cypm", "-d bin_install_path="++bindir, "install", "&&" , "export PATH="++bindir++":$PATH", "&&" , "cypm", "test", "&&" , "cypm", "-d bin_install_path="++bindir, "uninstall" ] putStrLn $ "...with command:\n" ++ cmd ecode <- inTempDir $ system cmd inTempDir (system $ unwords ["rm -rf ", checkoutdir, bindir]) when (ecode>0) $ putStrLn $ "ERROR OCCURED IN PACKAGE '"++pkgid++ "'!" return (ecode,pkgid) -- Set the package version as a tag in the git repository. setTagInGit :: Package -> IO () setTagInGit pkg = do let ts = 'v' : showVersion (version pkg) (_,gittag,_) <- evalCmd "git" ["tag","-l",ts] "" let deltag = if null gittag then [] else ["git tag -d",ts,"&&"] cmd = unwords $ deltag ++ ["git tag -a",ts,"-m",ts,"&&", "git push --tags -f"] putStrLn $ "Execute: " ++ cmd ecode <- system cmd when (ecode > 0) $ error "ERROR in setting the git tag" ------------------------------------------------------------------------------ -- Re-tag the current git version with the current package version -- and copy the package spec file to the cpm index updatePackage :: IO () updatePackage = do config <- readConfigurationWith [] >>= \c -> case c of Left err -> do putStrLn $ "Error reading .cpmrc file: " ++ err exitWith 1 Right c' -> return c' pkg <- fromErrorLogger (loadPackageSpec ".") let pkgIndexDir = name pkg showVersion (version pkg) pkgRepositoryDir = repositoryDir config pkgIndexDir pkgInstallDir = packageInstallDir config packageId pkg setTagInGit pkg putStrLn $ "Deleting old repo copy '" ++ pkgInstallDir ++ "'..." system $ "rm -rf " ++ pkgInstallDir (ecode,_) <- checkoutAndTestPackage pkg when (ecode > 0) $ do putStrLn $ "ERROR in package, CPM index not updated!" exitWith 1 let cmd = unwords ["cp -f", packageSpecFile, pkgRepositoryDir packageSpecFile] putStrLn $ "Execute: " ++ cmd system cmd cleanRepositoryCache config ------------------------------------------------------------------------------ -- Show package dependencies as graph showAllPackageDependencies :: IO () showAllPackageDependencies = do config <- readConfigurationWith [] >>= \c -> case c of Left err -> do putStrLn $ "Error reading .cpmrc file: " ++ err exitWith 1 Right c' -> return c' pkgs <- readRepository config False >>= return . allPackages let alldeps = map (\p -> (name p, map (\ (Dependency p' _) -> p') (dependencies p))) pkgs dotgraph = depsToGraph alldeps putStrLn $ "Show dot graph..." viewDotGraph dotgraph depsToGraph :: [(String, [String])] -> DotGraph depsToGraph cpmdeps = Graph "CPM Dependencies" (map (\s -> Node s []) (nub (map fst cpmdeps ++ concatMap snd cpmdeps))) (map (\ (s,t) -> Edge s t []) (nub (concatMap (\ (p,ds) -> map (\d -> (p,d)) ds) cpmdeps))) ------------------------------------------------------------------------------ -- The name of the package specification file. packageSpecFile :: String packageSpecFile = "package.json" ------------------------------------------------------------------------------