Repository.curry 14.6 KB
Newer Older
Michael Hanus's avatar
Michael Hanus committed
1
------------------------------------------------------------------------------
Michael Hanus's avatar
Michael Hanus committed
2
--- This module implements functionality surrounding the package *repository*.
Michael Hanus's avatar
Michael Hanus committed
3
4
--- The repository is the index of all packages known to the package manager.
--- It contains metadata about the packages, such as their names, versions 
Michael Hanus's avatar
Michael Hanus committed
5
6
7
--- dependencies and where they can be acquired. The repository does not contain
--- the actual packages. For a list of packages that are currently installed 
--- locally, you can consult the *database*.
Michael Hanus's avatar
Michael Hanus committed
8
------------------------------------------------------------------------------
Michael Hanus's avatar
Michael Hanus committed
9
10
11
12
13
14

module CPM.Repository 
  ( Repository
  , emptyRepository
  , allPackages
  , readRepository
Michael Hanus's avatar
Michael Hanus committed
15
  , findAllVersions, findVersion, findLatestVersion
Michael Hanus's avatar
Michael Hanus committed
16
17
  , searchPackages
  , listPackages
18
  , useUpdateHelp, updateRepository, cleanRepositoryCache
Michael Hanus's avatar
Michael Hanus committed
19
  , readPackageFromRepository, getAllPackageVersions, getPackageVersion
Michael Hanus's avatar
Michael Hanus committed
20
21
  ) where

Michael Hanus's avatar
Michael Hanus committed
22
import Char         ( toLower )
Michael Hanus's avatar
Michael Hanus committed
23
24
25
import Directory
import Either
import FilePath
Michael Hanus's avatar
Michael Hanus committed
26
import IO
Michael Hanus's avatar
Michael Hanus committed
27
import IOExts       ( readCompleteFile )
Michael Hanus's avatar
Michael Hanus committed
28
import List
29
import ReadShowTerm ( showQTerm, readQTerm, showTerm, readUnqualifiedTerm )
Michael Hanus's avatar
Michael Hanus committed
30
31
import System       ( exitWith, system )
import Time
Michael Hanus's avatar
Michael Hanus committed
32

Michael Hanus's avatar
Michael Hanus committed
33
34
import CPM.Config        ( Config, repositoryDir, packageIndexRepository
                         , packageInstallDir )
Michael Hanus's avatar
Michael Hanus committed
35
import CPM.ConfigPackage ( packageVersion )
Michael Hanus's avatar
Michael Hanus committed
36
37
import CPM.ErrorLogger
import CPM.Package
Michael Hanus's avatar
Michael Hanus committed
38
import CPM.FileUtil      ( checkAndGetVisibleDirectoryContents, inDirectory
Michael Hanus's avatar
Michael Hanus committed
39
                         , whenFileExists, removeDirectoryComplete )
Michael Hanus's avatar
Michael Hanus committed
40
import CPM.Resolution    ( isCompatibleToCompiler )
Michael Hanus's avatar
Michael Hanus committed
41
42
43
44
45
46
47
48
49
50
51
52
53
54

data Repository = Repository [Package]

--- Creates an empty repository.
emptyRepository :: Repository
emptyRepository = Repository []

--- Finds all versions of a package known to the repository. Returns the 
--- packages sorted from newest to oldest.
---
--- @param r the repository
--- @param p the name of the package to search for
--- @param pre should pre-release versions be included?
findAllVersions :: Repository -> String -> Bool -> [Package]
55
56
57
58
59
60
61
findAllVersions (Repository ps) p pre =
  sortedByVersion $ preFiltered $ sameName ps
 where 
  sortedByVersion = sortBy (\a b -> (version a) `vgt` (version b))
  preFiltered = filter filterPre
  sameName = filter ((== p) . name) 
  filterPre p' = pre || (not . isPreRelease . version) p'
Michael Hanus's avatar
Michael Hanus committed
62

Michael Hanus's avatar
Michael Hanus committed
63
64
65
--- Search the names and synopses of all compiler-compatbile packages
--- in the repository for a particular term.
--- Lower/upercase is ignored for the search.
Michael Hanus's avatar
Michael Hanus committed
66
--- Returns all matching versions (newest first) of each package.
Michael Hanus's avatar
Michael Hanus committed
67
---
Michael Hanus's avatar
Michael Hanus committed
68
69
70
71
72
73
74
--- @param repo       - the repository
--- @param searchmod  - search for some module?
--- @param searchexec - search for some executable?
--- @param searchterm - the term to search for
searchPackages :: Repository -> Bool -> Bool -> String -> [[Package]]
searchPackages (Repository ps) searchmod searchexec searchterm =
  map sortedByVersion (groupBy (\a b -> name a == name b) allResults)
