|
sourcecode:
|
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, compilerBaseVersion )
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))
cldirs = nub (dotcpm : map (</> compilerSubdir) (srcdirs ++ testdirs))
rmdirs <- filterM (liftIOEL . doesDirectoryExist) cldirs
unless (null rmdirs) $ do
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.6.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
let basedeps = maybe []
(\v -> [Dependency "base" [[VMajCompatible v]]])
(readVersion (compilerBaseVersion cfg))
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 = basedeps
}
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
------------------------------------------------------------------------------
|