PackageCopy.curry 9.81 KB
Newer Older
Michael Hanus's avatar
Michael Hanus committed
1
--------------------------------------------------------------------------------
Michael Hanus's avatar
Michael Hanus committed
2
--- This module contains operations that operate on a package copy.
Michael Hanus's avatar
Michael Hanus committed
3
4
5
6
--------------------------------------------------------------------------------

module CPM.PackageCopy
  ( resolveDependenciesForPackageCopy
Michael Hanus's avatar
Michael Hanus committed
7
  , resolveAndCopyDependencies, resolveAndCopyDependenciesForPackage
Michael Hanus's avatar
Michael Hanus committed
8
9
10
11
12
13
14
15
  , resolveDependencies
  , upgradeAllPackages
  , upgradeSinglePackage
  , linkToLocalCache
  , acquireAndInstallPackageWithDependencies
  , installLocalDependencies
  ) where

Michael Hanus's avatar
Michael Hanus committed
16
17
18
import Directory ( doesDirectoryExist )
import List      ( intercalate )
import Maybe     ( mapMaybe )
Michael Hanus's avatar
Michael Hanus committed
19

Michael Hanus's avatar
Michael Hanus committed
20
import CPM.Config     ( Config, baseVersion )
Michael Hanus's avatar
Michael Hanus committed
21
22
import CPM.Repository ( Repository, allPackages )
import CPM.Repository.Select
Michael Hanus's avatar
Michael Hanus committed
23
24
25
26
27
import qualified CPM.LookupSet as LS
import CPM.ErrorLogger
import qualified CPM.PackageCache.Global as GC
import qualified CPM.PackageCache.Runtime as RuntimeCache
import qualified CPM.PackageCache.Local as LocalCache
Michael Hanus's avatar
Michael Hanus committed
28
import CPM.Package
Michael Hanus's avatar
Michael Hanus committed
29
30
31
32
33
34
35
36
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 ->
Michael Hanus's avatar
Michael Hanus committed
37
  resolveDependenciesFromLookupSet cfg (setBaseDependency cfg pkg) lookupSet
Michael Hanus's avatar
Michael Hanus committed
38
39
40
41
42
43

--- 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 =
Michael Hanus's avatar
Michael Hanus committed
44
  LocalCache.allPackages dir |>= \localPkgs -> do
Michael Hanus's avatar
Michael Hanus committed
45
    diffInLC <- mapIO filterGCLinked localPkgs
Michael Hanus's avatar
Michael Hanus committed
46
    let lsLC = addPackagesWOBase cfg lsGC localPkgs LS.FromLocalCache in
Michael Hanus's avatar
Michael Hanus committed
47
48
49
      mapEL logSymlinkedPackage (mapMaybe id diffInLC) |>
      succeedIO lsLC
 where
Michael Hanus's avatar
Michael Hanus committed
50
51
52
53
  allRepoPackages = allPackages repo
  logSymlinkedPackage p = log Debug $ "Using symlinked version of '" ++
                                      packageId p ++ "' from local cache."
  lsRepo = addPackagesWOBase cfg LS.emptySet allRepoPackages LS.FromRepository
Michael Hanus's avatar
Michael Hanus committed
54
  -- Find all packages that are in the global cache, but not in the repo
Michael Hanus's avatar
Michael Hanus committed
55
  newInGC = filter (\p -> not $ any (packageIdEq p) allRepoPackages)
Michael Hanus's avatar
Michael Hanus committed
56
57
                   (GC.allPackages gc)
  lsGC = addPackagesWOBase cfg lsRepo newInGC LS.FromGlobalCache
Michael Hanus's avatar
Michael Hanus committed
58
  filterGCLinked p = do
Michael Hanus's avatar
Michael Hanus committed
59
    points <- LocalCache.doesLinkPointToGlobalCache cfg dir (packageId p)
Michael Hanus's avatar
Michael Hanus committed
60
61
62
63
64
    return $ if points
      then Nothing
      else Just p

--- Resolves dependencies for a package.
65
66
resolveDependenciesForPackage :: Config -> Package -> Repository
                              -> GC.GlobalCache 