Michael Hanus's avatar
Michael Hanus committed
75
 where
Michael Hanus's avatar
Michael Hanus committed
76
77
  allResults = let s = lowerS searchterm
               in if searchmod
Michael Hanus's avatar
Michael Hanus committed
78
                    then filter (\p -> searchterm `elem` exportedModules p) ps
Michael Hanus's avatar
Michael Hanus committed
79
80
81
82
83
                    else if searchexec
                           then filter (\p -> s `isInfixOf`
                                                (lowerS $ execOfPackage p)) ps
                           else filter (matches s) ps

Michael Hanus's avatar
Michael Hanus committed
84
  matches q p = q `isInfixOf` (lowerS $ name p) ||
Michael Hanus's avatar
Michael Hanus committed
85
86
                q `isInfixOf` (lowerS $ synopsis p) ||
                q `isInfixOf` (lowerS $ unwords (exportedModules p))
Michael Hanus's avatar
Michael Hanus committed
87
88
89

  sortedByVersion = sortBy (\a b -> version a `vgt` version b)

Michael Hanus's avatar
Michael Hanus committed
90
91
  lowerS = map toLower

Michael Hanus's avatar
Michael Hanus committed
92

Michael Hanus's avatar
Michael Hanus committed
93
94
--- Get all packages in the repository and group them by versions
--- (newest first).
Michael Hanus's avatar
Michael Hanus committed
95
---
Michael Hanus's avatar
Michael Hanus committed
96
--- @param cfg  - the current CPM configuration
Michael Hanus's avatar
Michael Hanus committed
97
--- @param repo - the repository
Michael Hanus's avatar
Michael Hanus committed
98
99
100
listPackages :: Repository -> [[Package]]
listPackages (Repository ps) =
  map sortedByVersion (groupBy (\a b -> name a == name b) ps)
Michael Hanus's avatar
Michael Hanus committed
101
102
103
 where
  sortedByVersion = sortBy (\a b -> (version a) `vgt` (version b))

Michael Hanus's avatar
Michael Hanus committed
104
--- Finds the latest compiler-compatbile version of a package.
Michael Hanus's avatar
Michael Hanus committed
105
---
106
--- @param cfg  - the current CPM configuration
Michael Hanus's avatar
Michael Hanus committed
107
108
109
--- @param repo - the central package index
--- @param p - the package to search for
--- @param pre - include pre-release versions
110
111
112
113
114
findLatestVersion :: Config -> Repository -> String -> Bool -> Maybe Package
findLatestVersion cfg repo pn pre =
 case filter (isCompatibleToCompiler cfg) (findAllVersions repo pn pre) of
  []    -> Nothing
  (p:_) -> Just p
Michael Hanus's avatar
Michael Hanus committed
115
116
117

--- Finds a specific version of a package.
findVersion :: Repository -> String -> Version -> Maybe Package
118
119
120
121
findVersion repo p v =
  maybeHead $ filter ((== v) . version) $ findAllVersions repo p True
 where maybeHead []    = Nothing
       maybeHead (x:_) = Just x
Michael Hanus's avatar
Michael Hanus committed
122
123
124
125
126

--- Get all packages in the central package index.
allPackages :: Repository -> [Package]
allPackages (Repository ps) = ps

Michael Hanus's avatar
Michael Hanus committed
127
--- Reads all package specifications from the default repository.
Michael Hanus's avatar
Michael Hanus committed
128
129
--- Uses the cache if it is present or update the cache after reading.
--- If some errors occur, show them and terminate with error exit status.
Michael Hanus's avatar
Michael Hanus committed
130
---
131
132
133
134
135
--- @param cfg   - the configuration to use
--- @param large - if true reads the larger cache with more package information
---                (e.g., for searching all packages)
readRepository :: Config -> Bool -> IO Repository
readRepository cfg large = do
Michael Hanus's avatar
Michael Hanus committed
136
  warnOldRepo cfg
137
  mbrepo <- readRepositoryCache cfg large
Michael Hanus's avatar
Michael Hanus committed
138
139
  case mbrepo of
    Nothing -> do
140
141
      infoMessage $ "Writing " ++ (if large then "large " else "") ++
                    "repository cache..."
