Commit f88dd57b authored by Michael Hanus 's avatar Michael Hanus

CPM updated (for faster `update` operation)

parent 782469aa
......@@ -35,7 +35,8 @@ import CPM.FileUtil ( joinSearchPath, safeReadFile, whenFileExists
import CPM.Config ( Config (..)
, readConfigurationWith, showCompilerVersion
, showConfiguration )
import CPM.PackageCache.Global ( GlobalCache, readGlobalCache, allPackages
import CPM.PackageCache.Global ( acquireAndInstallPackage
, GlobalCache, readGlobalCache, allPackages
, installFromZip, checkoutPackage
, uninstallPackage, packageInstalled )
import CPM.Package
......@@ -59,7 +60,7 @@ cpmBanner :: String
cpmBanner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText =
"Curry Package Manager <curry-language.org/tools/cpm> (version of 24/04/2019)"
"Curry Package Manager <curry-language.org/tools/cpm> (version of 13/06/2019)"
bannerLine = take (length bannerText) (repeat '-')
main :: IO ()
......@@ -211,8 +212,10 @@ data NewOptions = NewOptions
{ projectName :: String }
data UpdateOptions = UpdateOptions
{ indexURLs :: [String] -- the URLs of additional index repositories
, cleanCache :: Bool -- clean also repository cache?
{ indexURLs :: [String] -- the URLs of additional index repositories
, cleanCache :: Bool -- clean also repository cache?
, downloadIndex :: Bool -- download the index repository?
, writeCSV :: Bool -- write also a CSV file of the repository DB?
}
data UploadOptions = UploadOptions
......@@ -310,7 +313,7 @@ newOpts s = case optCommand s of
updateOpts :: Options -> UpdateOptions
updateOpts s = case optCommand s of
Update opts -> opts
_ -> UpdateOptions [] True
_ -> UpdateOptions [] True True False
uploadOpts :: Options -> UploadOptions
uploadOpts s = case optCommand s of
......@@ -559,6 +562,16 @@ optionParser allargs = optParser
( short "c"
<> long "cache"
<> help "Do not clean global package cache" )
<.> flag (\a -> Right $ a { optCommand = Update (updateOpts a)
{ downloadIndex = False } })
( short "d"
<> long "download"
<> help "Do not download the global repository index" )
<.> flag (\a -> Right $ a { optCommand = Update (updateOpts a)
{ writeCSV = True } })
( short "w"
<> long "writecsv"
<> help "Write also a CSV file of the cache database" )
uploadArgs =
flag (\a -> Right $ a { optCommand =
......@@ -809,7 +822,8 @@ updateCmd opts cfg = do
then cfg
else cfg { packageIndexURL = head (indexURLs opts) }
-- TODO: allow merging from several package indices
checkRequiredExecutables >> updateRepository cfg' (cleanCache opts)
checkRequiredExecutables
updateRepository cfg' (cleanCache opts) (downloadIndex opts) (writeCSV opts)
------------------------------------------------------------------------------
-- `deps` command:
......@@ -872,7 +886,7 @@ checkoutCmd (CheckoutOptions pkgname (Just ver) _) cfg =
getRepoForPackages cfg [pkgname] >>= \repo ->
case findVersion repo pkgname ver of
Nothing -> packageNotFoundFailure $ pkgname ++ "-" ++ showVersion ver
Just p -> acquireAndInstallPackageWithDependencies cfg repo p |>
Just p -> acquireAndInstallPackage cfg p |>
checkoutPackage cfg p
installCmd :: InstallOptions -> Config -> IO (ErrorLogger ())
......
......@@ -13,7 +13,7 @@ module CPM.Package.Helpers
import Directory
import FilePath
import List ( splitOn, nub )
import List ( isSuffixOf, nub, splitOn )
import System ( getPID )
import System.CurryPath ( addCurrySubdir )
......@@ -63,9 +63,11 @@ installPackageSourceTo pkg (Http url) installdir = do
pid <- getPID
let pkgDir = installdir </> packageId pkg
basepf = "package" ++ show pid
revurl = reverse url
pkgfile = if take 4 revurl == "piz." then basepf ++ ".zip" else
if take 7 revurl == "zg.rat." then basepf ++ ".tar.gz" else ""
pkgfile = if takeExtension url == ".zip"
then basepf ++ ".zip"
else if ".tar.gz" `isSuffixOf` url
then basepf ++ ".tar.gz"
else ""
if null pkgfile
then failIO $ "Illegal URL (only .zip or .tar.gz allowed):\n" ++ url
else do
......@@ -82,7 +84,7 @@ installPackageSourceTo pkg (Http url) installdir = do
--- deleted after unpacking.
installPkgFromFile :: Package -> String -> String -> Bool -> IO (ErrorLogger ())
installPkgFromFile pkg pkgfile pkgDir rmfile = do
let iszip = take 4 (reverse pkgfile) == "piz."
let iszip = takeExtension pkgfile == ".zip"
absfile <- getAbsolutePath pkgfile
createDirectory pkgDir
c <- if iszip
......
......@@ -2,14 +2,14 @@
--- Operations to initialize and manipulate the repository cache database.
---
--- @author Michael Hanus
--- @version March 2018
--- @version June 2019
------------------------------------------------------------------------------
module CPM.Repository.CacheDB
( repositoryCacheDB, tryWriteRepositoryDB, addPackagesToRepositoryDB )
where
import Directory ( removeFile )
import Directory ( doesFileExist, removeFile )
import FilePath ( (</>) )
import IO ( hFlush, stdout )
import ReadShowTerm
......@@ -17,10 +17,12 @@ import ReadShowTerm
import Database.CDBI.ER
import Database.CDBI.Connection
import System.Path ( fileInPath )
import Text.CSV
import CPM.Config ( Config, readConfigurationWith, repositoryDir )
import CPM.Config ( Config, packageTarFilesURL, readConfigurationWith
, repositoryDir )
import CPM.ErrorLogger
import CPM.FileUtil ( whenFileExists )
import CPM.FileUtil ( inTempDir, quote, tempDir, whenFileExists )
import CPM.Repository.RepositoryDB
import CPM.Package
import CPM.Repository
......@@ -29,31 +31,56 @@ import CPM.Repository
repositoryCacheDB :: Config -> String
repositoryCacheDB cfg = repositoryCacheFilePrefix cfg ++ ".db"
--- The database containing the repository cache.
repositoryCacheCSV :: Config -> String
repositoryCacheCSV cfg = repositoryCacheFilePrefix cfg ++ ".csv"
--- Writes the repository database with the current repository index
--- if the command `sqlite3` is in the path.
tryWriteRepositoryDB :: Config -> IO (ErrorLogger ())
tryWriteRepositoryDB cfg = do
tryWriteRepositoryDB :: Config -> Bool -> IO (ErrorLogger ())
tryWriteRepositoryDB cfg writecsv = do
withsqlite <- fileInPath "sqlite3"
if withsqlite
then writeRepositoryDB cfg
then writeRepositoryDB cfg writecsv
else log Info
"Command 'sqlite3' not found: install package 'sqlite3' to speed up CPM"
--- Writes the repository database with the current repository index.
writeRepositoryDB :: Config -> IO (ErrorLogger ())
writeRepositoryDB cfg = do
--- If the second argument is `True`, also a CSV file containing the
--- database entries is written.
writeRepositoryDB :: Config -> Bool -> IO (ErrorLogger ())
writeRepositoryDB cfg writecsv = do
let sqlitefile = repositoryCacheDB cfg
whenFileExists sqlitefile (removeFile sqlitefile)
createNewDB sqlitefile
repo <- readRepositoryFrom (repositoryDir cfg)
debugMessage $ "Writing repository cache DB '" ++ sqlitefile ++ "'"
tmpdir <- tempDir
let csvfile = tmpdir </> "cachedb.csv"
csvurl = packageTarFilesURL cfg ++ "/REPOSITORY_CACHE.csv"
showExecCmd $ "/bin/rm -f " ++ csvfile
c <- inTempDir $ showExecCmd $
"curl -f -s -o " ++ csvfile ++ " " ++ quote csvurl
csvexists <- doesFileExist csvfile
pkgentries <- if c == 0 && csvexists
then do
debugMessage $ "Reading CSV file '" ++ csvfile ++ "'..."
readCSVFile csvfile >>= return . map Right
else do
debugMessage $ "Fetching repository cache CSV file failed"
repo <- readRepositoryFrom (repositoryDir cfg)
return (map Left (allPackages repo))
putStr "Writing repository cache DB"
addPackagesToRepositoryDB cfg False (allPackages repo)
addPackagesToRepositoryDB cfg False pkgentries
putChar '\n'
log Info "Repository cache DB written"
showExecCmd $ "/bin/rm -f " ++ csvfile
if writecsv then saveDBAsCSV cfg
else succeedIO ()
-- Add a list of package specifications to the database.
addPackagesToRepositoryDB :: Config -> Bool -> [Package] -> IO (ErrorLogger ())
--- Add a list of package descriptions to the database.
--- Here, a package description is either a (reduced) package specification
--- or a list of string (a row from a CSV file) containing the required infos.
addPackagesToRepositoryDB :: Config -> Bool
-> [Either Package [String]] -> IO (ErrorLogger ())
addPackagesToRepositoryDB cfg quiet pkgs =
mapEL (runDBAction . newEntry) pkgs |> succeedIO ()
where
......@@ -64,7 +91,7 @@ addPackagesToRepositoryDB cfg quiet pkgs =
show kind ++ " " ++ str
Right _ -> (unless quiet $ putChar '.' >> hFlush stdout) >> succeedIO ()
newEntry p = newIndexEntry
newEntry (Left p) = newIndexEntry
(name p)
(showTerm (version p))
(showTerm (dependencies p))
......@@ -74,3 +101,22 @@ addPackagesToRepositoryDB cfg quiet pkgs =
(showTerm (sourceDirs p))
(showTerm (exportedModules p))
(showTerm (executableSpec p))
newEntry (Right [pn,pv,deps,cc,syn,cat,dirs,mods,exe]) =
newIndexEntry pn pv deps cc syn cat dirs mods exe
--- Saves complete database as term files into an existing directory
--- provided as a parameter.
saveDBAsCSV :: Config -> IO (ErrorLogger ())
saveDBAsCSV cfg = do
result <- runWithDB (repositoryCacheDB cfg)
(getAllEntries indexEntry_CDBI_Description)
case result of
Left (DBError kind str) -> log Critical $ "Repository DB failure: " ++
show kind ++ " " ++ str
Right es -> do let csvfile = repositoryCacheCSV cfg
writeCSVFile csvfile (map showIndexEntry es)
log Info ("CSV file '" ++ csvfile ++ "' written!")
where
showIndexEntry (IndexEntry _ pn pv deps cc syn cat dirs mods exe) =
[pn,pv,deps,cc,syn,cat,dirs,mods,exe]
......@@ -18,7 +18,9 @@ after its generation:
(also in `RepositoryDB_SQLCode.info`).
The actual database queries are defined in the module
`CPM.Repository.Select`.
CPM.Repository.Select
Since these queries are defined as embedded SQL code which requires
the Curry preprocessor to translate them, the distribution of CPM
contains the already preprocessed module whereas the original
......
--- This file has been generated from
---
--- cpm/src/CPM/Repository/RepositoryDB.erdterm
--- cpm/src/CPM/Repository/IndexDB_ERD.curry
---
--- and contains definitions for all entities and relations
--- specified in this model.
......
......@@ -265,7 +265,7 @@ pkgRead = readUnqualifiedTerm ["CPM.Package","Prelude"]
addPackageToRepositoryCache :: Config -> Package -> IO (ErrorLogger ())
addPackageToRepositoryCache cfg pkg = do
dbexists <- doesFileExist (repositoryCacheDB cfg)
if dbexists then addPackagesToRepositoryDB cfg True [pkg]
if dbexists then addPackagesToRepositoryDB cfg True [Left pkg]
else cleanRepositoryCache cfg >> succeedIO ()
--- Updates an existing package in the repository cache.
......@@ -274,7 +274,7 @@ updatePackageInRepositoryCache :: Config -> Package -> IO (ErrorLogger ())
updatePackageInRepositoryCache cfg pkg = do
dbexists <- doesFileExist (repositoryCacheDB cfg)
if dbexists then removePackageFromRepositoryDB cfg pkg >>
addPackagesToRepositoryDB cfg True [pkg]
addPackagesToRepositoryDB cfg True [Left pkg]
else cleanRepositoryCache cfg >> succeedIO ()
--- Removes a package from the repository cache DB.
......
......@@ -265,7 +265,7 @@ pkgRead = readUnqualifiedTerm ["CPM.Package","Prelude"]
addPackageToRepositoryCache :: Config -> Package -> IO (ErrorLogger ())
addPackageToRepositoryCache cfg pkg = do
dbexists <- doesFileExist (repositoryCacheDB cfg)
if dbexists then addPackagesToRepositoryDB cfg True [pkg]
if dbexists then addPackagesToRepositoryDB cfg True [Left pkg]
else cleanRepositoryCache cfg >> succeedIO ()
--- Updates an existing package in the repository cache.
......@@ -274,7 +274,7 @@ updatePackageInRepositoryCache :: Config -> Package -> IO (ErrorLogger ())
updatePackageInRepositoryCache cfg pkg = do
dbexists <- doesFileExist (repositoryCacheDB cfg)
if dbexists then removePackageFromRepositoryDB cfg pkg >>
addPackagesToRepositoryDB cfg True [pkg]
addPackagesToRepositoryDB cfg True [Left pkg]
else cleanRepositoryCache cfg >> succeedIO ()
--- Removes a package from the repository cache DB.
......
......@@ -30,19 +30,26 @@ import CPM.Repository.Select ( addPackageToRepositoryCache
--- Updates the package index from the central Git repository.
--- If the second argument is `True`, also the global package cache
--- is cleaned in order to support downloading the newest versions.
updateRepository :: Config -> Bool -> IO (ErrorLogger ())
updateRepository cfg cleancache = do
--- If the third argument is `True`, the global package index is downloaded
--- from the central repository.
--- If the fourth argument is `True`, also a CSV file containing the
--- database entries is written.
updateRepository :: Config -> Bool -> Bool -> Bool -> IO (ErrorLogger ())
updateRepository cfg cleancache download writecsv = do
cleanRepositoryCache cfg
when cleancache $ do
debugMessage $ "Deleting global package cache: '" ++
packageInstallDir cfg ++ "'"
removeDirectoryComplete (packageInstallDir cfg)
debugMessage $ "Recreating package index: '" ++ repositoryDir cfg ++ "'"
recreateDirectory (repositoryDir cfg)
c <- inDirectory (repositoryDir cfg) downloadCommand
if c == 0
then finishUpdate
else failIO $ "Failed to update package index, return code " ++ show c
if download
then do
recreateDirectory (repositoryDir cfg)
c <- inDirectory (repositoryDir cfg) downloadCommand
if c == 0
then finishUpdate
else failIO $ "Failed to update package index, return code " ++ show c
else tryWriteRepositoryDB cfg writecsv
where
downloadCommand
| ".git" `isSuffixOf` piurl
......@@ -68,7 +75,7 @@ updateRepository cfg cleancache = do
setLastUpdate cfg
cleanRepositoryCache cfg
infoMessage "Successfully downloaded repository index"
tryWriteRepositoryDB cfg
tryWriteRepositoryDB cfg writecsv
--- Sets the date of the last update by touching README.md.
setLastUpdate :: Config -> IO ()
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment