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