Michael Hanus's avatar
Michael Hanus committed
142
143
      (repo, repoErrors) <- readRepositoryFrom (repositoryDir cfg)
      if null repoErrors
144
        then writeRepositoryCache cfg large repo >> return repo
Michael Hanus's avatar
Michael Hanus committed
145
146
        else do errorMessage "Problems while reading the package index:"
                mapM_ errorMessage repoErrors
Michael Hanus's avatar
Michael Hanus committed
147
148
                exitWith 1
    Just repo -> return repo
Michael Hanus's avatar
Michael Hanus committed
149

Michael Hanus's avatar
Michael Hanus committed
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
--- Sets the date of the last update by touching README.md.
setLastUpdate :: Config -> IO ()
setLastUpdate cfg =
  system (unwords ["touch", repositoryDir cfg </> "README.md"]) >> done

--- Prints a warning if the repository index is older than 10 days.
warnOldRepo :: Config -> IO ()
warnOldRepo cfg = do
  utime <- getModificationTime (repositoryDir cfg </> "README.md")
  ctime <- getClockTime
  let warntime = addDays 10 utime
  when (compareClockTime ctime warntime == GT) $ do
    -- We assume that clock time is measured in seconds (as in PAKCS or KiCS2)
    let timediff = clockTimeToInt ctime - clockTimeToInt utime
        days = timediff `div` (60*60*24)
Michael Hanus's avatar
Michael Hanus committed
165
166
    infoMessage $ "Warning: your repository index is older than " ++
                  show days ++ " days.\n" ++ useUpdateHelp
Michael Hanus's avatar
Michael Hanus committed
167
168
169
170

useUpdateHelp :: String
useUpdateHelp = "Use 'cypm update' to download the newest package index."

Michael Hanus's avatar
Michael Hanus committed
171
172
173
174
175
176
--- Reads all package specifications from a repository.
---
--- @param path the location of the repository
readRepositoryFrom :: String -> IO (Repository, [String])
readRepositoryFrom path = do
  debugMessage $ "Reading repository index from '" ++ path ++ "'..."
Michael Hanus's avatar
Michael Hanus committed
177
178
179
180
  repos     <- checkAndGetVisibleDirectoryContents path
  pkgPaths  <- mapIO getDir (map (path </>) repos) >>= return . concat
  verDirs   <- mapIO checkAndGetVisibleDirectoryContents pkgPaths
  verPaths  <- return $ concatMap (\ (d, p) -> map (d </>) p)
Michael Hanus's avatar
Michael Hanus committed
181
                     $ zip pkgPaths verDirs
Michael Hanus's avatar
Michael Hanus committed
182
  specPaths <- return $ map (</> "package.json") verPaths
Michael Hanus's avatar
Michael Hanus committed
183
  specs     <- mapIO readPackageFile specPaths
Michael Hanus's avatar
Michael Hanus committed
184
185
186
187
188
189
  when (null (lefts specs)) $ debugMessage "Finished reading repository"
  return $ (Repository $ rights specs, lefts specs)
 where
  readPackageSpecIO = liftIO readPackageSpec

  readPackageFile f = do
Michael Hanus's avatar
Michael Hanus committed
190
    spec <- readPackageSpecIO $ readCompleteFile f
Michael Hanus's avatar
Michael Hanus committed
191
192
193
194
    return $ case spec of
      Left err -> Left $ "Problem reading '" ++ f ++ "': " ++ err
      Right  s -> Right s

Michael Hanus's avatar
Michael Hanus committed
195
  getDir d = doesDirectoryExist d >>= \b -> return $ if b then [d] else []
Michael Hanus's avatar
Michael Hanus committed
196

Michael Hanus's avatar
Michael Hanus committed
197

Michael Hanus's avatar
Michael Hanus committed
198
--- Updates the package index from the central Git repository.
Michael Hanus's avatar
Michael Hanus committed
199
200
--- Cleans also the global package cache in order to support
--- downloading the newest versions.
Michael Hanus's avatar
Michael Hanus committed
201
202
updateRepository :: Config -> IO (ErrorLogger ())
updateRepository cfg = do
Michael Hanus's avatar
Michael Hanus committed
203
  cleanRepositoryCache cfg
Michael Hanus's avatar
Michael Hanus committed
204
205
206
  debugMessage $ "Deleting global package cache: '" ++
                 packageInstallDir cfg ++ "'"
  removeDirectoryComplete (packageInstallDir cfg)