Michael Hanus's avatar
Michael Hanus committed
67
                              -> IO (ErrorLogger ResolutionResult)
68
resolveDependenciesForPackage cfg pkg repo gc = 
Michael Hanus's avatar
Michael Hanus committed
69
  resolveDependenciesFromLookupSet cfg (setBaseDependency cfg pkg) lookupSet
Michael Hanus's avatar
Michael Hanus committed
70
 where
Michael Hanus's avatar
Michael Hanus committed
71
72
  lsRepo = addPackagesWOBase cfg LS.emptySet (allPackages repo)
                             LS.FromRepository
Michael Hanus's avatar
Michael Hanus committed
73
74
  -- Find all packages that are in the global cache, but not in the repo
  newInGC = filter inGCButNotInRepo $ GC.allPackages gc
Michael Hanus's avatar
Michael Hanus committed
75
  inGCButNotInRepo p = not $ any (packageIdEq p) (allPackages repo)
Michael Hanus's avatar
Michael Hanus committed
76
  lookupSet = addPackagesWOBase cfg lsRepo newInGC LS.FromGlobalCache
Michael Hanus's avatar
Michael Hanus committed
77
78
79

--- Acquires a package and its dependencies and installs them to the global
--- package cache.
Michael Hanus's avatar
Michael Hanus committed
80
acquireAndInstallPackageWithDependencies :: Config -> Repository -> Package
Michael Hanus's avatar
Michael Hanus committed
81
                                         -> IO (ErrorLogger ())
Michael Hanus's avatar
Michael Hanus committed
82
83
acquireAndInstallPackageWithDependencies cfg repo pkg = 
  GC.readGlobalCache cfg repo |>= \gc ->
Michael Hanus's avatar
Michael Hanus committed
84
85
  resolveDependenciesForPackage cfg pkg repo gc |>= \result ->
  GC.installMissingDependencies cfg gc (resolvedPackages result) |>
Michael Hanus's avatar
Michael Hanus committed
86
87
88
  GC.acquireAndInstallPackage cfg pkg

--- Links the dependencies of a package to its local cache and copies them to
89
--- its runtime cache. Returns the package specifications of the dependencies.
Michael Hanus's avatar
Michael Hanus committed
90
copyDependencies :: Config -> Package -> [Package] -> String 
91
                 -> IO (ErrorLogger [Package])
Michael Hanus's avatar
Michael Hanus committed
92
93
copyDependencies cfg pkg pkgs dir = 
  LocalCache.linkPackages cfg dir pkgs |>
94
95
  RuntimeCache.copyPackages cfg pkgs' dir |>= \pkgspecs ->
  succeedIO (if pkg `elem` pkgs then pkg : pkgspecs else pkgspecs)
Michael Hanus's avatar
Michael Hanus committed
96
97
98
99
 where 
  pkgs' = filter (/= pkg) pkgs

--- Upgrades all dependencies of a package copy.
Michael Hanus's avatar
Michael Hanus committed
100
101
upgradeAllPackages :: Config -> String -> IO (ErrorLogger ())
upgradeAllPackages cfg dir =
Michael Hanus's avatar
Michael Hanus committed
102
103
  loadPackageSpec dir |>= \pkgSpec ->
  LocalCache.clearCache dir >> succeedIO () |>
Michael Hanus's avatar
Michael Hanus committed
104
  installLocalDependencies cfg dir |>= \ (_,deps) ->
105
  copyDependencies cfg pkgSpec deps dir |> succeedIO ()
Michael Hanus's avatar
Michael Hanus committed
106
107

--- Upgrades a single package and its transitive dependencies.
Michael Hanus's avatar
Michael Hanus committed
108
109
upgradeSinglePackage :: Config -> String -> String -> IO (ErrorLogger ())
upgradeSinglePackage cfg dir pkgName =
Michael Hanus's avatar
Michael Hanus committed
110
  loadPackageSpec dir |>= \pkgSpec ->
Michael Hanus's avatar
Michael Hanus committed
111
  getRepoForPackageSpec cfg pkgSpec >>= \repo ->
