1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142

------------------------------------------------------------------------------
--- This module implements operations to update and change the
--- package repository, i.e., the index of all packages known
--- to the package manager.
------------------------------------------------------------------------------

module CPM.Repository.Update
  ( addPackageToRepository, updateRepository
  )
 where

import System.Directory
import System.FilePath
import Data.List         ( isSuffixOf )
import Control.Monad

import CPM.Config             ( Config, packageInstallDir, packageIndexURLs
                              , repositoryDir )
import CPM.ErrorLogger
import CPM.Executables        ( getCurlCmd )
import CPM.Package
import CPM.Package.Helpers    ( cleanPackage )
import CPM.FileUtil           ( copyDirectory, quote, recreateDirectory
                              , removeDirectoryComplete, whenFileExists )
import CPM.Repository
import CPM.Repository.CacheDB ( tryInstallRepositoryDB )
import CPM.Repository.Select  ( addPackageToRepositoryCache
                              , updatePackageInRepositoryCache )

------------------------------------------------------------------------------
--- 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.
--- If the third argument is `True`, the global package index is recreated
--- by downloading it from the central repository.
--- If the fourth argument is `True`, the package database is created
--- by reading the CSV file `REPOSITORY_CACHE.csv` downloaded from
--- the tar files URL, otherwise by reading all package specifications.
--- If the fifth argument is `True`, also a CSV file containing the
--- database entries is written.
updateRepository :: Config -> Bool -> Bool -> Bool -> Bool -> ErrorLogger ()
updateRepository cfg cleancache download usecache writecsv = do
  let repodir    = repositoryDir cfg
      repodirbak = repodir ++ ".BAK"
  logDebug $ "Recreating package index: '" ++ repodir ++ "'"
  if download
    then do
      liftIOEL $ do removeDirectoryComplete repodirbak
                    renameDirectory repodir repodirbak -- save old repo
                    recreateDirectory repodir
      c <- inDirectoryEL repodir (tryDownload (packageIndexURLs cfg))
      if c == 0
        then finishUpdate >> liftIOEL (removeDirectoryComplete repodirbak)
        else do logDebug "Keeping old package index"
                liftIOEL $ do removeDirectoryComplete repodir
                              renameDirectory repodirbak repodir
                fail $ "Failed to update package index, return code " ++ show c
    else tryInstallRepositoryDB cfg usecache writecsv
  when cleancache $ do
    logDebug $ "Deleting global package cache: '" ++
               packageInstallDir cfg ++ "'"
    liftIOEL $ removeDirectoryComplete $ packageInstallDir cfg
 where
  tryDownload []         = return 1
  tryDownload (url:urls) = do c <- downloadCommand url
                              if c == 0 then return 0
                                        else tryDownload urls

  downloadCommand piurl
    | ".git" `isSuffixOf` piurl
    = let qcmd q = unwords ["git clone", q, quote piurl, "."]
      in execQuietCmd (qcmd "-q") (qcmd "")
    | ".tar" `isSuffixOf` piurl
    = do let tarfile = "INDEX.tar"
         curlcmd <- getCurlCmd
         c1 <- showExecCmd $ unwords [curlcmd, "-o", tarfile, quote piurl]
         c2 <- showExecCmd $ unwords ["tar", "-xf", tarfile]
         liftIOEL $ whenFileExists tarfile $ removeFile tarfile
         return (c1 + c2)
    | ".tar.gz" `isSuffixOf` piurl
    = do let tarfile = "INDEX.tar.gz"
         curlcmd <- getCurlCmd
         c1 <- showExecCmd $ unwords [curlcmd, "-o", tarfile, quote piurl]
         c2 <- showExecCmd $ unwords ["tar", "-xzf", tarfile]
         liftIOEL $ whenFileExists tarfile $ removeFile tarfile
         return (c1 + c2)
    | otherwise
    = do logError $ "Unknown kind of package index URL: " ++ piurl
         return 1

  finishUpdate = do
    setLastUpdate cfg
    cleanRepositoryCache cfg
    logInfo "Successfully downloaded repository index"
    tryInstallRepositoryDB cfg usecache writecsv

--- Sets the date of the last update by touching README.md.
setLastUpdate :: Config -> ErrorLogger ()
setLastUpdate cfg = do
  showExecCmd $ unwords ["touch", repositoryDir cfg </> "README.md"]
  return ()

------------------------------------------------------------------------------
--- Adds a package stored in the given directory to the repository index.
--- If the argument `force` is true, overwrite an already existing package.
--- If the argument `cpdir` is true, copy also the complete directory
--- into the local package installation store.
addPackageToRepository :: Config -> String -> Bool -> Bool -> ErrorLogger ()
addPackageToRepository cfg pkgdir force cpdir = do
  dirExists <- liftIOEL $ doesDirectoryExist pkgdir
  if dirExists
    then do pkgSpec <- loadPackageSpec pkgdir
            copyPackage pkgSpec
            logInfo $ "Package in directory '" ++ pkgdir ++
                          "' installed into local repository"
    else logCritical $ "Directory '" ++ pkgdir ++ "' does not exist."
 where
  copyPackage pkg = do
    let pkgIndexDir      = name pkg </> showVersion (version pkg)
        pkgRepositoryDir = repositoryDir cfg </> pkgIndexDir
        pkgInstallDir    = packageInstallDir cfg </> packageId pkg
    exrepodir <- liftIOEL $ doesDirectoryExist pkgRepositoryDir
    when (exrepodir && not force) $ error $
      "Package repository directory '" ++
      pkgRepositoryDir ++ "' already exists!\n"
    expkgdir <- liftIOEL $ doesDirectoryExist pkgInstallDir
    when expkgdir $
      if force then liftIOEL $ removeDirectoryComplete pkgInstallDir
               else error $ "Package installation directory '" ++
                            pkgInstallDir ++ "' already exists!\n"
    logInfo $ "Create directory: " ++ pkgRepositoryDir
    liftIOEL $ do
      createDirectoryIfMissing True pkgRepositoryDir
      copyFile (pkgdir </> packageSpecFile)
               (pkgRepositoryDir </> packageSpecFile)
    when cpdir $ do
      liftIOEL $ copyDirectory pkgdir pkgInstallDir
      inDirectoryEL pkgInstallDir $ cleanPackage cfg Debug
    if exrepodir then updatePackageInRepositoryCache cfg pkg
                 else addPackageToRepositoryCache    cfg pkg

------------------------------------------------------------------------------