Global.curry 10.5 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
36
37
38
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
90
91
92
93
94
95
96
97
98
--------------------------------------------------------------------------------
--- 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
                    , checkAndGetDirectoryContents )
import CPM.Package

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

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

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

--- Tries to read package specifications from a GC directory structure.
readInstalledPackagesFromDir :: String -> IO (Either String GlobalCache)
readInstalledPackagesFromDir path = do
  debugMessage $ "Reading global package cache from '" ++ path ++ "'..."
  pkgDirs <- checkAndGetDirectoryContents path
  pkgPaths <- return $ map (path </>) $ filter (not . isPrefixOf ".") pkgDirs
  specPaths <- return $ map (</> "package.json") pkgPaths
  specs <- mapIO readPackageSpecFromFile specPaths
  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

  readPackageSpecFromFile f = do
    spec <- readPackageSpecIO $ readFile f
    return $ case spec of
      Left err -> Left $ err ++ " for file '" ++ f ++ "'"
      Right  v -> Right v

quote :: String -> String
quote s = "\"" ++ s ++ "\""