Michael Hanus's avatar
Michael Hanus committed
207
208
209
  gitExists <- doesDirectoryExist $ (repositoryDir cfg) </> ".git"
  if gitExists 
    then do
Michael Hanus's avatar
Michael Hanus committed
210
      c <- inDirectory (repositoryDir cfg) $ execQuietCmd $ cleanPullCmd
Michael Hanus's avatar
Michael Hanus committed
211
      if c == 0
Michael Hanus's avatar
Michael Hanus committed
212
        then do setLastUpdate cfg
213
                cleanRepositoryCache cfg
Michael Hanus's avatar
Michael Hanus committed
214
                log Info "Successfully updated repository"
Michael Hanus's avatar
Michael Hanus committed
215
216
        else failIO $ "Failed to update git repository, return code " ++ show c
    else do
Michael Hanus's avatar
Michael Hanus committed
217
      c <- inDirectory (repositoryDir cfg) $ execQuietCmd cloneCommand
Michael Hanus's avatar
Michael Hanus committed
218
      if c == 0
Michael Hanus's avatar
Michael Hanus committed
219
        then do setLastUpdate cfg
220
                cleanRepositoryCache cfg
Michael Hanus's avatar
Michael Hanus committed
221
                log Info "Successfully updated repository"
Michael Hanus's avatar
Michael Hanus committed
222
223
        else failIO $ "Failed to update git repository, return code " ++ show c
 where
Michael Hanus's avatar
Michael Hanus committed
224
  cleanPullCmd q = "git clean -d -f && git pull " ++ q ++ " origin master"
Michael Hanus's avatar
Michael Hanus committed
225
226
  cloneCommand q = unwords ["git clone", q, packageIndexRepository cfg, "."]

Michael Hanus's avatar
Michael Hanus committed
227

Michael Hanus's avatar
Michael Hanus committed
228
229
------------------------------------------------------------------------------
-- Operations implementing the repository cache for faster reading.
Michael Hanus's avatar
Michael Hanus committed
230
231
232
233
234
-- The repository cache contains reduced package specifications
-- for faster reading/writing by removing some information
-- which is not relevant for the repository data structure.
--
-- The relevant package fields are:
235
236
-- * small cache: name version dependencies compilerCompatibility
-- * large cache: synopsis category sourceDirs exportedModules executableSpec
Michael Hanus's avatar
Michael Hanus committed
237
238
239

--- The local file name containing the repository cache as a Curry term.
repositoryCacheFileName :: String
Michael Hanus's avatar
Michael Hanus committed
240
repositoryCacheFileName = "REPOSITORY_CACHE"
Michael Hanus's avatar
Michael Hanus committed
241
242

--- The file containing the repository cache as a Curry term.
243
244
245
246
repositoryCache :: Config -> Bool -> String
repositoryCache cfg large =
  repositoryDir cfg </> repositoryCacheFileName ++
  (if large then "_LARGE" else "")
Michael Hanus's avatar
Michael Hanus committed
247

248
249
250
--- The first line of the repository cache (to check version compatibility):
repoCacheVersion :: String
repoCacheVersion = packageVersion ++ "-1"
Michael Hanus's avatar
Michael Hanus committed
251
252

--- Stores the given repository in the cache.
253
254
255
256
257
258
259
260
261
262
263
264
---
--- @param cfg   - the configuration to use
--- @param large - if true writes the larger cache with more package information
---                (e.g., for searching all packages)
--- @param repo  - the repository to write
writeRepositoryCache :: Config -> Bool -> Repository -> IO ()
writeRepositoryCache cfg large repo =
  writeFile (repositoryCache cfg large) $ unlines $
    repoCacheVersion :
    map (if large then showTerm . package2largetuple
                  else showTerm . package2smalltuple)
        (allPackages repo)
Michael Hanus's avatar
Michael Hanus committed
265
 where
266
267
268
269
270
271
272
  package2smalltuple p =
    ( name p, version p, dependencies p, compilerCompatibility p )

  package2largetuple p =
    (package2smalltuple p,
    (synopsis p, category p, sourceDirs p, exportedModules p,
     executableSpec  p))
Michael Hanus's avatar
Michael Hanus committed
273
274

--- Reads the given repository from the cache.
275
276
277
278
279
280
281
---
--- @param cfg   - the configuration to use
--- @param large - if true reads the larger cache with more package information
---                (e.g., for searching all packages)
readRepositoryCache :: Config -> Bool -> IO (Maybe Repository)
readRepositoryCache cfg large = do
  let cf = repositoryCache cfg large
