Global.curry 11.7 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 contains functions for accessing and modifying the global 
--- package cache.
--------------------------------------------------------------------------------

module CPM.PackageCache.Global 
  ( GlobalCache
  , findAllVersions
  , findNewestVersion
  , findVersion
  , isPackageInstalled
  , installedPackageDir
  , readInstalledPackagesFromDir
  , allPackages
  , copyPackage
  , installMissingDependencies
  , acquireAndInstallPackage
  , tryFindPackage
  , missingPackages
  , installFromZip
  , checkoutPackage
  , uninstallPackage
  , emptyCache
  ) where

import Directory
import Either
Michael Hanus 's avatar
Michael Hanus committed
28
import IOExts       ( readCompleteFile )
Michael Hanus 's avatar
Michael Hanus committed
29
30
31
32
import List
import Maybe (isJust)
import FilePath

Michael Hanus 's avatar
Michael Hanus committed
33
import CPM.Config   ( Config, packageInstallDir )
Michael Hanus 's avatar
Michael Hanus committed
34
35
36
import CPM.ErrorLogger
import CPM.FileUtil ( copyDirectory, inTempDir, recreateDirectory, inDirectory
                    , removeDirectoryComplete, tempDir
Michael Hanus 's avatar
Michael Hanus committed
37
                    , checkAndGetDirectoryContents, quote )
Michael Hanus 's avatar
Michael Hanus committed
38
import CPM.Package
Michael Hanus 's avatar
Michael Hanus committed
39
import CPM.Repository
Michael Hanus 's avatar
Michael Hanus committed
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

--- The global package cache.
data GlobalCache = GlobalCache [Package]

--- An empty package cache.
emptyCache :: GlobalCache
emptyCache = GlobalCache []

--- Gets all package specifications from a cache.
allPackages :: GlobalCache -> [Package]
allPackages (GlobalCache ps) = ps

--- Finds all versions of a package in the global package cache.
---
--- @param gc - the global package cache
--- @param p - the name of the package
--- @param pre - include pre-release versions
findAllVersions :: GlobalCache -> String -> Bool -> [Package]
findAllVersions (GlobalCache ps) p pre = sortBy pkgGt 
  $ filter filterPre 
  $ filter ((== p) . name) ps
 where 
  filterPre p' = pre || (not . isPreRelease . version) p'

--- Compares two packages by their versions.
pkgGt :: Package -> Package -> Bool
pkgGt a b = version a `vgt` version b

--- Finds the newest version of a package.
findNewestVersion :: GlobalCache -> String -> Maybe Package
findNewestVersion db p = if length pkgs > 0
  then Just $ head pkgs
  else Nothing
 where 
  pkgs = sortBy pkgGt $ findAllVersions db p False

--- Finds a specific version of a package.
findVersion :: GlobalCache -> String -> Version -> Maybe Package
findVersion (GlobalCache ps) p v = if length hits == 0
    then Nothing
    else Just $ head hits
  where
    hits = filter ((== v) . version) $ filter ((== p) . name) ps 

--- Checks whether a package is installed.
isPackageInstalled :: GlobalCache -> Package -> Bool
isPackageInstalled db p = isJust $ findVersion db (name p) (version p)

--- The directory of a package in the global package cache. Does not check 
--- whether the package is actually installed!
installedPackageDir :: Config -> Package -> String
Michael Hanus 's avatar
Michael Hanus committed
91
92
installedPackageDir cfg pkg =
  base  </> (name pkg ++ "-" ++ (showVersion $ version pkg))
Michael Hanus 's avatar
Michael Hanus committed
93
94
95
96
97
98
99
100
 where 
  base = packageInstallDir cfg

--- Copy a package version to a directory.
copyPackage :: Config -> Package -> String -> IO (ErrorLogger ())
copyPackage cfg pkg dir = do
  exists <- doesDirectoryExist srcDir
  if not exists
Michael Hanus 's avatar
Michael Hanus committed
101
    then failIO $ "Package '" ++ packageId pkg ++ "' not installed"
Michael Hanus 's avatar
Michael Hanus committed
102
103
104
105
106
107
108
109
    else copyDirectory srcDir dir >> succeedIO ()
 where
  srcDir = installedPackageDir cfg pkg

