PackageCopy.curry 13.4 KB
Newer Older
Michael Hanus's avatar
Michael Hanus committed
1
2
3
4
5
6
7
--------------------------------------------------------------------------------
--- Contains functions that operate on a package copy. And some functions that
--- don't quite fit anywhere else.
--------------------------------------------------------------------------------

module CPM.PackageCopy
  ( resolveDependenciesForPackageCopy
Michael Hanus's avatar
Michael Hanus committed
8
  , resolveAndCopyDependencies, resolveAndCopyDependenciesForPackage
Michael Hanus's avatar
Michael Hanus committed
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
  , resolveDependencies
  , upgradeAllPackages
  , upgradeSinglePackage
  , tryFindLocalPackageSpec
  , linkToLocalCache
  , acquireAndInstallPackageWithDependencies
  , installLocalDependencies
  , renderPackageInfo
  ) where

import Debug
import Directory (doesFileExist, getAbsolutePath, createDirectoryIfMissing
                 , doesDirectoryExist, getTemporaryDirectory
                 , getCurrentDirectory, setCurrentDirectory, createDirectory
                 , removeDirectory, getDirectoryContents, copyFile)
import FilePath ((</>), takeExtension, takeBaseName, joinPath, takeDirectory)
import AbstractCurry.Types (CurryProg)
import List (intercalate, splitOn)
import Maybe (mapMaybe, fromJust)
import System (system)
import Pretty hiding ((</>))

import CPM.AbstractCurry
import CPM.Config (Config, packageInstallDir)
import CPM.Repository (Repository, allPackages)
import qualified CPM.LookupSet as LS
import CPM.ErrorLogger
Michael Hanus's avatar
Michael Hanus committed
36
37
import CPM.FileUtil ( copyDirectory, recreateDirectory )
import CPM.Helpers  ( strip )
Michael Hanus's avatar
Michael Hanus committed
38
39
40
41
42
43
import qualified CPM.PackageCache.Global as GC
import qualified CPM.PackageCache.Runtime as RuntimeCache
import qualified CPM.PackageCache.Local as LocalCache
import CPM.Package ( Package (..)
                   , readPackageSpec, packageId, readVersion, Version 
                   , showVersion, PackageSource (..), showDependency
Michael Hanus's avatar
Michael Hanus committed
44
                   , showCompilerDependency, showPackageSource
Michael Hanus's avatar
Michael Hanus committed
45
                   , Dependency, GitRevision (..), PackageExecutable (..)
Michael Hanus's avatar
Michael Hanus committed
46
                   , PackageTest (..)
Michael Hanus's avatar
Michael Hanus committed
47
48
49
50
51
52
53
54
55
                   , packageIdEq, loadPackageSpec)
import CPM.Resolution

--- Resolves dependencies for a package copy.
resolveDependenciesForPackageCopy :: Config -> Package -> Repository 
                                  -> GC.GlobalCache -> String 
                                  -> IO (ErrorLogger ResolutionResult)
resolveDependenciesForPackageCopy cfg pkg repo gc dir = 
  lookupSetForPackageCopy cfg pkg repo gc dir |>= \lookupSet ->
56
  resolveDependenciesFromLookupSet cfg pkg lookupSet
Michael Hanus's avatar
Michael Hanus committed
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

--- Calculates the lookup set needed for dependency resolution on a package
--- copy.
lookupSetForPackageCopy :: Config -> Package -> Repository -> GC.GlobalCache 
                        -> String -> IO (ErrorLogger LS.LookupSet)
