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
161
162
163
164
165
166
167
168

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

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

import Data.Maybe          ( maybeToList, listToMaybe )

import System.Directory    ( doesFileExist, removeFile )
import System.FilePath     ( (</>) )
import System.IO           ( hFlush, stdout )
import Control.Monad
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.Executables ( getCurlCmd )
import CPM.FileUtil    ( cleanTempDir, 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 -> ErrorLogger ()
tryInstallRepositoryDB cfg usecache writecsv = do
  withsqlite <- liftIOEL $ fileInPath "sqlite3"
  if withsqlite
    then installRepositoryDB cfg usecache writecsv
    else logInfo
      "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 -> ErrorLogger ()
installRepositoryDB cfg False writecsv = writeRepositoryDB cfg False writecsv
installRepositoryDB cfg True  writecsv = do
  let sqlitefile = repositoryCacheDB cfg
  liftIOEL $ whenFileExists sqlitefile $ removeFile sqlitefile
  c <- tryDownloadFromURLs sqlitefile (packageTarFilesURLs cfg)
                           "REPOSITORY_CACHE.db"
  dbexists <- liftIOEL $ doesFileExist sqlitefile
  if c == 0 && dbexists
    then if writecsv then saveDBAsCSV cfg
                     else return ()
    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 -> ErrorLogger Int
tryDownloadFromURLs _      []                 _    = return 1
tryDownloadFromURLs target (baseurl:baseurls) file = do
  let sourceurl = baseurl ++ "/" ++ file
  logDebug $ "Trying to download '" ++ sourceurl ++ "'"
  curlcmd <- getCurlCmd
  rc <- showExecCmd $ unwords [curlcmd, "-f -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 -> ErrorLogger ()
writeRepositoryDB cfg usecache writecsv = do
  let sqlitefile = repositoryCacheDB cfg
  liftIOEL $ do
    whenFileExists sqlitefile (removeFile sqlitefile)
    createNewDB sqlitefile
  tmpdir <- liftIOEL $ 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 <- liftIOEL $ doesFileExist csvfile
  pkgentries <- if c == 0 && csvexists
                  then do
                    logDebug $ "Reading CSV file '" ++ csvfile ++ "'..."
                    (liftIOEL $ readCSVFile csvfile) >>= return . map Right
                  else do
                    when usecache $ logDebug $
                      "Fetching repository cache CSV file failed"
                    repo <- readRepositoryFrom (repositoryDir cfg)
                    return $ map Left $ allPackages repo
  liftIOEL $ putStr "Writing repository cache DB"
  addPackagesToRepositoryDB cfg False pkgentries
  liftIOEL $ putChar '\n'
  logInfo "Repository cache DB written"
  liftIOEL $ cleanTempDir
  if writecsv then saveDBAsCSV cfg
              else return ()

--- 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]] -> ErrorLogger ()
addPackagesToRepositoryDB cfg quiet pkgs =
  mapM (runDBAction . newEntry) pkgs >> return ()
 where
  runDBAction act = do
    result <- liftIOEL $ runWithDB (repositoryCacheDB cfg) act
    case result of
      Left (DBError kind str) -> logCritical $ "Repository DB failure: " ++
                                                   show kind ++ " " ++ str
      Right _ -> liftIOEL $ do
        unless quiet $ putChar '.'
        hFlush stdout
        return ()

  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 (listToMaybe (executableSpec  p)))
  newEntry (Right row) = case row of
    [pn,pv,deps,cc,syn,cat,dirs,mods,exe] ->
      newIndexEntry pn pv deps cc syn cat dirs mods exe
    _ -> error $ "CPM.Repository.CacheDB: internal format error"

--- Saves complete database as term files into an existing directory
--- provided as a parameter.
saveDBAsCSV :: Config -> ErrorLogger ()
saveDBAsCSV cfg = do
  result <- liftIOEL $ runWithDB (repositoryCacheDB cfg)
                                          (getAllEntries indexEntry_CDBI_Description)
  case result of
    Left (DBError kind str) -> logCritical $ "Repository DB failure: " ++
                                                 show kind ++ " " ++ str
    Right es -> do let csvfile = repositoryCacheCSV cfg
                   liftIOEL $ writeCSVFile csvfile $ map showIndexEntry es
                   logInfo ("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]