-------------------------------------------------------------------------------- --- This module contains some operations for processing packages, --- like installing package sources, cleaning packages, --- rendering package infos. -------------------------------------------------------------------------------- module CPM.Package.Helpers ( installPackageSourceTo , renderPackageInfo , cleanPackage , getLocalPackageSpec ) where import System.Directory import System.FilePath import System.Process ( getPID ) import Data.List ( intercalate, isSuffixOf, splitOn, nub ) import Control.Monad import Prelude hiding ( empty ) import System.CurryPath ( addCurrySubdir ) import Text.Pretty hiding ( () ) import CPM.Config ( Config(..), homePackageDir ) import CPM.ErrorLogger import CPM.Executables ( getCurlCmd ) import CPM.FileUtil ( cleanTempDir, getRealPath, inDirectory, inTempDir , quote, removeDirectoryComplete, tempDir , whenFileExists ) import CPM.Helpers ( stripSpaces ) import CPM.Package ------------------------------------------------------------------------------ --- Installs the source of the package from the given source location --- into the subdirectory `packageId pkg` of the given directory. installPackageSourceTo :: Package -> PackageSource -> String -> ErrorLogger () --- --- @param pkg - the package specification of the package --- @param source - the source of the package --- @param installdir - the directory where the package subdirectory should be --- installed installPackageSourceTo pkg (Git url rev) installdir = do let pkgDir = installdir pkgid c <- inDirectoryEL installdir $ execQuietCmd (cloneCommand "-q") (cloneCommand "") if c == 0 then case rev of Nothing -> checkoutGitRef pkgDir "HEAD" Just (Tag tag) -> checkoutGitRef pkgDir (replaceVersionInTag pkg tag) Just (Ref ref) -> checkoutGitRef pkgDir ref Just VersionAsTag -> let tag = "v" ++ (showVersion $ version pkg) in do checkoutGitRef pkgDir tag logInfo $ "Package '" ++ packageId pkg ++ "' installed" else liftIOEL (removeDirectoryComplete pkgDir) >> fail ("Failed to clone repository from '" ++ url ++ "', return code " ++ show c) where pkgid = packageId pkg cloneCommand q = unwords ["git clone", q, quote url, quote $ pkgid] installPackageSourceTo pkg (FileSource zipfile) installdir = installPkgFromFile pkg zipfile (installdir packageId pkg) False installPackageSourceTo pkg (Http url) installdir = do pid <- liftIOEL $ getPID let pkgDir = installdir packageId pkg basepf = "package" ++ show pid pkgfile = if takeExtension url == ".zip" then basepf ++ ".zip" else if ".tar.gz" `isSuffixOf` url then basepf ++ ".tar.gz" else "" if null pkgfile then fail $ "Illegal URL (only .zip or .tar.gz allowed):\n" ++ url else do tmpdir <- liftIOEL tempDir let tmppkgfile = tmpdir pkgfile curlcmd <- getCurlCmd c <- inTempDirEL $ showExecCmd $ curlcmd ++ " -f -o " ++ tmppkgfile ++ " " ++ quote url if c == 0 then installPkgFromFile pkg tmppkgfile pkgDir True else do liftIOEL cleanTempDir fail $ "`curl` failed with exit status " ++ show c --- Installs a package from a .zip or .tar.gz file into the specified --- package directory. If the last argument is true, the file will be --- deleted after unpacking. installPkgFromFile :: Package -> String -> String -> Bool -> ErrorLogger () installPkgFromFile pkg pkgfile pkgDir rmfile = do let iszip = takeExtension pkgfile == ".zip" absfile <- liftIOEL $ getRealPath pkgfile liftIOEL $ createDirectory pkgDir c <- if iszip then inTempDirEL $ showExecCmd $ "unzip -qq -d " ++ quote pkgDir ++ " " ++ quote absfile else inDirectoryEL pkgDir $ showExecCmd $ "tar -xzf " ++ quote absfile when rmfile (showExecCmd ("rm -f " ++ absfile) >> return ()) liftIOEL cleanTempDir if c == 0 then logInfo $ "Installed " ++ packageId pkg else do liftIOEL $ removeDirectoryComplete pkgDir fail ("Failed to unzip package, return code " ++ show c) --- Checks out a specific ref of a Git repository and deletes --- the Git auxiliary files (i.e., `.git` and `.gitignore`). --- --- @param dir - the directory containing the repo --- @param ref - the ref to check out checkoutGitRef :: String -> String -> ErrorLogger () checkoutGitRef dir ref = do let qcmd q = unwords ["git checkout", q, ref] c <- inDirectoryEL dir $ execQuietCmd (qcmd "-q") (qcmd "") if c == 0 then liftIOEL removeGitFiles >> return () else liftIOEL (removeDirectoryComplete dir) >> fail ("Failed to check out " ++ ref ++ ", return code " ++ show c) where removeGitFiles = do removeDirectoryComplete (dir ".git") let gitignore = dir ".gitignore" whenFileExists gitignore (removeFile gitignore) ------------------------------------------------------------------------------ --- Cleans auxiliary files in the local package, i.e., the package --- containing the current working directory. cleanPackage :: Config -> LogLevel -> ErrorLogger () cleanPackage cfg ll = do specDir <- getLocalPackageSpec cfg "." pkg <- loadPackageSpec specDir let dotcpm = specDir ".cpm" srcdirs = map (specDir ) (sourceDirsOf pkg) testdirs = map (specDir ) (maybe [] (map (\ (PackageTest m _ _ _) -> m)) (testSuite pkg)) rmdirs = nub (dotcpm : map ( compilerSubdir) (srcdirs ++ testdirs)) logAt ll $ "Removing directories: " ++ unwords rmdirs showExecCmd (unwords $ ["rm", "-rf"] ++ rmdirs) return () where --- Name of the sub directory where auxiliary files (.fint, .fcy, etc) --- are stored, e.g., ".curry/pakcs-3.4.0". compilerSubdir = let (cname,cmaj,cmin,crev) = compilerVersion cfg in ".curry" cname ++ '-' : intercalate "." (map show [cmaj, cmin, crev]) ------------------------------------------------------------------------------ --- Renders information about a package. renderPackageInfo :: Bool -> Bool -> Bool -> Package -> String renderPackageInfo allinfos plain installed pkg = pPrint doc where boldText s = (if plain then id else bold) $ text s maxLen = 12 doc = vcat $ [ heading, rule , if allinfos then instTxt installed else empty , ver, auth, maintnr, synop , cats, deps, compilers, descr ] ++ execspecs ++ if allinfos then [ srcdirs, expmods, cfgmod ] ++ testsuites ++ [ docuspec, src, licns, licfl, copyrt, homepg , reposy, bugrep ] else [] pkgId = packageId pkg heading = text pkgId instTxt i = if i || plain then empty else red $ text "Not installed" rule = text (take (length pkgId) $ repeat '-') ver = fill maxLen (boldText "Version") <+> (text $ showVersion $ version pkg) auth = fill maxLen (boldText "Author") <+> indent 0 (fillSep (map (text . stripSpaces) (concatMap (splitOn ",") $ author pkg))) synop = fill maxLen (boldText "Synopsis") <+> indent 0 (fillSep (map text (words (synopsis pkg)))) deps = boldText "Dependencies" <$$> (vcat $ map (indent 4 . text . showDependency) $ dependencies pkg) maintnr = case maintainer pkg of [] -> empty xs -> fill maxLen (boldText "Maintainer") <+> indent 0 (fillSep (map (text . stripSpaces) (concatMap (splitOn ",") xs))) cats = if null (category pkg) then empty else fill maxLen (boldText "Category") <+> indent 0 (fillSep (map text (category pkg))) execspecs = map showExec (executableSpec pkg) where showExec (PackageExecutable n m eopts) = if allinfos then boldText "Executable" <$$> indent 4 (boldText "Name " <+> text n) <$$> indent 4 (boldText "Main module " <+> text m) <$$> if null eopts then empty else indent 4 (boldText "Options ") <+> align (vsep (map (\ (c,o) -> text $ c ++ ": " ++ o) eopts)) else fill maxLen (boldText "Executable") <+> text n testsuites = case testSuite pkg of Nothing -> [] Just tests -> map (\ (PackageTest dir mods opts script) -> let check = if null script then "Check" else "Test" in boldText "Test suite" <$$> indent 4 (boldText "Directory " <+> text dir) <$$> (if null script then empty else indent 4 (boldText "Test script " <+> text script)) <$$> (if null opts then empty else indent 4 (boldText (check++" options") <+> text opts)) <$$> (if null mods then empty else indent 4 (boldText "Test modules " <+> align (fillSep (map text mods))))) tests docuspec = case documentation pkg of Nothing -> empty Just (PackageDocumentation docdir docmain doccmd) -> boldText "Documentation" <$$> indent 4 (boldText "Directory " <+> text docdir) <$$> indent 4 (boldText "Main file " <+> text docmain) <$$> if null doccmd then empty else indent 4 (boldText "Command ") <+> text doccmd descr = showParaField description "Description" licns = showLineField license "License" licfl = showLineField licenseFile "License file" copyrt = showParaField copyright "Copyright" homepg = showLineField homepage "Homepage" reposy = showLineField repository "Repository" bugrep = showLineField bugReports "Bug reports" cfgmod = showLineField configModule "Config module" src = maybe empty (\_ -> boldText "Source" <$$> indent 4 (text $ showSourceOfPackage pkg)) (source pkg) srcdirs = if null (sourceDirs pkg) then empty else boldText "Source directories" <$$> indent 4 (fillSep (map text (sourceDirs pkg))) expmods = if null (exportedModules pkg) then empty else boldText "Exported modules" <$$> indent 4 (fillSep (map text (exportedModules pkg))) compilers = if null (compilerCompatibility pkg) then empty else boldText "Compiler compatibility" <$$> (vcat $ map (indent 4 . text . showCompilerDependency) $ compilerCompatibility pkg) showLineField fgetter fname = case fgetter pkg of Nothing -> empty Just s -> boldText fname <$$> indent 4 (text s) showParaField fgetter fname = case fgetter pkg of Nothing -> empty Just s -> boldText fname <$$> indent 4 (fillSep (map text (words s))) ------------------------------------------------------------------------------ --- Tries to find a package specification in the given directory or one of its --- ancestors. If there is no package specifiction in these directories, --- the home package specification (i.e., `~/.cpm/...-homepackage/package.json` --- is returned (and created if it does not exist). --- In order to avoid infinite loops due to cyclic file structures, --- the search is limited to the number of directories occurring in the --- current absolute path. getLocalPackageSpec :: Config -> String -> ErrorLogger String getLocalPackageSpec cfg dir = do adir <- liftIOEL $ getRealPath dir spec <- searchLocalSpec (length (splitPath adir)) dir maybe returnHomePackage return spec where returnHomePackage = do let homepkgdir = homePackageDir cfg homepkgspec = homepkgdir packageSpecFile specexists <- liftIOEL $ doesFileExist homepkgspec unless (specexists || null homepkgdir) $ do liftIOEL $ createDirectoryIfMissing True homepkgdir let newpkg = emptyPackage { name = snd (splitFileName homepkgdir) , version = initialVersion , author = ["CPM"] , synopsis = "Default home package" , dependencies = [] } liftIOEL $ writePackageSpec newpkg homepkgspec logInfo $ "New empty package specification '" ++ homepkgspec ++ "' generated" return homepkgdir searchLocalSpec m sdir = do existsLocal <- liftIOEL $ doesFileExist $ sdir packageSpecFile if existsLocal then return (Just sdir) else do logDebug ("No package.json in " ++ show sdir ++ ", trying " ++ show (sdir "..")) parentExists <- liftIOEL $ doesDirectoryExist $ sdir ".." if m>0 && parentExists then searchLocalSpec (m-1) $ sdir ".." else return Nothing ------------------------------------------------------------------------------