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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160

------------------------------------------------------------------------------
--- Operations to initialize and manipulate the repository cache database.
---
--- @author Michael Hanus
--- @version June 2019
------------------------------------------------------------------------------

module CPM.Repository.CacheDB
  ( repositoryCacheDB, tryInstallRepositoryDB, addPackagesToRepositoryDB )
 where

import Directory    ( doesFileExist, removeFile )
import FilePath     ( (</>) )
import IO           ( hFlush, stdout )
import ReadShowTerm

import Database.CDBI.ER
import Database.CDBI.Connection
import System.Path  ( fileInPath )
import Text.CSV

import CPM.Config      ( Config, packageTarFilesURLs, readConfigurationWith
                       , repositoryDir )
import CPM.ErrorLogger
import CPM.FileUtil    ( cleanTempDir, inTempDir, quote, tempDir
                       , whenFileExists )
import CPM.Repository.RepositoryDB
import CPM.Package
import CPM.Repository

--- The database containing the repository cache.
repositoryCacheDB :: Config -> String
repositoryCacheDB cfg = repositoryCacheFilePrefix cfg ++ ".db"

--- The database containing the repository cache.
repositoryCacheCSV :: Config -> String
repositoryCacheCSV cfg = repositoryCacheFilePrefix cfg ++ ".csv"

--- Installs the repository database with the current repository index
--- if the command `sqlite3` is in the path.
tryInstallRepositoryDB :: Config -> Bool -> Bool -> IO (ErrorLogger ())
tryInstallRepositoryDB cfg usecache writecsv = do
  withsqlite <- fileInPath "sqlite3"
  if withsqlite
    then installRepositoryDB cfg usecache writecsv
    else log Info
      "Command 'sqlite3' not found: install package 'sqlite3' to speed up CPM"

--- Writes the repository database with the current repository index.
--- First, it is tried to download `REPOSITORY_CACHE.db`
--- from the tar files URL (if the second argument is `True`).
--- Otherwise, `writeRepositoryDB` is called.
--- If the second argument is `True`, also a CSV file containing the
--- database entries is written.
installRepositoryDB :: Config -> Bool -> Bool -> IO (ErrorLogger ())
installRepositoryDB cfg False writecsv = writeRepositoryDB cfg False writecsv
installRepositoryDB cfg True  writecsv = do
  let sqlitefile = repositoryCacheDB cfg
  whenFileExists sqlitefile (removeFile sqlitefile)
  c <- tryDownloadFromURLs sqlitefile (packageTarFilesURLs cfg)
                           "REPOSITORY_CACHE.db"
  dbexists <- doesFileExist sqlitefile
  if c == 0 && dbexists
    then if writecsv then saveDBAsCSV cfg
                     else succeedIO ()
    else writeRepositoryDB cfg True writecsv

--- Tries to download some target file (first argument) from a list of
--- base URLs where the source file (third argument) is located.
--- Returns 0 if the download was successfull.
tryDownloadFromURLs :: String -> [String] -> String -> IO Int
tryDownloadFromURLs _      []                 _    = return 1
tryDownloadFromURLs target (baseurl:baseurls) file = do
  let sourceurl = baseurl ++ "/" ++ file
  rc <- inTempDir $ showExecCmd $
          "curl -f -s -o " ++ quote target ++ " " ++ quote sourceurl
  if rc == 0
    then return 0
    else tryDownloadFromURLs target baseurls file

--- Writes the repository database with the current repository index.
--- It is generated either from the CSV file `REPOSITORY_CACHE.csv`
--- downloaded from the tar files URL (if the second argument is `True`)
--- or from reading all package specs.
--- If the third argument is `True`, also a CSV file containing the
--- database entries is written.
writeRepositoryDB :: Config -> Bool -> Bool -> IO (ErrorLogger ())
writeRepositoryDB cfg usecache writecsv = do
  let sqlitefile = repositoryCacheDB cfg
  whenFileExists sqlitefile (removeFile sqlitefile)
  createNewDB sqlitefile
  tmpdir <- tempDir
  let csvfile = tmpdir </> "cachedb.csv"
  showExecCmd $ "/bin/rm -f " ++ csvfile
  c <- if usecache
         then tryDownloadFromURLs csvfile (packageTarFilesURLs cfg)
                                  "REPOSITORY_CACHE.csv"
         else return 1
  csvexists <- doesFileExist csvfile
  pkgentries <- if c == 0 && csvexists
                  then do
                    debugMessage $ "Reading CSV file '" ++ csvfile ++ "'..."
                    readCSVFile csvfile >>= return . map Right
                  else do
                    when usecache $ debugMessage $
                      "Fetching repository cache CSV file failed"
                    repo <- readRepositoryFrom (repositoryDir cfg)
                    return (map Left (allPackages repo))
  putStr "Writing repository cache DB"
  addPackagesToRepositoryDB cfg False pkgentries
  putChar '\n'
  log Info "Repository cache DB written"
  cleanTempDir
  if writecsv then saveDBAsCSV cfg
              else succeedIO ()

--- 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
  runDBAction act = do
    result <- runWithDB (repositoryCacheDB cfg) act
    case result of
      Left (DBError kind str) -> log Critical $ "Repository DB failure: " ++
                                                show kind ++ " " ++ str
      Right _ -> (unless quiet $ putChar '.' >> hFlush stdout) >> succeedIO ()

  newEntry (Left p) = newIndexEntry
    (name p)
    (showTerm (version p))
    (showTerm (dependencies p))
    (showTerm (compilerCompatibility p))
    (synopsis p)
    (showTerm (category p))
    (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]