Michael Hanus's avatar
Michael Hanus committed
112
113
114
  GC.readGlobalCache cfg repo |>= \gc ->
  lookupSetForPackageCopy cfg pkgSpec repo gc dir |>= \originalLS ->
  let transitiveDeps = pkgName : allTransitiveDependencies originalLS pkgName in
Michael Hanus's avatar
Michael Hanus committed
115
  resolveDependenciesFromLookupSet cfg (setBaseDependency cfg pkgSpec)
116
                        (LS.setLocallyIgnored originalLS transitiveDeps) |>=
Michael Hanus's avatar
Michael Hanus committed
117
118
  \result -> GC.installMissingDependencies cfg gc (resolvedPackages result) |>
  log Info (showDependencies result) |>
119
  copyDependencies cfg pkgSpec (resolvedPackages result) dir |> succeedIO ()
Michael Hanus's avatar
Michael Hanus committed
120
121

--- Installs the dependencies of a package.
Michael Hanus's avatar
Michael Hanus committed
122
installLocalDependencies :: Config -> String
Michael Hanus's avatar
Michael Hanus committed
123
                         -> IO (ErrorLogger (Package,[Package]))
Michael Hanus's avatar
Michael Hanus committed
124
installLocalDependencies cfg dir =
Michael Hanus's avatar
Michael Hanus committed
125
  loadPackageSpec dir |>= \pkgSpec ->
Michael Hanus's avatar
Michael Hanus committed
126
127
128
129
130
131
132
  getRepoForPackageSpec cfg pkgSpec >>= \repo ->
  installLocalDependenciesWithRepo cfg repo dir pkgSpec

--- Installs the dependencies of a package.
installLocalDependenciesWithRepo :: Config -> Repository -> String -> Package
                                 -> IO (ErrorLogger (Package,[Package]))
installLocalDependenciesWithRepo cfg repo dir pkgSpec =
Michael Hanus's avatar
Michael Hanus committed
133
  GC.readGlobalCache cfg repo |>= \gc ->
Michael Hanus's avatar
Michael Hanus committed
134
135
136
  resolveDependenciesForPackageCopy cfg pkgSpec repo gc dir |>= \result ->
  GC.installMissingDependencies cfg gc (resolvedPackages result) |>
  log Info (showDependencies result) |> 
137
138
  copyDependencies cfg pkgSpec (resolvedPackages result) dir |>= \cpkgs ->
  succeedIO (pkgSpec, cpkgs)
Michael Hanus's avatar
Michael Hanus committed
139

Michael Hanus's avatar
Michael Hanus committed
140
--- Links a directory into the local package cache. Used for `cypm link`.
Michael Hanus's avatar
Michael Hanus committed
141
142
linkToLocalCache :: Config -> String -> String -> IO (ErrorLogger ())
linkToLocalCache cfg src pkgDir = do
Michael Hanus's avatar
Michael Hanus committed
143
144
  dirExists <- doesDirectoryExist src
  if dirExists
Michael Hanus's avatar
Michael Hanus committed
145
    then loadPackageSpec src |>= \pkgSpec ->
Michael Hanus's avatar
Michael Hanus committed
146
147
148
149
150
151
152
153
         getPackageVersion cfg (name pkgSpec) (version pkgSpec) >>=
         maybe
           (log Critical
                ("Package '" ++ packageId pkgSpec ++ "' not in repository!\n" ++
                 "Note: you can only link copies of existing packages."))
           (\_ -> LocalCache.createLink pkgDir src (packageId pkgSpec) True |> 
                  succeedIO ())
    else log Critical ("Directory '" ++ src ++ "' does not exist.")
Michael Hanus's avatar
Michael Hanus committed
154
155
156
157

--- 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
158
resolveAndCopyDependencies cfg repo gc dir =
Michael Hanus's avatar
Michael Hanus committed
159
  loadPackageSpec dir |>= resolveAndCopyDependenciesForPackage' cfg repo gc dir
Michael Hanus's avatar
Michael Hanus committed
160
161
162