lookupSetForPackageCopy cfg _ repo gc dir =
  LocalCache.allPackages dir |>=
  \localPkgs -> do
    diffInLC <- mapIO filterGCLinked localPkgs
    let lsLC = LS.addPackages lsGC localPkgs LS.FromLocalCache in
      mapEL logSymlinkedPackage (mapMaybe id diffInLC) |>
      succeedIO lsLC
 where
  logSymlinkedPackage p = log Debug $ "Using symlinked version of '" ++ (packageId p) ++ "' from local cache."
  lsRepo = LS.addPackages LS.emptySet (allPackages repo) LS.FromRepository
  -- Find all packages that are in the global cache, but not in the repo
  newInGC = filter (\p -> not $ elemBy (packageIdEq p) (allPackages repo)) $ GC.allPackages gc
  lsGC = LS.addPackages lsRepo newInGC LS.FromGlobalCache
  filterGCLinked p = do
    points <- LocalCache.doesLinkPointToGlobalCache cfg gc dir (packageId p)
    return $ if points
      then Nothing
      else Just p

--- Resolves dependencies for a package.
82
83
resolveDependenciesForPackage :: Config -> Package -> Repository
                              -> GC.GlobalCache 
Michael Hanus's avatar
Michael Hanus committed
84
                              -> IO (ErrorLogger ResolutionResult)
85
86
resolveDependenciesForPackage cfg pkg repo gc = 
  resolveDependenciesFromLookupSet cfg pkg lookupSet
Michael Hanus's avatar
Michael Hanus committed
87
88
89
90
91
92
93
94
95
96
97
98
99
 where
  lsRepo = LS.addPackages LS.emptySet (allPackages repo) LS.FromRepository
  -- Find all packages that are in the global cache, but not in the repo
  newInGC = filter inGCButNotInRepo $ GC.allPackages gc
  inGCButNotInRepo p = not $ elemBy (packageIdEq p) (allPackages repo)
  lookupSet = LS.addPackages lsRepo newInGC LS.FromGlobalCache

--- Acquires a package and its dependencies and installs them to the global
--- package cache.
acquireAndInstallPackageWithDependencies :: Config -> Repository 
                                         -> GC.GlobalCache -> Package 
                                         -> IO (ErrorLogger ())
acquireAndInstallPackageWithDependencies cfg repo gc pkg = 
100
  resolveDependenciesForPackage cfg pkg repo gc |>=
Michael Hanus's avatar
Michael Hanus committed
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
  \result -> GC.installMissingDependencies cfg gc (resolvedPackages result) |>
  GC.acquireAndInstallPackage cfg pkg

elemBy :: (a -> Bool) -> [a] -> Bool
elemBy _ [] = False
elemBy f (x:xs) = if f x 
  then True
  else elemBy f xs

--- Links the dependencies of a package to its local cache and copies them to
--- its runtime cache.
copyDependencies :: Config -> GC.GlobalCache -> Package -> [Package] -> String 
                 -> IO (ErrorLogger ())
copyDependencies cfg gc pkg pkgs dir = 
  LocalCache.linkPackages cfg dir gc pkgs |>
  RuntimeCache.copyPackages cfg pkgs' dir >> succeedIO ()
 where 
  pkgs' = filter (/= pkg) pkgs

--- Upgrades all dependencies of a package copy.
upgradeAllPackages :: Config -> Repository -> GC.GlobalCache -> String 
                   -> IO (ErrorLogger ())
upgradeAllPackages cfg repo gc dir = loadPackageSpec dir |>=
  \pkgSpec -> LocalCache.clearCache dir >> succeedIO () |>
  installLocalDependencies cfg repo gc dir |>=
  \ (_,deps) -> copyDependencies cfg gc pkgSpec deps dir

--- Upgrades a single dependencies and its transitive dependencies.
upgradeSinglePackage :: Config -> Repository -> GC.GlobalCache -> String 
                     -> String -> IO (ErrorLogger ())
upgradeSinglePackage cfg repo gc dir pkgName = loadPackageSpec dir |>=
  \pkgSpec -> lookupSetForPackageCopy cfg pkgSpec repo gc dir |>=
  \originalLS -> let transitiveDeps = pkgName : allTransitiveDependencies originalLS pkgName in
134
135
  resolveDependenciesFromLookupSet cfg pkgSpec
                        (LS.setLocallyIgnored originalLS transitiveDeps) |>=
