-
Notifications
You must be signed in to change notification settings - Fork 21
/
Merge.hs
230 lines (195 loc) · 8.95 KB
/
Merge.hs
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
{-# OPTIONS -XPatternGuards #-}
module Merge
( merge
, mergeGenericPackageDescription
) where
import Control.Monad.Error
import Control.Exception
import Data.Maybe
import Data.List as L
import Distribution.Package
import Distribution.PackageDescription ( PackageDescription(..)
, FlagName(..)
, GenericPackageDescription
)
import Distribution.PackageDescription.Configuration
( finalizePackageDescription )
import Distribution.Text (display)
import System.Directory ( getCurrentDirectory
, setCurrentDirectory
, createDirectoryIfMissing
, doesFileExist
)
import System.Cmd (system)
import System.FilePath ((</>))
import System.Exit
import qualified Cabal2Ebuild as C2E
import qualified Portage.EBuild as E
import Error as E
import qualified Distribution.Package as Cabal
import qualified Distribution.Version as Cabal
import Distribution.System (buildPlatform)
import Distribution.Verbosity
import Distribution.Simple.Utils
import Network.URI
import Distribution.Client.IndexUtils ( getSourcePackages )
import qualified Distribution.Client.PackageIndex as Index
import Distribution.Client.Types
import qualified Portage.PackageId as Portage
import qualified Portage.Version as Portage
import qualified Portage.Metadata as Portage
import qualified Portage.Overlay as Overlay
import qualified Portage.Resolve as Portage
import qualified Portage.GHCCore as GHCCore
import qualified Merge.Dependencies as Merge
import Debug.Trace ( trace )
(<.>) :: String -> String -> String
a <.> b = a ++ '.':b
{-
Requested features:
* Copy the old keywords and ~arch them
* Add files to darcs?
* Print diff with the next latest version?
BUGS:
* Dependencies are always expected to be in dev-haskell
-}
readPackageString :: [String]
-> Either HackPortError ( Maybe Portage.Category
, Cabal.PackageName
, Maybe Portage.Version
)
readPackageString args = do
packageString <-
case args of
[] -> Left (ArgumentError "Need an argument, [category/]package[-version]")
[pkg] -> return pkg
_ -> Left (ArgumentError ("Too many arguments: " ++ unwords args))
case Portage.parseFriendlyPackage packageString of
Just v@(_,_,Nothing) -> return v
-- we only allow versions we can convert into cabal versions
Just v@(_,_,Just (Portage.Version _ Nothing [] 0)) -> return v
_ -> Left (ArgumentError ("Could not parse [category/]package[-version]: " ++ packageString))
-- | Given a list of available packages, and maybe a preferred version,
-- return the available package with that version. Latest version is chosen
-- if no preference.
resolveVersion :: [SourcePackage] -> Maybe Cabal.Version -> Maybe SourcePackage
resolveVersion avails Nothing = Just $ maximumBy (comparing packageInfoId) avails
resolveVersion avails (Just ver) = listToMaybe (filter match avails)
where
match avail = ver == pkgVersion (packageInfoId avail)
merge :: Verbosity -> Repo -> URI -> [String] -> FilePath -> IO ()
merge verbosity repo _serverURI args overlayPath = do
(m_category, user_pName, m_version) <-
case readPackageString args of
Left err -> throwEx err
Right (c,p,m_v) ->
case m_v of
Nothing -> return (c,p,Nothing)
Just v -> case Portage.toCabalVersion v of
Nothing -> throwEx (ArgumentError "illegal version")
Just ver -> return (c,p,Just ver)
debug verbosity $ "Category: " ++ show m_category
debug verbosity $ "Package: " ++ show user_pName
debug verbosity $ "Version: " ++ show m_version
let (Cabal.PackageName user_pname_str) = user_pName
overlay <- Overlay.loadLazy overlayPath
-- portage_path <- Host.portage_dir `fmap` Host.getInfo
-- portage <- Overlay.loadLazy portage_path
index <- fmap packageIndex $ getSourcePackages verbosity [ repo ]
-- find all packages that maches the user specified package name
availablePkgs <-
case map snd (Index.searchByName index user_pname_str) of
[] -> throwEx (PackageNotFound user_pname_str)
[pkg] -> return pkg
pkgs -> let names = map (pkgName . packageInfoId . L.head) pkgs
whole_list = map (L.intercalate "\n" . map (show . packageInfoId)) pkgs
in throwEx $ ArgumentError $ L.intercalate "\n---\n" $ ["Ambiguous names: " ++ show names] ++ whole_list
-- select a single package taking into account the user specified version
selectedPkg <-
case resolveVersion availablePkgs m_version of
Nothing -> do
putStrLn "No such version for that package, available versions:"
forM_ availablePkgs $ \ avail ->
putStrLn (display . packageInfoId $ avail)
throwEx (ArgumentError "no such version for that package")
Just avail -> return avail
-- print some info
info verbosity "Selecting package:"
forM_ availablePkgs $ \ avail -> do
let match_text | packageInfoId avail == packageInfoId selectedPkg = "* "
| otherwise = "- "
info verbosity $ match_text ++ (display . packageInfoId $ avail)
let cabal_pkgId = packageInfoId selectedPkg
norm_pkgName = packageName (Portage.normalizeCabalPackageId cabal_pkgId)
cat <- maybe (Portage.resolveCategory verbosity overlay norm_pkgName) return m_category
mergeGenericPackageDescription verbosity overlayPath cat (packageDescription selectedPkg) True
mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> GenericPackageDescription -> Bool -> IO ()
mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch = do
let Right (pkgDesc0, flags) =
finalizePackageDescription
[ -- XXX: common things we should enable/disable?
-- (FlagName "small_base", True) -- try to use small base
(FlagName "cocoa", False)
]
(\dep -> trace ("accepting dep(?): " ++ display dep) True)
-- (Nothing :: Maybe (Index.PackageIndex PackageIdentifier))
buildPlatform
(fst GHCCore.defaultGHC)
[] pkgGenericDesc
mminimumGHC = GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc
(compilerId, excludePkgs) = maybe GHCCore.defaultGHC id mminimumGHC
pkgDesc = let deps = [ Dependency pn (Cabal.simplifyVersionRange vr)
| Dependency pn vr <- buildDepends pkgDesc0
, pn `notElem` excludePkgs
]
in pkgDesc0 { buildDepends = deps }
edeps = Merge.resolveDependencies pkgDesc (Just compilerId)
debug verbosity ("Selected flags: " ++ show flags)
info verbosity ("Guessing GHC version: " ++ maybe "could not guess" (display.fst) mminimumGHC)
let ebuild = (\e -> e { E.depend = Merge.dep edeps } )
. (\e -> e { E.depend_extra = Merge.dep_e edeps } )
. (\e -> e { E.rdepend = Merge.rdep edeps } )
. (\e -> e { E.rdepend_extra = Merge.rdep_e edeps } )
$ C2E.cabal2ebuild pkgDesc
mergeEbuild verbosity overlayPath (Portage.unCategory cat) ebuild
when fetch $ do
let cabal_pkgId = packageId pkgDesc
norm_pkgName = packageName (Portage.normalizeCabalPackageId cabal_pkgId)
fetchAndDigest
verbosity
(overlayPath </> display cat </> display norm_pkgName)
fetchAndDigest :: Verbosity
-> FilePath -- ^ directory of ebuild
-> IO ()
fetchAndDigest verbosity ebuildDir =
withWorkingDirectory ebuildDir $ do
notice verbosity "Recalculating digests (repoman manifest)..."
r <- system "repoman manifest"
when (r /= ExitSuccess) $
notice verbosity "repoman manifest failed horribly. Do something about it!"
return ()
withWorkingDirectory :: FilePath -> IO a -> IO a
withWorkingDirectory newDir action = do
oldDir <- getCurrentDirectory
bracket
(setCurrentDirectory newDir)
(\_ -> setCurrentDirectory oldDir)
(\_ -> action)
mergeEbuild :: Verbosity -> FilePath -> String -> E.EBuild -> IO ()
mergeEbuild verbosity target cat ebuild = do
let edir = target </> cat </> E.name ebuild
elocal = E.name ebuild ++"-"++ E.version ebuild <.> "ebuild"
epath = edir </> elocal
emeta = "metadata.xml"
mpath = edir </> emeta
default_meta = Portage.makeDefaultMetadata (E.long_desc ebuild)
createDirectoryIfMissing True edir
notice verbosity $ "Writing " ++ elocal
writeFile epath (display ebuild)
yet_meta <- doesFileExist mpath
if (not yet_meta) -- TODO: add --force-meta-rewrite to opts
then do notice verbosity $ "Writing " ++ emeta
writeFile mpath default_meta
else do current_meta <- readFile mpath
when (current_meta /= default_meta) $
notice verbosity $ "Default and current " ++ emeta ++ " differ."