--- Acquires a package from the source specified in its specification and 
--- installs it to the global package cache.
acquireAndInstallPackage :: Config -> Package -> IO (ErrorLogger ())
acquireAndInstallPackage cfg pkg = case (source pkg) of
Michael Hanus 's avatar
Michael Hanus committed
110
111
112
  Nothing -> failIO $ "No source specified for " ++ packageId pkg
  Just  s -> log Info ("Installing package from " ++ showPackageSource pkg) |> 
             installFromSource cfg pkg s
Michael Hanus 's avatar
Michael Hanus committed
113
114
115
116
117
118
119
120

--- Installs a package from the given package source to the global package
--- cache.
installFromSource :: Config -> Package -> PackageSource -> IO (ErrorLogger ())
installFromSource cfg pkg (Git url rev) = do
  pkgDirExists <- doesDirectoryExist pkgDir
  if pkgDirExists
    then
Michael Hanus 's avatar
Michael Hanus committed
121
      log Info $ "Package '" ++ packageId pkg ++ "' already installed, skipping"
Michael Hanus 's avatar
Michael Hanus committed
122
    else do
Michael Hanus 's avatar
Michael Hanus committed
123
      c <- inDirectory (packageInstallDir cfg) $ execQuietCmd cloneCommand
Michael Hanus 's avatar
Michael Hanus committed
124
125
126
      if c == 0
        then case rev of
          Nothing           -> checkoutGitRef pkgDir "HEAD"
Michael Hanus 's avatar
Michael Hanus committed
127
128
          Just (Tag tag)    -> checkoutGitRef pkgDir
                                              (replaceVersionInTag pkg tag)
Michael Hanus 's avatar
Michael Hanus committed
129
          Just (Ref ref)    -> checkoutGitRef pkgDir ref
Michael Hanus 's avatar
Michael Hanus committed
130
131
132
133
          Just VersionAsTag ->
            let tag = "v" ++ (showVersion $ version pkg) 
            in checkoutGitRef pkgDir tag |> 
               log Info ("Package '" ++ packageId pkg ++ "' installed")
Michael Hanus 's avatar
Michael Hanus committed
134
135
136
137
        else removeDirectoryComplete pkgDir >>
             failIO ("Failed to clone repository from '" ++ url ++
                     "', return code " ++ show c)
 where
Michael Hanus 's avatar
Michael Hanus committed
138
139
  pkgDir = packageInstallDir cfg </> packageId pkg
  cloneCommand q = unwords ["git clone", q, quote url, quote $ packageId pkg]
Michael Hanus 's avatar
Michael Hanus committed
140
141
142
143
144
145

installFromSource cfg pkg (FileSource zip) = do
  absZip <- getAbsolutePath zip
  pkgDirExists <- doesDirectoryExist pkgDir
  if pkgDirExists
    then
Michael Hanus 's avatar
Michael Hanus committed
146
      log Info $ "Package '" ++ packageId pkg ++ "' already installed, skipping"
Michael Hanus 's avatar
Michael Hanus committed
147
148
    else do 
      createDirectory pkgDir
Michael Hanus 's avatar
Michael Hanus committed
149
150
      c <- inTempDir $ showExecCmd $ "unzip -qq -d " ++ quote pkgDir ++
                                     " " ++ quote absZip
Michael Hanus 's avatar
Michael Hanus committed
151
152
153
154
155
156
157
158
      if c == 0
        then log Info $ "Installed " ++ (packageId pkg)
        else removeDirectoryComplete pkgDir >>
             failIO ("Failed to unzip package, return code " ++ show c)
 where
  pkgDir = (packageInstallDir cfg) </> (packageId pkg)

installFromSource cfg pkg (Http url) = do
Michael Hanus 's avatar
Michael Hanus committed
159
  c <- inTempDir $ showExecCmd $ "curl -s -o package.zip " ++ quote url
Michael Hanus 's avatar
Michael Hanus committed
160
161
162
163
  if c == 0
    then do
      pkgDirExists <- doesDirectoryExist pkgDir
      if pkgDirExists
Michael Hanus 's avatar
Michael Hanus committed
164
165
        then log Info $ "Package '" ++ packageId pkg ++
                        "' already installed, skipping"