--- Resolves the dependencies for a package copy and fills the package caches.
resolveAndCopyDependenciesForPackage ::
Michael Hanus's avatar
Michael Hanus committed
163
164
     Config -> String -> Package -> IO (ErrorLogger [Package])
resolveAndCopyDependenciesForPackage cfg dir pkgSpec =
Michael Hanus's avatar
Michael Hanus committed
165
  getRepoForPackageSpec cfg pkgSpec >>= \repo ->
Michael Hanus's avatar
Michael Hanus committed
166
167
168
169
  GC.readGlobalCache cfg repo |>= \gc ->
  resolveAndCopyDependenciesForPackage' cfg repo gc dir pkgSpec

resolveAndCopyDependenciesForPackage' ::
Michael Hanus's avatar
Michael Hanus committed
170
171
     Config -> Repository -> GC.GlobalCache -> String -> Package
  -> IO (ErrorLogger [Package])
Michael Hanus's avatar
Michael Hanus committed
172
resolveAndCopyDependenciesForPackage' cfg repo gc dir pkgSpec =
Michael Hanus's avatar
Michael Hanus committed
173
174
175
176
177
  resolveDependenciesForPackageCopy cfg pkgSpec repo gc dir |>= \result -> 
    let deps = resolvedPackages result
        missingDeps = GC.missingPackages gc deps 
        failMsg = "Missing dependencies " 
                  ++ (intercalate "," $ map packageId missingDeps) 
Michael Hanus's avatar
Michael Hanus committed
178
                  ++ "\nUse `cypm install` to install missing dependencies."
Michael Hanus's avatar
Michael Hanus committed
179
    in if null missingDeps
180
         then copyDependencies cfg pkgSpec deps dir
Michael Hanus's avatar
Michael Hanus committed
181
         else failIO failMsg
Michael Hanus's avatar
Michael Hanus committed
182
183

--- Resolves the dependencies for a package copy.
Michael Hanus's avatar
Michael Hanus committed
184
185
186
187
resolveDependencies :: Config -> String -> IO (ErrorLogger ResolutionResult)
resolveDependencies cfg dir =
  loadPackageSpec dir |->
  log Info ("Read package spec from " ++ dir) |>= \pkgSpec ->
Michael Hanus's avatar
Michael Hanus committed
188
189
  getRepoForPackageSpec cfg pkgSpec >>= \repo ->
  GC.readGlobalCache cfg repo |>= \gc ->
Michael Hanus's avatar
Michael Hanus committed
190
  resolveDependenciesForPackageCopy cfg pkgSpec repo gc dir
Michael Hanus's avatar
Michael Hanus committed
191

Michael Hanus's avatar
Michael Hanus committed
192
------------------------------------------------------------------------------
Michael Hanus's avatar
Michael Hanus committed
193
194
195
196
197
198
199
--- Sets `base` package dependency in a package to the current `baseVersion`
--- if this dependency is compatible with the current `baseVersion`.
--- Hence, a conflict occurs if some package requires a different version
--- of the `base` package.
setBaseDependency :: Config -> Package -> Package
setBaseDependency cfg pkg =
  pkg { dependencies = map setBase (dependencies pkg) }
Michael Hanus's avatar
Michael Hanus committed
200
 where
Michael Hanus's avatar
Michael Hanus committed
201
202
203
204
205
206
207
208
  bv = maybe (0,0,0,Nothing) id (readVersion (baseVersion cfg))
  
  setBase (Dependency n disj) =
    Dependency n $ if n == "base" && isDisjunctionCompatible bv disj
                     then [[VExact bv]]
                     else disj

--- Same as `LS.addPackages` but set the `base` package dependency.
Michael Hanus's avatar
Michael Hanus committed
209
210
211
addPackagesWOBase :: Config -> LS.LookupSet -> [Package] -> LS.LookupSource
                  -> LS.LookupSet
addPackagesWOBase cfg ls pkgs src =
Michael Hanus's avatar
Michael Hanus committed
212
  LS.addPackages ls (map (setBaseDependency cfg) pkgs) src
Michael Hanus's avatar
Michael Hanus committed
213
214

------------------------------------------------------------------------------