Global.curry 10.8 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
99
100
101
102
103
104
105
106
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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
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
247
248
249
250
251
252
253
254
255
256
257
258
259
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
286
287
288
289
290
291
292
293
--------------------------------------------------------------------------------
--- 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 System (system)

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
    then failIO $ "Package " ++ (packageId pkg) ++ " not installed"
    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
  Nothing -> failIO $ "No source specified for " ++ (packageId pkg)
  Just  s -> log Info ("Installing package from " ++ showSource s) |> 
    installFromSource cfg pkg s
 where
  showSource (Git url rev) = "Git " ++ url ++ showGitRev rev
  showSource (Http url) = url
  showSource (FileSource url) = "File " ++ url
  showGitRev (Just (Ref ref)) = "@" ++ ref
  showGitRev (Just (Tag tag)) = "@" ++ tag
  showGitRev (Just VersionAsTag) = "@v" ++ (showVersion $ version pkg)
  showGitRev Nothing = ""

--- 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
      log Info $ "Package " ++ packageId pkg ++ " already installed, skipping"
    else do
      c <- inDirectory (packageInstallDir cfg) $ system cloneCommand
      if c == 0
        then case rev of
          Nothing           -> checkoutGitRef pkgDir "HEAD"
          Just (Tag tag)    -> checkoutGitRef pkgDir tag
          Just (Ref ref)    -> checkoutGitRef pkgDir ref
          Just VersionAsTag -> let tag = "v" ++ (showVersion $ version pkg) 
                                in checkoutGitRef pkgDir tag |> 
                                  log Info ("Package " ++ (packageId pkg) ++
                                            " installed")
        else removeDirectoryComplete pkgDir >>
             failIO ("Failed to clone repository from '" ++ url ++
                     "', return code " ++ show c)
 where
  pkgDir = (packageInstallDir cfg) </> (packageId pkg)
  cloneCommand = "git clone " ++ (quote url) ++ " " ++ (quote $ packageId pkg)

installFromSource cfg pkg (FileSource zip) = do
  absZip <- getAbsolutePath zip
  pkgDirExists <- doesDirectoryExist pkgDir
  if pkgDirExists
    then
      log Info $ "Package " ++ packageId pkg ++ " already installed, skipping"
    else do 
      createDirectory pkgDir
      c <- inTempDir $ system $ "unzip -qq -d " ++ (quote pkgDir) ++
                                " " ++ (quote absZip)
      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
  c <- inTempDir $ system $ "curl -s -o package.zip " ++ (quote url)
  if c == 0
    then do
      pkgDirExists <- doesDirectoryExist pkgDir
      if pkgDirExists
        then log Info $ "Package " ++ packageId pkg ++
                        " already installed, skipping"
        else do
          createDirectory pkgDir
          c' <- inTempDir $ system $ "unzip -qq -d " ++ (quote pkgDir) ++
                                     " package.zip"
          if c' == 0
            then do
              c'' <- inTempDir $ system ("rm package.zip")
              if c'' == 0
                then log Info ("Installed " ++ (packageId pkg))
                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
  c <- inTempDir $ system $ "unzip -qq -d installtmp " ++ (quote absZip)
  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
  c <- inDirectory dir $ system $ "git checkout " ++ ref
  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
    then system ("rm -Rf " ++ (quote pkgDir)) >> log Info logMsg
    else log Info $ "Package '" ++ pkgId ++ "' is not installed."
 where
  pkgDir = (packageInstallDir cfg) </> pkgId
  pkgId = pkg ++ "-" ++ (showVersion ver)
  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
  Nothing -> failIO $ "Package " ++ name ++ "-" ++ (showVersion ver) ++ " could not be found."

--- 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 ++ "\""