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

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

module CPM.Repository.CacheDB
  ( repositoryCacheDB, tryWriteRepositoryDB, 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, packageTarFilesURL, 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"

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

--- Writes the repository database with the current repository index.
--- If the second argument is `True`, also a CSV file containing the
--- database entries is written.
writeRepositoryDB :: Config -> Bool -> IO (ErrorLogger ())
writeRepositoryDB cfg writecsv = do
  let sqlitefile = repositoryCacheDB cfg
  whenFileExists sqlitefile (removeFile sqlitefile)
  createNewDB sqlitefile
  tmpdir <- tempDir
  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"
  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]