Michael Hanus's avatar
Michael Hanus committed
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
  \result -> GC.installMissingDependencies cfg gc (resolvedPackages result) |>
  log Info (showDependencies result) |>
  copyDependencies cfg gc pkgSpec (resolvedPackages result) dir

--- Installs the dependencies of a package.
installLocalDependencies :: Config -> Repository -> GC.GlobalCache -> String 
                         -> IO (ErrorLogger (Package,[Package]))
installLocalDependencies cfg repo gc dir =
  loadPackageSpec dir |>= \pkgSpec ->
  resolveDependenciesForPackageCopy cfg pkgSpec repo gc dir |>= \result ->
  GC.installMissingDependencies cfg gc (resolvedPackages result) |>
  log Info (showDependencies result) |> 
  copyDependencies cfg gc pkgSpec (resolvedPackages result) dir |>
  succeedIO (pkgSpec, resolvedPackages result)

--- Links a directory into the local package cache. Used for cpm link.
linkToLocalCache :: String -> String -> IO (ErrorLogger ())
linkToLocalCache src pkgDir = do
  dirExists <- doesDirectoryExist src
  if dirExists
Michael Hanus's avatar
Michael Hanus committed
156
157
158
    then loadPackageSpec src |>= \pkgSpec ->
         LocalCache.createLink pkgDir src (packageId pkgSpec) True |> 
         succeedIO ()
Michael Hanus's avatar
Michael Hanus committed
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
    else log Critical ("Directory '" ++ src ++ "' does not exist.") |>
         succeedIO ()

--- Tries to find a package specification in the current directory or one of its
--- ancestors.
tryFindLocalPackageSpec :: String -> IO (ErrorLogger String)
tryFindLocalPackageSpec dir = do
  existsLocal <- doesFileExist $ dir </> "package.json"
  if existsLocal
    then succeedIO dir
    else log Debug ("No package.json in " ++ show dir ++ ", trying " ++
                    show (dir </> "..")) |> do
      parentExists <- doesDirectoryExist $ dir </> ".."
      if parentExists
        then tryFindLocalPackageSpec $ dir </> ".."
        else failIO "No package.json found"

--- Resolves the dependencies for a package copy and fills the package caches.
resolveAndCopyDependencies :: Config -> Repository -> GC.GlobalCache -> String 
                           -> IO (ErrorLogger [Package])
Michael Hanus's avatar
Michael Hanus committed
179
180
181
182
183
184
185
186
187
188
189
190
191
192
resolveAndCopyDependencies cfg repo gc dir =
  loadPackageSpec dir |>= resolveAndCopyDependenciesForPackage cfg repo gc dir

--- Resolves the dependencies for a package copy and fills the package caches.
resolveAndCopyDependenciesForPackage ::
     Config -> Repository -> GC.GlobalCache -> String -> Package
  -> IO (ErrorLogger [Package])
resolveAndCopyDependenciesForPackage cfg repo gc dir pkgSpec =
  resolveDependenciesForPackageCopy cfg pkgSpec repo gc dir |>= \result -> 
    let deps = resolvedPackages result
        missingDeps = GC.missingPackages gc deps 
        failMsg = "Missing dependencies " 
                  ++ (intercalate "," $ map packageId missingDeps) 
                  ++ "\nUse `cpm install` to install missing dependencies."
Michael Hanus's avatar
Michael Hanus committed
193
194
195
196
197
198
199
200
201
202
203
204
205
    in if length missingDeps > 0
         then failIO failMsg
         else copyDependencies cfg gc pkgSpec deps dir |>= \_ ->
              succeedIO deps

--- Resolves the dependencies for a package copy.
resolveDependencies :: Config -> Repository -> GC.GlobalCache -> String 
                    -> IO (ErrorLogger ResolutionResult)
