From 9142d8a9e6ed18faf17a360521fbbbd25f6a3b47 Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Sun, 12 Aug 2018 04:45:34 +0200 Subject: Add initial new-build (v2-build) support to wrapper --- src/CabalHelper/Compiletime/Compat/Version.hs | 8 ++ src/CabalHelper/Compiletime/Compile.hs | 101 ++++++++++++++++++-------- src/CabalHelper/Compiletime/Wrapper.hs | 85 +++++++++++++++++----- 3 files changed, 142 insertions(+), 52 deletions(-) (limited to 'src') diff --git a/src/CabalHelper/Compiletime/Compat/Version.hs b/src/CabalHelper/Compiletime/Compat/Version.hs index 853aca5..af17bcb 100644 --- a/src/CabalHelper/Compiletime/Compat/Version.hs +++ b/src/CabalHelper/Compiletime/Compat/Version.hs @@ -4,6 +4,7 @@ module CabalHelper.Compiletime.Compat.Version , toDataVersion , fromDataVersion , Data.Version.showVersion + , makeDataVersion ) where import qualified Data.Version @@ -23,3 +24,10 @@ fromDataVersion (Data.Version.Version vs _) = Distribution.Version.mkVersion vs toDataVersion = id fromDataVersion = id #endif + +makeDataVersion :: [Int] -> Data.Version.Version +#if MIN_VERSION_base(4,8,0) +makeDataVersion = Data.Version.makeVersion +#else +makeDataVersion xs = Data.Version.Version xs [] +#endif diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs index b39e86f..571240d 100644 --- a/src/CabalHelper/Compiletime/Compile.hs +++ b/src/CabalHelper/Compiletime/Compile.hs @@ -23,6 +23,7 @@ License : AGPL-3 module CabalHelper.Compiletime.Compile where +import Cabal.Plan import Control.Applicative import Control.Arrow import Control.Exception as E @@ -47,6 +48,10 @@ import System.IO.Error import System.IO.Temp import Prelude + +import qualified Data.Text as Text +import qualified Data.Map.Strict as Map + import Distribution.System (buildPlatform) import Distribution.Text (display) @@ -81,13 +86,15 @@ data CompPaths = CompPaths -- executable. data CompilationProductScope = CPSGlobal | CPSProject -compileHelper :: Options -> Version -> FilePath -> FilePath -> IO (Either ExitCode FilePath) -compileHelper opts hdrCabalVersion projdir distdir = do +compileHelper :: Options -> Version -> FilePath -> Maybe (PlanJson, FilePath) -> FilePath -> IO (Either ExitCode FilePath) +compileHelper opts hdrCabalVersion projdir mnewstyle distdir = do + ghcVer <- ghcVersion opts Just (prepare, comp) <- runMaybeT $ msum $ case oCabalPkgDb opts of Nothing -> [ compileCabalSource - , compileSandbox + , compileNewBuild ghcVer + , compileSandbox ghcVer , compileGlobal , MaybeT $ Just <$> compileWithCabalInPrivatePkgDb ] @@ -104,7 +111,7 @@ compileHelper opts hdrCabalVersion projdir distdir = do vLog opts $ "helper already compiled, using exe: "++compExePath return (Right compExePath) else do - vLog opts $ "helper exe does not exist, compiling"++compExePath + vLog opts $ "helper exe does not exist, compiling "++compExePath prepare >> compile comp cp opts where @@ -115,21 +122,38 @@ compileHelper opts hdrCabalVersion projdir distdir = do -- | Check if this version is globally available compileGlobal :: MaybeT IO (IO (), Compile) compileGlobal = do - ver <- MaybeT $ find (== hdrCabalVersion) <$> listCabalVersions opts + cabal_versions <- listCabalVersions opts + ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions vLog opts $ logMsg ++ "user/global package-db" return $ (return (), compileWithPkg Nothing ver CPSGlobal) -- | Check if this version is available in the project sandbox - compileSandbox :: MaybeT IO (IO (), Compile) - compileSandbox = do - let ghcVer = ghcVersion opts - mdb_path = getSandboxPkgDb projdir (display buildPlatform) =<< ghcVer + compileSandbox :: Version -> MaybeT IO (IO (), Compile) + compileSandbox ghcVer = do + let mdb_path = getSandboxPkgDb projdir (display buildPlatform) ghcVer sandbox <- PackageDbDir <$> MaybeT mdb_path - ver <- MaybeT $ logIOError opts "compileSandbox" $ - find (== hdrCabalVersion) <$> listCabalVersions' opts (Just sandbox) + cabal_versions <- listCabalVersions' opts (Just sandbox) + ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions vLog opts $ logMsg ++ "sandbox package-db" return $ (return (), compileWithPkg (Just sandbox) ver CPSProject) + compileNewBuild :: Version -> MaybeT IO (IO (), Compile) + compileNewBuild ghcVer = do + (PlanJson {pjUnits}, distdir_newstyle) <- maybe mzero pure mnewstyle + let cabal_pkgid = + PkgId (PkgName (Text.pack "Cabal")) + (Ver $ versionBranch hdrCabalVersion) + mcabal_unit = listToMaybe $ + Map.elems $ Map.filter (\Unit {..} -> uPId == cabal_pkgid) pjUnits + Unit {} <- maybe mzero pure mcabal_unit + let inplace_db_path = distdir_newstyle + "packagedb" ("ghc-" ++ showVersion ghcVer) + inplace_db = PackageDbDir inplace_db_path + cabal_versions <- listCabalVersions' opts (Just inplace_db) + ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions + vLog opts $ logMsg ++ "v2-build package-db " ++ inplace_db_path + return $ (return (), compileWithPkg (Just inplace_db) ver CPSProject) + -- | Compile the requested Cabal version into an isolated package-db if it's -- not there already compileWithCabalInPrivatePkgDb :: IO (IO (), Compile) @@ -322,6 +346,13 @@ exeName CabalVersion {cabalVersion} = intercalate "-" , "Cabal" ++ showVersion cabalVersion ] +readProcess' :: Options -> FilePath -> [String] -> String -> IO String +readProcess' opts@Options{..} exe args inp = do + vLog opts $ intercalate " " $ map formatProcessArg (oGhcPkgProgram:args) + outp <- readProcess exe args inp + vLog opts $ unlines $ map ("=> "++) $ lines outp + return outp + callProcessStderr' :: Options -> Maybe FilePath -> FilePath -> [String] -> IO ExitCode callProcessStderr' opts mwd exe args = do @@ -377,7 +408,7 @@ installCabal opts ever = do withSystemTempDirectory "cabal-helper-Cabal-source" $ \tmpdir -> do (srcdir, cabalVer) <- case ever of Left HEAD -> do - second CabalHEAD <$> unpackCabalHEAD tmpdir + second CabalHEAD <$> unpackCabalHEAD opts tmpdir Right ver -> do message ver let patch = fromMaybe nopCabalPatchDescription $ @@ -578,13 +609,13 @@ unpackCabal opts cabalVer tmpdir variant = do callProcessStderr opts (Just tmpdir) (oCabalProgram opts) args return $ CabalSourceDir dir -unpackCabalHEAD :: FilePath -> IO (CabalSourceDir, CommitId) -unpackCabalHEAD tmpdir = do +unpackCabalHEAD :: Options -> FilePath -> IO (CabalSourceDir, CommitId) +unpackCabalHEAD opts tmpdir = do let dir = tmpdir "cabal-head.git" url = "https://github.com/haskell/cabal.git" ExitSuccess <- rawSystem "git" [ "clone", "--depth=1", url, dir] commit <- - withDirectory_ dir $ trim <$> readProcess "git" ["rev-parse", "HEAD"] "" + withDirectory_ dir $ trim <$> readProcess' opts "git" ["rev-parse", "HEAD"] "" return (CabalSourceDir $ dir "Cabal", CommitId commit) where withDirectory_ :: FilePath -> IO a -> IO a @@ -629,40 +660,46 @@ errorInstallCabal cabalVer _distdir = panicIO $ printf "\ where sver = showVersion cabalVer -listCabalVersions :: Options -> IO [Version] +listCabalVersions :: Options -> MaybeT IO [Version] listCabalVersions opts = listCabalVersions' opts Nothing --- TODO: Include sandbox? Probably only relevant for build-type:custom projects. -listCabalVersions' :: Options -> Maybe PackageDbDir -> IO [Version] -listCabalVersions' Options {..} mdb = do - let mdbopt = ("--package-conf="++) <$> unPackageDbDir <$> mdb - opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt - - catMaybes . map (fmap snd . parsePkgId . fromString) . words - <$> readProcess oGhcPkgProgram opts "" +listCabalVersions' :: Options -> Maybe PackageDbDir -> MaybeT IO [Version] +listCabalVersions' opts@Options {..} mdb = do + case mdb of + Nothing -> mzero + Just (PackageDbDir db_path) -> do + exists <- liftIO $ doesDirectoryExist db_path + case exists of + False -> mzero + True -> MaybeT $ logIOError opts "listCabalVersions'" $ Just <$> do + let mdbopt = ("--package-conf="++) <$> unPackageDbDir <$> mdb + args = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt + + catMaybes . map (fmap snd . parsePkgId . fromString) . words + <$> readProcess' opts oGhcPkgProgram args "" cabalVersionExistsInPkgDb :: Options -> Version -> PackageDbDir -> IO Bool cabalVersionExistsInPkgDb opts cabalVer db@(PackageDbDir db_path) = do exists <- doesDirectoryExist db_path case exists of False -> return False - True -> do + True -> fromMaybe False <$> runMaybeT (do vers <- listCabalVersions' opts (Just db) - return $ cabalVer `elem` vers + return $ cabalVer `elem` vers) ghcVersion :: Options -> IO Version -ghcVersion Options {..} = do - parseVer . trim <$> readProcess oGhcProgram ["--numeric-version"] "" +ghcVersion opts@Options {..} = do + parseVer . trim <$> readProcess' opts oGhcProgram ["--numeric-version"] "" ghcPkgVersion :: Options -> IO Version -ghcPkgVersion Options {..} = do - parseVer . trim . dropWhile (not . isDigit) <$> readProcess oGhcPkgProgram ["--version"] "" +ghcPkgVersion opts@Options {..} = do + parseVer . trim . dropWhile (not . isDigit) <$> readProcess' opts oGhcPkgProgram ["--version"] "" newtype CabalInstallVersion = CabalInstallVersion { cabalInstallVer :: Version } cabalInstallVersion :: Options -> IO CabalInstallVersion -cabalInstallVersion Options {..} = do +cabalInstallVersion opts@Options {..} = do CabalInstallVersion . parseVer . trim - <$> readProcess oCabalProgram ["--numeric-version"] "" + <$> readProcess' opts oCabalProgram ["--numeric-version"] "" createPkgDb :: Options -> CabalVersion -> IO PackageDbDir createPkgDb opts@Options {..} cabalVer = do diff --git a/src/CabalHelper/Compiletime/Wrapper.hs b/src/CabalHelper/Compiletime/Wrapper.hs index ae936f3..cd92219 100644 --- a/src/CabalHelper/Compiletime/Wrapper.hs +++ b/src/CabalHelper/Compiletime/Wrapper.hs @@ -13,9 +13,10 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE RecordWildCards, FlexibleContexts #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns, FlexibleContexts, ViewPatterns #-} module Main where +import Cabal.Plan import Control.Applicative import Control.Monad import Data.Char @@ -23,6 +24,7 @@ import Data.List import Data.Maybe import Data.String import Text.Printf +import Text.Show.Pretty import System.Console.GetOpt import System.Environment import System.Directory @@ -32,6 +34,9 @@ import System.Exit import System.IO import Prelude +import qualified Data.Text as Text +import qualified Data.Map.Strict as Map + import Distribution.System (buildPlatform) import Distribution.Text (display) import Distribution.Verbosity (silent, deafening) @@ -61,7 +66,11 @@ usage = do \ [--with-cabal=CABAL_PATH]\n\ \ [--with-cabal-version=VERSION]\n\ \ [--with-cabal-pkg-db=PKG_DB]\n\ -\ PROJ_DIR DIST_DIR ( print-exe | package-id | [CABAL_HELPER_ARGS...] ) )\n" +\ v1-style PROJ_DIR DIST_DIR \n\ +\ ( print-exe | package-id | [CABAL_HELPER_ARGS...] )\n\ +\ v2-style PROJ_DIR DIST_NEWSTYLE_DIR DIST_DIR\n\ +\ ( print-exe | package-id | [CABAL_HELPER_ARGS...] )\n\ +\)\n" globalArgSpec :: [OptDescr (Options -> Options)] globalArgSpec = @@ -147,7 +156,7 @@ main = handlePanic $ do "print-appcachedir":[] -> putStrLn =<< appCacheDir "print-build-platform":[] -> putStrLn $ display buildPlatform - projdir:_distdir:"package-id":[] -> do + "oldstyle":projdir:_distdir:"package-id":[] -> do let v | oVerbose opts = deafening | otherwise = silent -- ghc-mod will catch multiple cabal files existing before we get here @@ -156,27 +165,63 @@ main = handlePanic $ do putStrLn $ show $ [Just $ ChResponseVersion (display (packageName gpd)) (toDataVersion $ packageVersion gpd)] - projdir:distdir:args' -> do + "v2-style":projdir:distdir_newstyle:unitid':args' -> do + let unitid = UnitId $ Text.pack unitid' + let plan_path = distdir_newstyle "cache" "plan.json" + plan@PlanJson {pjCabalLibVersion=Ver (makeDataVersion -> pjCabalLibVersion) } + <- decodePlanJson plan_path + case oCabalVersion opts of + Just ver | pjCabalLibVersion /= ver -> let + sver = showVersion ver + spjVer = showVersion pjCabalLibVersion + in panic $ printf "\ +\Cabal version %s was requested but plan.json was written by version %s" sver spjVer + _ -> case Map.lookup unitid $ pjUnits plan of + Just u@Unit {uType} | uType /= UnitTypeLocal -> do + panic $ "\ +\UnitId '"++ unitid' ++"' points to non-local unit: " ++ ppShow u + Just Unit {uDistDir=Nothing} -> panic $ printf "\ +\plan.json doesn't contain 'dist-dir' for UnitId '"++ unitid' ++"'" + Just Unit {uType=UnitTypeLocal, uDistDir=Just distdir} -> + runHelper opts projdir (Just (plan, distdir_newstyle)) distdir pjCabalLibVersion args' + _ -> let + units = map (\(UnitId u) -> Text.unpack u) + $ Map.keys + $ Map.filter ((==UnitTypeLocal) . uType) + $ pjUnits plan + + units_list = unlines $ map (" "++) units + in + panic $ "\ +\UnitId '"++ unitid' ++"' not found in plan.json, available local units:\n" ++ units_list + + "v1-style":projdir:distdir:args' -> do cfgf <- canonicalizePath (distdir "setup-config") mhdr <- getCabalConfigHeader cfgf - case mhdr of - Nothing -> panic $ printf "\ + case (mhdr, oCabalVersion opts) of + (Nothing, _) -> panic $ printf "\ \Could not read Cabal's persistent setup configuration header\n\ \- Check first line of: %s\n\ \- Maybe try: $ cabal configure" cfgf - Just (hdrCabalVersion, _) -> do - case oCabalVersion opts of - Just ver | hdrCabalVersion /= ver -> panic $ printf "\ + (Just (hdrCabalVersion, _), Just ver) + | hdrCabalVersion /= ver -> panic $ printf "\ \Cabal version %s was requested but setup configuration was\n\ \written by version %s" (showVersion ver) (showVersion hdrCabalVersion) - _ -> do - eexe <- compileHelper opts hdrCabalVersion projdir distdir - case eexe of - Left e -> exitWith e - Right exe -> - case args' of - "print-exe":_ -> putStrLn exe - _ -> do - (_,_,_,h) <- createProcess $ proc exe args - exitWith =<< waitForProcess h - _ -> error "invalid command line" + (Just (hdrCabalVersion, _), _) -> + runHelper opts projdir Nothing distdir hdrCabalVersion args' + _ -> do + hPutStrLn stderr "Invalid command line!" + usage + exitWith $ ExitFailure 1 + +runHelper :: Options -> FilePath -> Maybe (PlanJson, FilePath) -> FilePath -> DataVersion -> [String] -> IO () +runHelper opts projdir mnewstyle distdir cabal_ver args' = do + eexe <- compileHelper opts cabal_ver projdir mnewstyle distdir + case eexe of + Left e -> exitWith e + Right exe -> do + case args' of + "print-exe":_ -> putStrLn exe + _ -> do + (_,_,_,h) <- createProcess $ proc exe $ projdir : distdir : args' + exitWith =<< waitForProcess h -- cgit v1.2.3