Michael Hanus 's avatar
Michael Hanus committed
166
167
        else do
          createDirectory pkgDir
Michael Hanus 's avatar
Michael Hanus committed
168
169
          c' <- inTempDir $ showExecCmd $ "unzip -qq -d " ++ quote pkgDir ++
                                          " package.zip"
Michael Hanus 's avatar
Michael Hanus committed
170
171
          if c' == 0
            then do
Michael Hanus 's avatar
Michael Hanus committed
172
              c'' <- inTempDir $ showExecCmd ("rm package.zip")
Michael Hanus 's avatar
Michael Hanus committed
173
              if c'' == 0
Michael Hanus 's avatar
Michael Hanus committed
174
                then log Info ("Installed " ++ packageId pkg)
Michael Hanus 's avatar
Michael Hanus committed
175
176
177
178
179
180
181
182
183
184
185
186
                else failIO $ "failed to delete package.zip"
            else failIO $ "failed to unzip package.zip " ++ (show c')
    else failIO $ "curl failed with " ++ (show c)
 where
  pkgDir = (packageInstallDir cfg) </> (packageId pkg)

--- Installs a package from a ZIP file to the global package cache.
installFromZip :: Config -> String -> IO (ErrorLogger ())
installFromZip cfg zip = do
  t <- tempDir
  recreateDirectory (t </> "installtmp")
  absZip <- getAbsolutePath zip
Michael Hanus 's avatar
Michael Hanus committed
187
  c <- inTempDir $ showExecCmd $ "unzip -qq -d installtmp " ++ quote absZip
Michael Hanus 's avatar
Michael Hanus committed
188
189
190
191
192
193
194
195
196
197
198
199
200
  if c == 0
    then do
      loadPackageSpec (t </> "installtmp") |>=
        \pkgSpec -> log Debug ("ZIP contains " ++ (packageId pkgSpec)) |> 
        installFromSource cfg pkgSpec (FileSource zip)
    else failIO "failed to extract ZIP file"

--- Checks out a specific ref of a Git repository
--- 
--- @param dir - the directory containing the repo
--- @param ref - the ref to check out
checkoutGitRef :: String -> String -> IO (ErrorLogger ())
checkoutGitRef dir ref = do
Michael Hanus 's avatar
Michael Hanus committed
201
  c <- inDirectory dir $ execQuietCmd (\q -> unwords ["git checkout", q, ref])
Michael Hanus 's avatar
Michael Hanus committed
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
  if c == 0
    then succeedIO ()
    else removeDirectoryComplete dir >>
         failIO ("Failed to check out " ++ ref ++ ", return code " ++ show c)

--- Installs a package's missing dependencies.
installMissingDependencies :: Config -> GlobalCache -> [Package] 
                           -> IO (ErrorLogger ())
installMissingDependencies cfg gc deps = if length missing > 0
  then log Info logMsg |>
    mapEL (acquireAndInstallPackage cfg) missing |>
    succeedIO ()
  else succeedIO ()
 where
   missing = filter (not . isPackageInstalled gc) deps
   logMsg = "Installing missing dependencies " ++
            intercalate "," (map packageId missing)

--- Filters a list of packages to the ones not installed in the global package
--- cache.
missingPackages :: GlobalCache -> [Package] -> [Package]
missingPackages gc = filter (not . isPackageInstalled gc)

--- Checkout a package from the global package cache.
checkoutPackage :: Config -> Repository -> GlobalCache -> Package
                -> IO (ErrorLogger ())
checkoutPackage cfg _ _ pkg = do
  sexists <- doesDirectoryExist pkgDir
  texists <- doesDirectoryExist codir
  if texists
    then log Error $ "Local package directory '" ++ codir ++ "' already exists."
    else if sexists
           then copyDirectory pkgDir codir >> log Info logMsg
           else log Error $ "Package '" ++ pkgId ++ "' is not installed."
 where
  pkgId  = packageId pkg
  pkgDir = packageInstallDir cfg </> pkgId
  codir  = name pkg
  logMsg = "Package '" ++ pkgId ++ "' checked out into directory '" ++
           codir ++ "'."

--- Removes a package from the global package cache.
uninstallPackage :: Config -> Repository -> GlobalCache -> String -> Version 
                 -> IO (ErrorLogger ())
uninstallPackage cfg _ _ pkg ver = do
  exists <- doesDirectoryExist pkgDir
  if exists
Michael Hanus 's avatar
Michael Hanus committed
249
    then showExecCmd ("rm -Rf " ++ quote pkgDir) >> log Info logMsg
Michael Hanus 's avatar
Michael Hanus committed
250
251
252
    else log Info $ "Package '" ++ pkgId ++ "' is not installed."
 where
  pkgDir = (packageInstallDir cfg) </> pkgId
Michael Hanus 's avatar
Michael Hanus committed
253
  pkgId = pkg ++ "-" ++ showVersion ver
Michael Hanus 's avatar
Michael Hanus committed
254
255
256
257
258
259
  logMsg = "Package '" ++ pkgId ++ "' uninstalled."

--- Tries to find a package in the global package cache.
tryFindPackage :: GlobalCache -> String -> Version -> IO (ErrorLogger Package)
tryFindPackage gc name ver = case findVersion gc name ver of
  Just pkg -> succeedIO pkg
Michael Hanus 's avatar
Michael Hanus committed
260
261
  Nothing -> failIO $ "Package " ++ name ++ "-" ++ showVersion ver ++
                      " could not be found."
Michael Hanus 's avatar
Michael Hanus committed
262
263

--- Tries to read package specifications from a GC directory structure.
Michael Hanus 's avatar
Michael Hanus committed
264
265
266
267
268
269
270
271
--- If some GC package directory has the same name as a package from
--- the repository index, the package specification from the repository
--- is used, otherwise (this case should not occur) the package specification
--- stored in the directory is read.
--- This should result in faster GC loading.
readInstalledPackagesFromDir :: Repository -> String
                             -> IO (Either String GlobalCache)
readInstalledPackagesFromDir repo path = do
Michael Hanus 's avatar
Michael Hanus committed
272
273
  debugMessage $ "Reading global package cache from '" ++ path ++ "'..."
  pkgDirs <- checkAndGetDirectoryContents path
Michael Hanus 's avatar
Michael Hanus committed
274
275
  pkgPaths <- return $ filter (not . isPrefixOf ".") pkgDirs
  specs <- mapIO loadPackageSpecFromDir pkgPaths
Michael Hanus 's avatar
Michael Hanus committed
276
277
278
279
280
281
282
  if null (lefts specs)
    then do debugMessage "Finished reading global package cache"
            return (Right $ GlobalCache (rights specs))
    else return (Left $ intercalate "; " (lefts specs))
 where
  readPackageSpecIO = liftIO readPackageSpec

Michael Hanus 's avatar
Michael Hanus committed
283
284
285
286
287
288
289
290
291
292
293
  loadPackageSpecFromDir pkgdir = case packageVersionFromFile pkgdir of
    Nothing -> readPackageSpecFromFile pkgdir
    Just (pn,pv) -> case CPM.Repository.findVersion repo pn pv of
      Nothing -> readPackageSpecFromFile pkgdir
      Just p  -> do debugMessage $ "Package spec '" ++ packageId p ++
                                   "' loaded from repository"
                    return (Right p)

  readPackageSpecFromFile pkgdir = do
    let f = path </> pkgdir </> "package.json"
    debugMessage $ "Reading package spec from '" ++ f ++ "'..."
Michael Hanus 's avatar
Michael Hanus committed
294
    spec <- readPackageSpecIO $ readCompleteFile f
Michael Hanus 's avatar
Michael Hanus committed
295
296
297
298
    return $ case spec of
      Left err -> Left $ err ++ " for file '" ++ f ++ "'"
      Right  v -> Right v

Michael Hanus 's avatar
Michael Hanus committed
299
300
301
302
303
304
305
306
307
  packageVersionFromFile :: String -> Maybe (String, Version)
  packageVersionFromFile fn =
    let ps = split (=='-') fn
        l  = length ps
    in if l < 2
         then Nothing
         else case readVersion (last ps) of
                Nothing -> Nothing
                Just v  -> Just (intercalate "-" (take (l-1) ps), v)