resolveDependencies cfg repo gc dir = loadPackageSpec dir |->
  log Info ("Read package spec from " ++ dir) |>=
  \pkgSpec -> resolveDependenciesForPackageCopy cfg pkgSpec repo gc dir

--- Renders information on a package.
Michael Hanus's avatar
Michael Hanus committed
206
207
renderPackageInfo :: Bool -> Bool -> GC.GlobalCache -> Package -> String
renderPackageInfo allinfos plain gc pkg = pPrint doc
Michael Hanus's avatar
Michael Hanus committed
208
 where
Michael Hanus's avatar
Michael Hanus committed
209
  boldText s = (if plain then id else bold) $ text s
Michael Hanus's avatar
Michael Hanus committed
210
211
212
213
  maxLen = 12
  doc = vcat $ [ heading, rule, installed, ver, auth, maintnr, synop
               , cats, deps, compilers, descr ] ++
               if allinfos
Michael Hanus's avatar
Michael Hanus committed
214
                 then [ srcdirs, expmods, cfgmod, execspec] ++ testsuites ++
Michael Hanus's avatar
Michael Hanus committed
215
                      [ src, licns, licfl, copyrt, homepg, reposy, bugrep]
Michael Hanus's avatar
Michael Hanus committed
216
217
218
219
220
221
                 else []

  pkgId = packageId pkg
  isInstalled = GC.isPackageInstalled gc pkg

  heading   = text pkgId 
Michael Hanus's avatar
Michael Hanus committed
222
223
  installed = if isInstalled || plain then empty
                                      else red $ text "Not installed"
Michael Hanus's avatar
Michael Hanus committed
224
  rule      = text (take (length pkgId) $ repeat '-')
Michael Hanus's avatar
Michael Hanus committed
225
  ver       = fill maxLen (boldText "Version") <+>
Michael Hanus's avatar
Michael Hanus committed
226
              (text $ showVersion $ version pkg)
Michael Hanus's avatar
Michael Hanus committed
227
228
  auth      = fill maxLen (boldText "Author") <+>
              indent 0 (fillSep (map (text . strip) (splitOn "," $ author pkg)))
Michael Hanus's avatar
Michael Hanus committed
229
  synop     = fill maxLen (boldText "Synopsis") <+>
Michael Hanus's avatar
Michael Hanus committed
230
              indent 0 (fillSep (map text (words (synopsis pkg))))
Michael Hanus's avatar
Michael Hanus committed
231
  deps      = boldText "Dependencies" <$$>
Michael Hanus's avatar
Michael Hanus committed
232
233
234
235
              (vcat $ map (indent 4 . text . showDependency) $ dependencies pkg)

  maintnr = case maintainer pkg of
    Nothing -> empty
Michael Hanus's avatar
Michael Hanus committed
236
237
    Just  s -> fill maxLen (boldText "Maintainer") <+>
               indent 0 (fillSep (map (text . strip) (splitOn "," s)))
Michael Hanus's avatar
Michael Hanus committed
238
239
240
241

  cats =
    if null (category pkg)
      then empty
Michael Hanus's avatar
Michael Hanus committed
242
      else fill maxLen (boldText "Category") <+>
Michael Hanus's avatar
Michael Hanus committed
243
           indent 0 (fillSep (map text (category pkg)))
Michael Hanus's avatar
Michael Hanus committed
244
245
246

  execspec = case executableSpec pkg of
    Nothing -> empty
Michael Hanus's avatar
Michael Hanus committed
247
    Just  (PackageExecutable n m eopts) ->
Michael Hanus's avatar
Michael Hanus committed
248
249
      boldText "Executable" <$$>
      indent 4 (boldText "Name         " <+> text n) <$$>
Michael Hanus's avatar
Michael Hanus committed
250
251
252
253
254
      indent 4 (boldText "Main module  " <+> text m) <$$>
      if null eopts
        then empty
        else indent 4 (boldText "Options      ") <+>
             align (vsep (map (\ (c,o) -> text $ c ++ ": " ++ o) eopts))