Michael Hanus's avatar
Michael Hanus committed
282
283
284
  excache <- doesFileExist cf
  if excache
    then debugMessage ("Reading repository cache from '" ++ cf ++ "'...") >>
285
286
287
288
         catch ((if large
                  then readTermInCacheFile cfg (largetuple2package . uread) cf
                  else readTermInCacheFile cfg (smalltuple2package . uread) cf)
                  >>= \repo ->
Michael Hanus's avatar
Michael Hanus committed
289
                debugMessage "Finished reading repository cache" >> return repo)
Michael Hanus's avatar
Michael Hanus committed
290
291
292
               (\_ -> do infoMessage "Cleaning broken repository cache..."
                         cleanRepositoryCache cfg
                         return Nothing )
Michael Hanus's avatar
Michael Hanus committed
293
    else return Nothing
Michael Hanus's avatar
Michael Hanus committed
294
 where
295
296
297
  uread s = readUnqualifiedTerm ["CPM.Package","Prelude"] s

  smalltuple2package (nm,vs,dep,cmp) =
Michael Hanus's avatar
Michael Hanus committed
298
299
300
301
302
303
    emptyPackage { name = nm
                 , version = vs
                 , dependencies = dep
                 , compilerCompatibility = cmp
                 }

304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
  largetuple2package (basics,(sy,cat,srcs,exps,exec)) =
    (smalltuple2package basics)
      { synopsis = sy
      , category = cat
      , sourceDirs = srcs
      , exportedModules = exps
      , executableSpec  = exec
      }

readTermInCacheFile :: Config -> (String -> Package) -> String
                    -> IO (Maybe Repository)
readTermInCacheFile cfg trans cf = do
  h <- openFile cf ReadMode
  pv <- hGetLine h
  if pv == repoCacheVersion
    then hGetContents h >>= \t ->
         return $!! Just (Repository (map trans (lines  t)))
    else do infoMessage "Cleaning repository cache (wrong version)..."
            cleanRepositoryCache cfg
            return Nothing
Michael Hanus's avatar
Michael Hanus committed
324

Michael Hanus's avatar
Michael Hanus committed
325
326
327
--- Cleans the repository cache.
cleanRepositoryCache :: Config -> IO ()
cleanRepositoryCache cfg = do
328
329
330
331
  let smallcachefile = repositoryCache cfg False
      largecachefile = repositoryCache cfg True
  whenFileExists smallcachefile $ removeFile smallcachefile
  whenFileExists largecachefile $ removeFile largecachefile
Michael Hanus's avatar
Michael Hanus committed
332
333

------------------------------------------------------------------------------
Michael Hanus's avatar
Michael Hanus committed
334
335
336
337
338
339
340
341
342
--- Reads a given package from the default repository directory.
--- This is useful to obtain the complete package specification
--- from a possibly incomplete package specification.
readPackageFromRepository :: Config -> Package -> IO (ErrorLogger Package)
readPackageFromRepository cfg pkg =
  let pkgdir = repositoryDir cfg </> name pkg </> showVersion (version pkg)
  in loadPackageSpec pkgdir

------------------------------------------------------------------------------
Michael Hanus's avatar
Michael Hanus committed
343
344
345
346
347
348
349
350
351
352
-- Some operations to access the repository. In the future, these
-- operations might be implemented by a better database structure
-- of the repository to speed-up the repository access.

--- Retrieves all versions of a package with a given name from the repository.
---
--- @param cfg     - the current CPM configuration
--- @param pkgname - the package name to be retrieved
--- @param pre     - should pre-release versions be included?
getAllPackageVersions :: Config -> String -> Bool -> IO [Package]
353
354
355
getAllPackageVersions cfg pkgname pre = do
  repo <- readRepository cfg False
  return (findAllVersions repo pkgname pre)
Michael Hanus's avatar
Michael Hanus committed
356
357
358
359
360
361
362

--- Retrieves a package with a given name and version from the repository.
---
--- @param cfg     - the current CPM configuration
--- @param pkgname - the package name to be retrieved
--- @param ver     - the requested version of the package
getPackageVersion :: Config -> String -> Version -> IO (Maybe Package)
363
364
365
getPackageVersion cfg pkgname ver = do
  repo <- readRepository cfg False
  return (findVersion repo pkgname ver)
Michael Hanus's avatar
Michael Hanus committed
366
367

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