Repository.curry 6.11 KB
Newer Older
Michael Hanus 's avatar
Michael Hanus committed
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
--------------------------------------------------------------------------------
--- This module implements functionality surrounding the package *repository*.
--- The repository is the index of all packages known to the package manager. It
--- contains metadata about the packages, such as their names, versions 
--- 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*.
--------------------------------------------------------------------------------

module CPM.Repository 
  ( Repository
  , emptyRepository
  , allPackages
  , readRepository
  , findVersion
  , findLatestVersion
  , searchPackages
  , listPackages
  , updateRepository
  ) where

import Char   (toLower)
import Directory
import Either
import List
import FilePath

28
import CPM.Config     (Config, repositoryDir, packageIndexRepository)
Michael Hanus 's avatar
Michael Hanus committed
29
30
import CPM.ErrorLogger
import CPM.Package
31
32
import CPM.FileUtil   ( checkAndGetDirectoryContents, inDirectory )
import CPM.Resolution ( isCompatibleToCompiler )
Michael Hanus 's avatar
Michael Hanus committed
33
34
35
36
37
38
39
40
41
42
43
44
45
46

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]
47
48
49
50
51
52
53
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
54

Michael Hanus 's avatar
Michael Hanus committed
55
56
57
--- 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
58
59
60
--- Returns the newest matching version of each package.
---
--- @param repo - the repository
Michael Hanus 's avatar
Michael Hanus committed
61
--- @searchmod - search for some module?
Michael Hanus 's avatar
Michael Hanus committed
62
--- @param q - the term to search for
Michael Hanus 's avatar
Michael Hanus committed
63
64
searchPackages :: Repository -> Bool -> String -> [Package]
searchPackages (Repository ps) searchmod searchstring =
Michael Hanus 's avatar
Michael Hanus committed
65
66
67
  map (head . sortedByVersion) groupedResults
 where
  groupedResults = groupBy namesEqual allResults
Michael Hanus 's avatar
Michael Hanus committed
68
69
70
  allResults = if searchmod
                 then filter (\p -> searchstring `elem` (exportedModules p)) ps
                 else filter (matches (lowerS searchstring)) ps
Michael Hanus 's avatar
Michael Hanus committed
71
  matches q p = q `isInfixOf` (lowerS $ name p) ||
Michael Hanus 's avatar
Michael Hanus committed
72
73
                q `isInfixOf` (lowerS $ synopsis p) ||
                q `isInfixOf` (lowerS $ unwords (exportedModules p))
Michael Hanus 's avatar
Michael Hanus committed
74
75
76
77
  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
78
79
--- Get all packages in the repository and group them by versions
--- (newest first).
Michael Hanus 's avatar
Michael Hanus committed
80
---
Michael Hanus 's avatar
Michael Hanus committed
81
--- @param cfg  - the current CPM configuration
Michael Hanus 's avatar
Michael Hanus committed
82
--- @param repo - the repository
Michael Hanus 's avatar
Michael Hanus committed
83
84
85
listPackages :: Repository -> [[Package]]
listPackages (Repository ps) =
  map sortedByVersion (groupBy (\a b -> name a == name b) ps)
Michael Hanus 's avatar
Michael Hanus committed
86
87
88
 where
  sortedByVersion = sortBy (\a b -> (version a) `vgt` (version b))

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

--- Finds a specific version of a package.
findVersion :: Repository -> String -> Version -> Maybe Package
103
104
105
106
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
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

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

--- Reads all package specifications from the default repository
---
--- @param cfg the configuration to use
readRepository :: Config -> IO (Repository, [String])
readRepository cfg = readRepositoryFrom (repositoryDir cfg)

--- 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
  verPaths <- return $ concat $ map (\(d, p) -> map (d </>) (filter dirOrSpec p)) $ zip pkgPaths verDirs
  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

  dirOrSpec d =  (not $ isPrefixOf "." d) && takeExtension d /= ".md"

--- Updates the package index from the central Git repository.
updateRepository :: Config -> IO (ErrorLogger ())
updateRepository cfg = do
  gitExists <- doesDirectoryExist $ (repositoryDir cfg) </> ".git"
  if gitExists 
    then do
Michael Hanus 's avatar
Michael Hanus committed
149
150
      c <- inDirectory (repositoryDir cfg) $
             execQuietCmd $ (\q -> "git pull " ++ q ++ " origin master")
Michael Hanus 's avatar
Michael Hanus committed
151
152
153
154
      if c == 0
        then log Info "Successfully updated repository"
        else failIO $ "Failed to update git repository, return code " ++ show c
    else do
Michael Hanus 's avatar
Michael Hanus committed
155
      c <- inDirectory (repositoryDir cfg) $ execQuietCmd cloneCommand
Michael Hanus 's avatar
Michael Hanus committed
156
157
158
159
      if c == 0
        then log Info "Successfully updated repository"
        else failIO $ "Failed to update git repository, return code " ++ show c
 where
Michael Hanus 's avatar
Michael Hanus committed
160
161
  cloneCommand q = unwords ["git clone", q, packageIndexRepository cfg, "."]

Michael Hanus 's avatar
Michael Hanus committed
162