Michael Hanus's avatar
Michael Hanus committed
255
256
257

  testsuites = case testSuite pkg of
    Nothing -> []
Michael Hanus's avatar
Michael Hanus committed
258
    Just  tests ->
Michael Hanus's avatar
Michael Hanus committed
259
260
      map (\ (PackageTest dir mods opts script) ->
            let check = if null script then "Check" else "Test" in
Michael Hanus's avatar
Michael Hanus committed
261
262
            boldText "Test suite" <$$>
            indent 4 (boldText "Directory    " <+> text dir) <$$>
Michael Hanus's avatar
Michael Hanus committed
263
264
            (if null script
               then empty
Michael Hanus's avatar
Michael Hanus committed
265
               else indent 4 (boldText "Test script  " <+> text script)) <$$>
Michael Hanus's avatar
Michael Hanus committed
266
267
            (if null opts
               then empty
Michael Hanus's avatar
Michael Hanus committed
268
               else indent 4 (boldText (check++" options") <+>
Michael Hanus's avatar
Michael Hanus committed
269
270
271
                              text opts)) <$$>
            (if null mods
               then empty
Michael Hanus's avatar
Michael Hanus committed
272
               else indent 4 (boldText "Test modules " <+>
Michael Hanus's avatar
Michael Hanus committed
273
                    align (fillSep (map text mods)))))
Michael Hanus's avatar
Michael Hanus committed
274
275
276
          tests

  descr  = showParaField description  "Description"
Michael Hanus's avatar
Michael Hanus committed
277
278
  licns  = showLineField license      "License"
  licfl  = showLineField licenseFile  "License file"
Michael Hanus's avatar
Michael Hanus committed
279
280
281
282
283
284
  copyrt = showParaField copyright    "Copyright"
  homepg = showLineField homepage     "Homepage"
  reposy = showLineField repository   "Repository"
  bugrep = showLineField bugReports   "Bug reports"
  cfgmod = showLineField configModule "Config module"

Michael Hanus's avatar
Michael Hanus committed
285
286
287
288
  src = maybe empty
              (\_ -> boldText "Source" <$$>
                     indent 4 (text $ showPackageSource pkg))
              (source pkg)
Michael Hanus's avatar
Michael Hanus committed
289

Michael Hanus's avatar
Michael Hanus committed
290
291
292
  srcdirs =
    if null (sourceDirs pkg)
      then empty
Michael Hanus's avatar
Michael Hanus committed
293
      else boldText "Source directories" <$$>
Michael Hanus's avatar
Michael Hanus committed
294
295
           indent 4 (fillSep (map text (sourceDirs pkg)))

Michael Hanus's avatar
Michael Hanus committed
296
297
298
  expmods =
    if null (exportedModules pkg)
      then empty
Michael Hanus's avatar
Michael Hanus committed
299
      else boldText "Exported modules" <$$>
Michael Hanus's avatar
Michael Hanus committed
300
301
302
303
304
           indent 4 (fillSep (map text (exportedModules pkg)))

  compilers =
    if null (compilerCompatibility pkg)
      then empty
Michael Hanus's avatar
Michael Hanus committed
305
      else boldText "Compiler compatibility" <$$>
Michael Hanus's avatar
Michael Hanus committed
306
307
308
309
310
           (vcat $ map (indent 4 . text . showCompilerDependency)
                 $ compilerCompatibility pkg)

  showLineField fgetter fname = case fgetter pkg of
    Nothing -> empty
Michael Hanus's avatar
Michael Hanus committed
311
    Just  s -> boldText fname <$$> indent 4 (text s)
Michael Hanus's avatar
Michael Hanus committed
312
313
314

  showParaField fgetter fname = case fgetter pkg of
    Nothing -> empty
Michael Hanus's avatar
Michael Hanus committed
315
    Just  s -> boldText fname <$$>
Michael Hanus's avatar
Michael Hanus committed
316
317
               indent 4 (fillSep (map text (words s)))