Global.curry 11.6 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
28
29
30
31
32
33
34
35
--------------------------------------------------------------------------------
--- 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
import List
import Maybe (isJust)
import FilePath

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

--- 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
90
91
installedPackageDir cfg pkg =
  base  </> (name pkg ++ "-" ++ (showVersion $ version pkg))
Michael Hanus 's avatar
Michael Hanus committed
92
93
94
95
96
97
98
99
 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
100
    then failIO $ "Package '" ++ packageId pkg ++ "' not installed"
Michael Hanus 's avatar
Michael Hanus committed
101
102
103
104
105
106
107
108
    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
109
110
111
  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
112
113
114
115
116
117
118
119

--- 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
120
      log Info $ "Package '" ++ packageId pkg ++ "' already installed, skipping"
Michael Hanus 's avatar
Michael Hanus committed
121
    else do
Michael Hanus 's avatar
Michael Hanus committed
122
      c <- inDirectory (packageInstallDir cfg) $ execQuietCmd cloneCommand
Michael Hanus 's avatar
Michael Hanus committed
123
124
125
      if c == 0
        then case rev of
          Nothing           -> checkoutGitRef pkgDir "HEAD"
Michael Hanus 's avatar
Michael Hanus committed
126
127
          Just (Tag tag)    -> checkoutGitRef pkgDir
                                              (replaceVersionInTag pkg tag)
Michael Hanus 's avatar
Michael Hanus committed
128
          Just (Ref ref)    -> checkoutGitRef pkgDir ref
Michael Hanus 's avatar
Michael Hanus committed
129
130
131
132
          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
133
134
135
136
        else removeDirectoryComplete pkgDir >>
             failIO ("Failed to clone repository from '" ++ url ++
                     "', return code " ++ show c)
 where
Michael Hanus 's avatar
Michael Hanus committed
137
138
  pkgDir = packageInstallDir cfg </> packageId pkg
  cloneCommand q = unwords ["git clone", q, quote url, quote $ packageId pkg]
Michael Hanus 's avatar
Michael Hanus committed
139
140
141
142
143
144

installFromSource cfg pkg (FileSource zip) = do
  absZip <- getAbsolutePath zip
  pkgDirExists <- doesDirectoryExist pkgDir
  if pkgDirExists
    then
Michael Hanus 's avatar
Michael Hanus committed
145
      log Info $ "Package '" ++ packageId pkg ++ "' already installed, skipping"
Michael Hanus 's avatar
Michael Hanus committed
146
147
    else do 
      createDirectory pkgDir
Michael Hanus 's avatar
Michael Hanus committed
148
149
      c <- inTempDir $ showExecCmd $ "unzip -qq -d " ++ quote pkgDir ++
                                     " " ++ quote absZip
Michael Hanus 's avatar
Michael Hanus committed
150
151
152
153
154
155
156
157
      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
158
  c <- inTempDir $ showExecCmd $ "curl -s -o package.zip " ++ quote url
Michael Hanus 's avatar
Michael Hanus committed
159
160
161
162
  if c == 0
    then do
      pkgDirExists <- doesDirectoryExist pkgDir
      if pkgDirExists
Michael Hanus 's avatar
Michael Hanus committed
163
164
        then log Info $ "Package '" ++ packageId pkg ++
                        "' already installed, skipping"
Michael Hanus 's avatar
Michael Hanus committed
165
166
        else do
          createDirectory pkgDir
Michael Hanus 's avatar
Michael Hanus committed
167
168
          c' <- inTempDir $ showExecCmd $ "unzip -qq -d " ++ quote pkgDir ++
                                          " package.zip"
Michael Hanus 's avatar
Michael Hanus committed
169
170
          if c' == 0
            then do
Michael Hanus 's avatar
Michael Hanus committed
171
              c'' <- inTempDir $ showExecCmd ("rm package.zip")
Michael Hanus 's avatar
Michael Hanus committed
172
              if c'' == 0
Michael Hanus 's avatar
Michael Hanus committed
173
                then log Info ("Installed " ++ packageId pkg)
Michael Hanus 's avatar
Michael Hanus committed
174
175
176
177
178
179
180
181
182
183
184
185
                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
186
  c <- inTempDir $ showExecCmd $ "unzip -qq -d installtmp " ++ quote absZip
Michael Hanus 's avatar
Michael Hanus committed
187
188
189
190
191
192
193
194
195
196
197
198
199
  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
200
  c <- inDirectory dir $ execQuietCmd (\q -> unwords ["git checkout", q, ref])
Michael Hanus 's avatar
Michael Hanus committed
201
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
  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
248
    then showExecCmd ("rm -Rf " ++ quote pkgDir) >> log Info logMsg
Michael Hanus 's avatar
Michael Hanus committed
249
250
251
    else log Info $ "Package '" ++ pkgId ++ "' is not installed."
 where
  pkgDir = (packageInstallDir cfg) </> pkgId
Michael Hanus 's avatar
Michael Hanus committed
252
  pkgId = pkg ++ "-" ++ showVersion ver
Michael Hanus 's avatar
Michael Hanus committed
253
254
255
256
257
258
  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
259
260
  Nothing -> failIO $ "Package " ++ name ++ "-" ++ showVersion ver ++
                      " could not be found."
Michael Hanus 's avatar
Michael Hanus committed
261
262

--- Tries to read package specifications from a GC directory structure.
Michael Hanus 's avatar
Michael Hanus committed
263
264
265
266
267
268
269
270
--- 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
271
272
  debugMessage $ "Reading global package cache from '" ++ path ++ "'..."
  pkgDirs <- checkAndGetDirectoryContents path
Michael Hanus 's avatar
Michael Hanus committed
273
274
  pkgPaths <- return $ filter (not . isPrefixOf ".") pkgDirs
  specs <- mapIO loadPackageSpecFromDir pkgPaths
Michael Hanus 's avatar
Michael Hanus committed
275
276
277
278
279
280
281
  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
282
283
284
285
286
287
288
289
290
291
292
  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
293
294
295
296
297
    spec <- readPackageSpecIO $ readFile f
    return $ case spec of
      Left err -> Left $ err ++ " for file '" ++ f ++ "'"
      Right  v -> Right v

Michael Hanus 's avatar
Michael Hanus committed
298
299
300
301
302
303
304
305
306
  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)