Repository.curry 9 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
15
16
17
18
19

module CPM.Repository 
  ( Repository
  , emptyRepository
  , allPackages
  , readRepository
  , findVersion
  , findLatestVersion
  , searchPackages
  , listPackages
  , updateRepository
Michael Hanus 's avatar
Michael Hanus committed
20
  , updateRepositoryCache
Michael Hanus 's avatar
Michael Hanus committed
21
22
  ) where

Michael Hanus 's avatar
Michael Hanus committed
23
import Char         ( toLower )
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 List
Michael Hanus 's avatar
Michael Hanus committed
29
30
import ReadShowTerm ( showQTerm, readQTerm )
import System       ( exitWith )
Michael Hanus 's avatar
Michael Hanus committed
31

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

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]
53
54
55
56
57
58
59
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
60

Michael Hanus 's avatar
Michael Hanus committed
61
62
63
--- 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
64
65
66
--- Returns the newest matching version of each package.
---
--- @param repo - the repository
Michael Hanus 's avatar
Michael Hanus committed
67
--- @searchmod - search for some module?
Michael Hanus 's avatar
Michael Hanus committed
68
--- @param q - the term to search for
Michael Hanus 's avatar
Michael Hanus committed
69
70
searchPackages :: Repository -> Bool -> String -> [Package]
searchPackages (Repository ps) searchmod searchstring =
Michael Hanus 's avatar
Michael Hanus committed
71
72
73
  map (head . sortedByVersion) groupedResults
 where
  groupedResults = groupBy namesEqual allResults
Michael Hanus 's avatar
Michael Hanus committed
74
75
76
  allResults = if searchmod
                 then filter (\p -> searchstring `elem` (exportedModules p)) ps
                 else filter (matches (lowerS searchstring)) ps
Michael Hanus 's avatar
Michael Hanus committed
77
  matches q p = q `isInfixOf` (lowerS $ name p) ||
Michael Hanus 's avatar
Michael Hanus committed
78
79
                q `isInfixOf` (lowerS $ synopsis p) ||
                q `isInfixOf` (lowerS $ unwords (exportedModules p))
Michael Hanus 's avatar
Michael Hanus committed
80
81
82
83
  namesEqual a b = (name a) == (name b)
  sortedByVersion = sortBy (\a b -> (version a) `vgt` (version b))
  lowerS = map toLower

Michael Hanus 's avatar
Michael Hanus committed
84
85
--- Get all packages in the repository and group them by versions
--- (newest first).
Michael Hanus 's avatar
Michael Hanus committed
86
---
Michael Hanus 's avatar
Michael Hanus committed
87
--- @param cfg  - the current CPM configuration
Michael Hanus 's avatar
Michael Hanus committed
88
--- @param repo - the repository
Michael Hanus 's avatar
Michael Hanus committed
89
90
91
listPackages :: Repository -> [[Package]]
listPackages (Repository ps) =
  map sortedByVersion (groupBy (\a b -> name a == name b) ps)
Michael Hanus 's avatar
Michael Hanus committed
92
93
94
 where
  sortedByVersion = sortBy (\a b -> (version a) `vgt` (version b))

Michael Hanus 's avatar
Michael Hanus committed
95
--- Finds the latest compiler-compatbile version of a package.
Michael Hanus 's avatar
Michael Hanus committed
96
---
97
--- @param cfg  - the current CPM configuration
Michael Hanus 's avatar
Michael Hanus committed
98
99
100
--- @param repo - the central package index
--- @param p - the package to search for
--- @param pre - include pre-release versions
101
102
103
104
105
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
106
107
108

--- Finds a specific version of a package.
findVersion :: Repository -> String -> Version -> Maybe Package
109
110
111
112
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
113
114
115
116
117

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

Michael Hanus 's avatar
Michael Hanus committed
118
119
120
--- 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
121
122
---
--- @param cfg the configuration to use
Michael Hanus 's avatar
Michael Hanus committed
123
124
125
126
127
readRepository :: Config -> IO Repository
readRepository cfg = do
  mbrepo <- readRepositoryCache cfg
  case mbrepo of
    Nothing -> do
Michael Hanus 's avatar
Michael Hanus committed
128
      infoMessage "Writing repository cache..."
