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

------------------------------------------------------------------------------
--- 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 Directory
import FilePath
import List              ( isSuffixOf )
import System            ( system )

import CPM.Config        ( Config, packageInstallDir, packageIndexURLs
                         , repositoryDir )
import CPM.ErrorLogger
import CPM.Package
import CPM.Package.Helpers    ( cleanPackage )
import CPM.FileUtil           ( copyDirectory, inDirectory, quote
                              , recreateDirectory, removeDirectoryComplete )
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 -> ErrorLoggerIO ()
updateRepository cfg cleancache download usecache writecsv = toELM $ do
  cleanRepositoryCache cfg
  when cleancache $ do
    debugMessage $ "Deleting global package cache: '" ++
                   packageInstallDir cfg ++ "'"
    removeDirectoryComplete (packageInstallDir cfg)
  debugMessage $ "Recreating package index: '" ++ repositoryDir cfg ++ "'"
  if download
    then do
      recreateDirectory (repositoryDir cfg)
      c <- inDirectory (repositoryDir cfg) (tryDownload (packageIndexURLs cfg))
      if c == 0
        then finishUpdate
        else failIO $ "Failed to update package index, return code " ++ show c
    else tryInstallRepositoryDB cfg usecache writecsv
 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
    = execQuietCmd $ \q -> unwords ["git clone", q, quote piurl, "."]
    | ".tar" `isSuffixOf` piurl
    = do let tarfile = "INDEX.tar"
         c1 <- showExecCmd $ unwords ["curl", "-s", "-o", tarfile, quote piurl]
         c2 <- showExecCmd $ unwords ["tar", "-xf", tarfile]
         removeFile tarfile
         return (c1+c2)
    | ".tar.gz" `isSuffixOf` piurl
    = do let tarfile = "INDEX.tar.gz"
         c1 <- showExecCmd $ unwords ["curl", "-s", "-o", tarfile, quote piurl]
         c2 <- showExecCmd $ unwords ["tar", "-xzf", tarfile]
         removeFile tarfile
         return (c1+c2)
    | otherwise
    = do errorMessage $ "Unknown kind of package index URL: " ++ piurl
         return 1

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

--- Sets the date of the last update by touching README.md.
setLastUpdate :: Config -> IO ()
setLastUpdate cfg =
  system (unwords ["touch", repositoryDir cfg </> "README.md"]) >> done

------------------------------------------------------------------------------
--- 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 -> ErrorLoggerIO ()
addPackageToRepository cfg pkgdir force cpdir = do
  dirExists <- execIO $ doesDirectoryExist pkgdir
  if dirExists
    then do pkgSpec <- loadPackageSpecELM pkgdir
            execIO $ copyPackage pkgSpec
            logMsg Info $ "Package in directory '" ++ pkgdir ++
                          "' installed into local repository"
    else logMsg Critical $ "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 <- doesDirectoryExist pkgRepositoryDir
    when (exrepodir && not force) $ error $
      "Package repository directory '" ++
      pkgRepositoryDir ++ "' already exists!\n"
    expkgdir <- doesDirectoryExist pkgInstallDir
    when expkgdir $
      if force then removeDirectoryComplete pkgInstallDir
               else error $ "Package installation directory '" ++
                            pkgInstallDir ++ "' already exists!\n"
    infoMessage $ "Create directory: " ++ pkgRepositoryDir
    createDirectoryIfMissing True pkgRepositoryDir
    copyFile (pkgdir </> "package.json") (pkgRepositoryDir </> "package.json")
    when cpdir $ do
      copyDirectory pkgdir pkgInstallDir
      inDirectory pkgInstallDir $ runELM $ cleanPackage cfg Debug
    if exrepodir then updatePackageInRepositoryCache cfg pkg
                 else addPackageToRepositoryCache    cfg pkg

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