Repository.curry 11.1 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
18
  , searchPackages
  , listPackages
  , updateRepository
Michael Hanus 's avatar
Michael Hanus committed
19
  , updateRepositoryCache
Michael Hanus 's avatar
Michael Hanus committed
20
  , readPackageFromRepository
Michael Hanus 's avatar
Michael Hanus committed
21
22
  ) where

Michael Hanus 's avatar
Michael Hanus committed
23
import Char         ( toLower, toUpper )
Michael Hanus 's avatar
Michael Hanus committed
24
25
26
import Directory
import Either
import FilePath
Michael Hanus 's avatar
Michael Hanus committed
27
import IO
Michael Hanus 's avatar
Michael Hanus committed
28
import IOExts       ( readCompleteFile )
Michael Hanus 's avatar
Michael Hanus committed
29
import List
Michael Hanus 's avatar
Michael Hanus committed
30
31
import ReadShowTerm ( showQTerm, readQTerm )
import System       ( exitWith )
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      ( checkAndGetDirectoryContents, 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
128
129
--- Reads all package specifications from the default repository.
--- Use the cache if is present or update the cache after reading.
--- If some errors occur, show them and terminate with exit status.
Michael Hanus 's avatar
Michael Hanus committed
130
131
---
--- @param cfg the configuration to use
Michael Hanus 's avatar
Michael Hanus committed
132
133
134
135
136
readRepository :: Config -> IO Repository
readRepository cfg = do
  mbrepo <- readRepositoryCache cfg
  case mbrepo of
    Nothing -> do
Michael Hanus 's avatar
Michael Hanus committed
137
      infoMessage "Writing repository cache..."
Michael Hanus 's avatar
Michael Hanus committed
138
139
140
141
142
143
144
      (repo, repoErrors) <- readRepositoryFrom (repositoryDir cfg)
      if null repoErrors
        then writeRepositoryCache cfg repo >> return repo
        else do putStrLn "Problems while reading the package index:"
                mapIO putStrLn repoErrors
                exitWith 1
    Just repo -> return repo
Michael Hanus 's avatar
Michael Hanus committed
145
146
147
148
149
150
151
152
153
154

--- 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 ++ "'..."
  pkgDirs <- checkAndGetDirectoryContents path
  pkgPaths <- return $ map (path </>) $ filter dirOrSpec pkgDirs
  verDirs <- mapIO checkAndGetDirectoryContents pkgPaths
Michael Hanus 's avatar
Michael Hanus committed
155
156
  verPaths <- return $ concatMap (\ (d, p) -> map (d </>) (filter dirOrSpec p))
                     $ zip pkgPaths verDirs
Michael Hanus 's avatar
Michael Hanus committed
157
158
159
160
161
162
163
164
  specPaths <- return $ map (</> "package.json") verPaths
  specs <- mapIO readPackageFile specPaths
  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
165
    spec <- readPackageSpecIO $ readCompleteFile f
Michael Hanus 's avatar
Michael Hanus committed
166
167
168
169
    return $ case spec of
      Left err -> Left $ "Problem reading '" ++ f ++ "': " ++ err
      Right  s -> Right s

Michael Hanus 's avatar
Michael Hanus committed
170
  dirOrSpec d = (not $ isPrefixOf "." d) && takeExtension d /= ".md" &&
Michael Hanus 's avatar
Michael Hanus committed
171
                (not $ isPrefixOf repositoryCacheFileName (map toUpper d))
Michael Hanus 's avatar
Michael Hanus committed
172

Michael Hanus 's avatar
Michael Hanus committed
173

Michael Hanus 's avatar
Michael Hanus committed
174
--- Updates the package index from the central Git repository.
Michael Hanus 's avatar
Michael Hanus committed
175
176
--- Cleans also the global package cache in order to support
--- downloading the newest versions.
Michael Hanus 's avatar
Michael Hanus committed
177
178
updateRepository :: Config -> IO (ErrorLogger ())
updateRepository cfg = do
Michael Hanus 's avatar
Michael Hanus committed
179
  cleanRepositoryCache cfg
Michael Hanus 's avatar
Michael Hanus committed
180
181
182
  debugMessage $ "Deleting global package cache: '" ++
                 packageInstallDir cfg ++ "'"
  removeDirectoryComplete (packageInstallDir cfg)
Michael Hanus 's avatar
Michael Hanus committed
183
184
185
  gitExists <- doesDirectoryExist $ (repositoryDir cfg) </> ".git"
  if gitExists 
    then do
Michael Hanus 's avatar
Michael Hanus committed
186
187
      c <- inDirectory (repositoryDir cfg) $
             execQuietCmd $ (\q -> "git pull " ++ q ++ " origin master")
Michael Hanus 's avatar
Michael Hanus committed
188
      if c == 0
Michael Hanus 's avatar
Michael Hanus committed
189
190
        then do updateRepositoryCache cfg
                log Info "Successfully updated repository"
Michael Hanus 's avatar
Michael Hanus committed
191
192
        else failIO $ "Failed to update git repository, return code " ++ show c
    else do
Michael Hanus 's avatar
Michael Hanus committed
193
      c <- inDirectory (repositoryDir cfg) $ execQuietCmd cloneCommand
Michael Hanus 's avatar
Michael Hanus committed
194
      if c == 0
Michael Hanus 's avatar
Michael Hanus committed
195
196
        then do updateRepositoryCache cfg
                log Info "Successfully updated repository"
Michael Hanus 's avatar
Michael Hanus committed
197
198
        else failIO $ "Failed to update git repository, return code " ++ show c
 where
Michael Hanus 's avatar
Michael Hanus committed
199
200
  cloneCommand q = unwords ["git clone", q, packageIndexRepository cfg, "."]

Michael Hanus 's avatar
Michael Hanus committed
201

Michael Hanus 's avatar
Michael Hanus committed
202
203
------------------------------------------------------------------------------
-- Operations implementing the repository cache for faster reading.
Michael Hanus 's avatar
Michael Hanus committed
204
205
206
207
208
209
210
-- 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:
-- name version synopsis category dependencies
-- compilerCompatibility sourceDirs exportedModules
Michael Hanus 's avatar
Michael Hanus committed
211
212
213

--- The local file name containing the repository cache as a Curry term.
repositoryCacheFileName :: String
Michael Hanus 's avatar
Michael Hanus committed
214
repositoryCacheFileName = "REPOSITORY_CACHE"
Michael Hanus 's avatar
Michael Hanus committed
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229

--- The file containing the repository cache as a Curry term.
repositoryCache :: Config -> String
repositoryCache cfg = repositoryDir cfg </> repositoryCacheFileName

--- Updates the repository cache with the current repository index.
updateRepositoryCache :: Config -> IO ()
updateRepositoryCache cfg = do
  cleanRepositoryCache cfg
  repo <- readRepository cfg
  writeRepositoryCache cfg repo

--- Stores the given repository in the cache.
writeRepositoryCache :: Config -> Repository -> IO ()
writeRepositoryCache cfg repo =
Michael Hanus 's avatar
Michael Hanus committed
230
  writeFile (repositoryCache cfg)
Michael Hanus 's avatar
Michael Hanus committed
231
232
233
234
235
236
237
238
239
240
241
242
243
            (packageVersion ++ "\n" ++
             showQTerm (map package2tuple (allPackages repo)))
 where
  package2tuple p =
    ( name p
    , version p
    , synopsis p
    , category p
    , dependencies p
    , compilerCompatibility p
    , sourceDirs p
    , exportedModules p
    )
Michael Hanus 's avatar
Michael Hanus committed
244
245
246
247
248
249
250
251

--- Reads the given repository from the cache.
readRepositoryCache :: Config -> IO (Maybe Repository)
readRepositoryCache cfg = do
  let cf = repositoryCache cfg
  excache <- doesFileExist cf
  if excache
    then debugMessage ("Reading repository cache from '" ++ cf ++ "'...") >>
Michael Hanus 's avatar
Michael Hanus committed
252
253
254
255
         catch (readTermInCacheFile cf)
               (\_ -> do infoMessage "Cleaning broken repository cache..."
                         cleanRepositoryCache cfg
                         return Nothing )
Michael Hanus 's avatar
Michael Hanus committed
256
    else return Nothing
Michael Hanus 's avatar
Michael Hanus committed
257
258
259
260
261
 where
  readTermInCacheFile cf = do
    h <- openFile cf ReadMode
    pv <- hGetLine h
    if pv == packageVersion
Michael Hanus 's avatar
Michael Hanus committed
262
263
      then hGetContents h >>= \t ->
           return $!! Just (Repository (map tuple2package (readQTerm t)))
Michael Hanus 's avatar
Michael Hanus committed
264
265
266
      else do infoMessage "Cleaning repository cache (wrong version)..."
              cleanRepositoryCache cfg
              return Nothing
Michael Hanus 's avatar
Michael Hanus committed
267

Michael Hanus 's avatar
Michael Hanus committed
268
269
270
271
272
273
274
275
276
277
278
279
  tuple2package (nm,vs,sy,cat,dep,cmp,srcs,exps) =
    emptyPackage { name = nm
                 , version = vs
                 , synopsis = sy
                 , category = cat
                 , dependencies = dep
                 , compilerCompatibility = cmp
                 , sourceDirs = srcs
                 , exportedModules = exps
                 }


Michael Hanus 's avatar
Michael Hanus committed
280
281
282
283
284
285
286
--- Cleans the repository cache.
cleanRepositoryCache :: Config -> IO ()
cleanRepositoryCache cfg = do
  let cachefile = repositoryCache cfg
  whenFileExists cachefile $ removeFile cachefile

------------------------------------------------------------------------------
Michael Hanus 's avatar
Michael Hanus committed
287
288
289
290
291
292
293
294
295
--- 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

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