Michael Hanus 's avatar
Michael Hanus committed
129
130
131
132
133
134
135
      (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
136
137
138
139
140
141
142
143
144
145

--- 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
146
147
  verPaths <- return $ concatMap (\ (d, p) -> map (d </>) (filter dirOrSpec p))
                     $ zip pkgPaths verDirs
Michael Hanus 's avatar
Michael Hanus committed
148
149
150
151
152
153
154
155
156
157
158
159
160
  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
    spec <- readPackageSpecIO $ readFile f
    return $ case spec of
      Left err -> Left $ "Problem reading '" ++ f ++ "': " ++ err
      Right  s -> Right s

Michael Hanus 's avatar
Michael Hanus committed
161
  dirOrSpec d = (not $ isPrefixOf "." d) && takeExtension d /= ".md" &&
Michael Hanus 's avatar
Michael Hanus committed
162
                (not $ isPrefixOf repositoryCacheFileName d)
Michael Hanus 's avatar
Michael Hanus committed
163
164
165
166

--- Updates the package index from the central Git repository.
updateRepository :: Config -> IO (ErrorLogger ())
updateRepository cfg = do
Michael Hanus 's avatar
Michael Hanus committed
167
  cleanRepositoryCache cfg
Michael Hanus 's avatar
Michael Hanus committed
168
169
170
  gitExists <- doesDirectoryExist $ (repositoryDir cfg) </> ".git"
  if gitExists 
    then do
Michael Hanus 's avatar
Michael Hanus committed
171
172
      c <- inDirectory (repositoryDir cfg) $
             execQuietCmd $ (\q -> "git pull " ++ q ++ " origin master")
Michael Hanus 's avatar
Michael Hanus committed
173
      if c == 0
Michael Hanus 's avatar
Michael Hanus committed
174
175
        then do updateRepositoryCache cfg
                log Info "Successfully updated repository"
Michael Hanus 's avatar
Michael Hanus committed
176
177
        else failIO $ "Failed to update git repository, return code " ++ show c
    else do
Michael Hanus 's avatar
Michael Hanus committed
178
      c <- inDirectory (repositoryDir cfg) $ execQuietCmd cloneCommand
Michael Hanus 's avatar
Michael Hanus committed
179
      if c == 0
Michael Hanus 's avatar
Michael Hanus committed
180
181
        then do updateRepositoryCache cfg
                log Info "Successfully updated repository"
Michael Hanus 's avatar
Michael Hanus committed
182
183
        else failIO $ "Failed to update git repository, return code " ++ show c
 where
Michael Hanus 's avatar
Michael Hanus committed
184
185
  cloneCommand q = unwords ["git clone", q, packageIndexRepository cfg, "."]

Michael Hanus 's avatar
Michael Hanus committed
186

Michael Hanus 's avatar
Michael Hanus committed
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
------------------------------------------------------------------------------
-- Operations implementing the repository cache for faster reading.

--- The local file name containing the repository cache as a Curry term.
repositoryCacheFileName :: String
repositoryCacheFileName = "repository_cache"

--- 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
208
209
  writeFile (repositoryCache cfg)
            (packageVersion ++ "\n" ++ showQTerm repo)
Michael Hanus 's avatar
Michael Hanus committed
210
211
212
213
214
215
216
217

--- 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
218
219
220
221
         catch (readTermInCacheFile cf)
               (\_ -> do infoMessage "Cleaning broken repository cache..."
                         cleanRepositoryCache cfg
                         return Nothing )
Michael Hanus 's avatar
Michael Hanus committed
222
    else return Nothing
Michael Hanus 's avatar
Michael Hanus committed
223
224
225
226
227
228
229
230
231
 where
  readTermInCacheFile cf = do
    h <- openFile cf ReadMode
    pv <- hGetLine h
    if pv == packageVersion
      then hGetContents h >>= \t -> return $!! Just (readQTerm t)
      else do infoMessage "Cleaning repository cache (wrong version)..."
              cleanRepositoryCache cfg
              return Nothing
Michael Hanus 's avatar
Michael Hanus committed
232
233
234
235
236
237
238
239

--- Cleans the repository cache.
cleanRepositoryCache :: Config -> IO ()
cleanRepositoryCache cfg = do
  let cachefile = repositoryCache cfg
  whenFileExists cachefile $ removeFile cachefile

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