diff --git a/Development/Shake/FilePath.hs b/Development/Shake/FilePath.hs index 5750e0e4..c351bb1f 100644 --- a/Development/Shake/FilePath.hs +++ b/Development/Shake/FilePath.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | Useful 'System.FilePath' wrapper around Shake. module Development.Shake.FilePath @@ -10,12 +12,14 @@ module Development.Shake.FilePath ,Rules ,Action ,CmdOption(..) - ,Shake.cmd) + ,Shake.cmd + ,makeTargetFile) where import Control.Monad.IO.Class import Development.Shake (Rules,Action,CmdOption(..)) import qualified Development.Shake as Shake +import qualified Filesystem as FP import Filesystem.Path.CurrentOS (FilePath) import qualified Filesystem.Path.CurrentOS as FP import Prelude hiding (FilePath) @@ -54,3 +58,7 @@ need xs = Shake.need $ want :: [Target] -> Rules () want xs = Shake.want (map (FP.encodeString . unTarget) xs) + +-- | Make an empty file of this name. +makeTargetFile :: Target -> Action () +makeTargetFile fp = liftIO $ FP.writeFile (unTarget fp) "" diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs new file mode 100644 index 00000000..f49a7477 --- /dev/null +++ b/Stackage/GhcPkg.hs @@ -0,0 +1,55 @@ +-- | General commands related to ghc-pkg. + +module Stackage.GhcPkg where + +import Control.Monad +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Conduit.Process +import qualified Data.Conduit.Text as CT +import Data.List +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Compat.ReadP +import Distribution.Package +import Distribution.Text (display) +import Distribution.Text (parse) +import Filesystem.Path.CurrentOS (FilePath) +import qualified Filesystem.Path.CurrentOS as FP +import Prelude hiding (FilePath) + +-- | Get broken packages. +getBrokenPackages :: FilePath -> IO [PackageIdentifier] +getBrokenPackages dir = do + (_,ps) <- sourceProcessWithConsumer + (proc + "ghc-pkg" + ["check", "--simple-output", "-f", FP.encodeString dir]) + (CT.decodeUtf8 $= CT.lines $= CL.consume) + return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) + +-- | Get available packages. +getRegisteredPackages :: FilePath -> IO [PackageIdentifier] +getRegisteredPackages dir = do + (_,ps) <- sourceProcessWithConsumer + (proc + "ghc-pkg" + ["list", "--simple-output", "-f", FP.encodeString dir]) + (CT.decodeUtf8 $= CT.lines $= CL.consume) + return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) + +-- | Parse a package identifier: foo-1.2.3 +parsePackageIdent :: Text -> Maybe PackageIdentifier +parsePackageIdent = fmap fst . + listToMaybe . + filter (null . snd) . + readP_to_S parse . T.unpack + +-- | Unregister a package. +unregisterPackage :: FilePath -> PackageName -> IO () +unregisterPackage dir ident = do + void (readProcessWithExitCode + "ghc-pkg" + ["unregister", "-f", FP.encodeString dir, "--force", display ident] + "") diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 5ab46a96..7e1f5c3b 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -12,6 +12,7 @@ module Stackage.ShakeBuild where import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.CheckBuildPlan +import Stackage.GhcPkg import Stackage.PackageDescription import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy) import Stackage.Prelude (unFlagName) @@ -21,25 +22,18 @@ import Control.Concurrent.STM import Control.Exception import Control.Monad import Control.Monad.IO.Class -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Conduit.Process -import qualified Data.Conduit.Text as CT import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid import qualified Data.Set as S -import Data.Text (Text) import qualified Data.Text as T import Data.Version -import Development.Shake.FilePath hiding (Env) import qualified Development.Shake.FilePath as Shake -import Distribution.Compat.ReadP +import Development.Shake.FilePath hiding (Env) import Distribution.Package import Distribution.Text (display) -import Distribution.Text (parse) import qualified Filesystem as FP import Filesystem.Path.CurrentOS (FilePath) import qualified Filesystem.Path.CurrentOS as FP @@ -47,15 +41,19 @@ import Prelude hiding (FilePath) import System.Environment import System.Exit +-- | Reader environment used generally throughout the build process. data Env = Env - {envCur :: FilePath - ,envShake :: FilePath - ,envHadLock :: TVar (Map String FilePath) - ,envRegLock :: MVar () - ,envPB :: PerformBuild - ,envRegistered :: [PackageIdentifier] + {envCur :: FilePath -- ^ Current directory. + ,envShake :: FilePath -- ^ Shake directory. + ,envHaddocks :: TVar (Map String FilePath) -- ^ Haddock files. + ,envRegLock :: MVar () -- ^ Package registering lock. + ,envPB :: PerformBuild -- ^ Build perform settings. + ,envRegistered :: [PackageIdentifier] -- ^ Registered packages. } +-------------------------------------------------------------------------------- +-- Main entry point + -- | Run the shake builder. performBuild :: PerformBuild -> IO () performBuild pb' = do @@ -64,14 +62,14 @@ performBuild pb' = do FP.createTree shakeDir haddockFiles <- liftIO (newTVarIO mempty) registerLock <- liftIO (newMVar ()) - pkgs <- getRegisteredPackages shakeDir + pkgs <- getRegisteredPackages (buildDatabase shakeDir) let !pb = pb' { pbInstallDest = cur <> pbInstallDest pb' } !env = Env { envCur = cur , envShake = shakeDir - , envHadLock = haddockFiles + , envHaddocks = haddockFiles , envRegLock = registerLock , envPB = pb , envRegistered = pkgs @@ -80,6 +78,9 @@ performBuild pb' = do printNewPackages env startShake 2 shakeDir (shakePlan env) +-------------------------------------------------------------------------------- +-- The whole Shake plan + -- | The complete build plan as far as Shake is concerned. shakePlan :: Env -> Rules () shakePlan env@Env{..} = do @@ -106,6 +107,190 @@ shakePlan env@Env{..} = do normalPackages = filter (not . (`elem` corePackages) . fst) $ M.toList $ bpPackages $ pbPlan envPB +-------------------------------------------------------------------------------- +-- Target file paths + +-- | Get the target file for confirming that all packages have been +-- pre-fetched. +targetForFetched :: Env -> Target +targetForFetched Env{..} = Target (envShake <> "packages-fetched") + +-- | Get the target file for a package. +targetForPackage :: FilePath -> PackageName -> Version -> Target +targetForPackage shakeDir name version = Target $ + shakeDir <> "packages" <> + FP.decodeString (nameVer name version) + <> "dist" <> "shake-build" + +-- | Get the target file for a package. +targetForDocs :: FilePath -> PackageName -> Version -> Target +targetForDocs shakeDir name version = Target $ + shakeDir <> "packages" <> + FP.decodeString + (nameVer name version) <> + "dist" <> "shake-docs" + +-- | Target for the complete, copied build under builds/date/. +targetForBuild :: PerformBuild -> Target +targetForBuild pb = Target $ (pbInstallDest pb) <> "shake-built" + +-- | Get a package database path. +targetForDb :: Env -> Target +targetForDb Env{..} = Target $ envShake <> "pkgdb-initialized" + +-------------------------------------------------------------------------------- +-- Locations, names and environments used. Just to avoid "magic +-- strings". + +-- | Print the name and version. +nameVer :: PackageName -> Version -> String +nameVer name version = display name ++ "-" ++ display version + +-- | Default environment for running commands. +defaultEnv :: PerformBuild -> FilePath -> FilePath -> [(String, String)] +defaultEnv pb shakeDir pwd = + [( "HASKELL_PACKAGE_SANDBOX" + , FP.encodeString (pwd <> buildDatabase shakeDir)) + | pbGlobalInstall pb] + +-- | Database location. +buildDatabase :: FilePath -> FilePath +buildDatabase shakeDir = shakeDir <> "pkgdb" + +-- | The directory for the package's docs. +pkgDocDir :: Env -> PackageName -> Version -> FilePath +pkgDocDir env@Env{..} name version = pkgDir env name version <> + "dist" <> + "doc" <> + "html" <> + (FP.decodeString (display name)) + +-- | The package directory. +pkgDir :: Env -> PackageName -> Version -> FilePath +pkgDir Env{..} name version = envShake <> "packages" <> + (FP.decodeString (nameVer name version)) + +-- | Installation paths. +pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath +pbBinDir root = (pbInstallDest root) <> "bin" +pbLibDir root = (pbInstallDest root) <> "lib" +pbDataDir root = (pbInstallDest root) <> "share" +pbDocDir root = (pbInstallDest root) <> "doc" + +-------------------------------------------------------------------------------- +-- Pre-build messages + +-- | Print the new packages. +printNewPackages :: Env -> IO () +printNewPackages Env{..} = do + unless + (M.null new) + (do putStrLn + ("There are " ++ + show (M.size new) ++ + " packages to build and install: ") + forM_ + (map fst (take maxDisplay (M.toList new))) + (putStrLn . display) + when (M.size new > maxDisplay) + (putStrLn ("And " ++ show (M.size new - maxDisplay) ++ " more."))) + where maxDisplay = 10 + new = M.filterWithKey + (\name _ -> + isNothing (find ((== name) . pkgName) envRegistered)) + versions + versions = (M.map ppVersion . + M.filter (not . S.null . sdModules . ppDesc) . + bpPackages . pbPlan) envPB + +-------------------------------------------------------------------------------- +-- Clean/purging of old packages + +-- | Reason for purging a package. +data PurgeReason + = NoLongerIncluded + | Replaced Version + | Broken + +-- | Clean up old versions of packages that are no longer in use. +cleanOldPackages :: Env -> IO () +cleanOldPackages env@Env{..} = do + putStrLn "Collecting garbage" + pkgs <- getRegisteredPackages (buildDatabase envShake) + let toRemove = mapMaybe + (\(PackageIdentifier name version) -> + case M.lookup name versions of + Just version' + | version' == version -> + Nothing + Just newVersion -> Just + (name, version, (Replaced newVersion)) + Nothing -> Just (name, version, NoLongerIncluded)) + pkgs + unless (null toRemove) + (putStrLn ("There are " ++ show (length toRemove) ++ " packages to be purged.")) + when (length toRemove > 0) + (do putStrLn "Waiting 3 seconds before proceeding to remove ..." + threadDelay (1000 * 1000 * 3)) + forM_ pkgs $ + \(PackageIdentifier name version) -> + case M.lookup name versions of + Just version' + | version' == version -> + return () + Just newVersion -> purgePackage + env + name + version + (Replaced newVersion) + Nothing -> purgePackage env name version NoLongerIncluded + broken <- getBrokenPackages (buildDatabase envShake) + unless (null broken) + (putStrLn ("There are " ++ show (length broken) ++ " broken packages to be purged.")) + when (length broken > 0) + (do putStrLn "Waiting 3 seconds before proceeding to remove ..." + threadDelay (1000 * 1000 * 3)) + forM_ + broken + (\(PackageIdentifier name version) -> + purgePackage env name version Broken) + where versions = (M.map ppVersion . bpPackages . pbPlan) envPB + +-- | Purge the given package and version. +purgePackage :: Env -> PackageName -> Version -> PurgeReason -> IO () +purgePackage env name version reason = do + putStr $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... " + unregisterPackage (buildDatabase (envShake env)) name + remove + putStrLn "done." + where showReason = + case reason of + Replaced version' -> "replaced by " ++ ordinal ++ " " ++ display version' + where ordinal | version' > version = "newer" + | otherwise = "older" + NoLongerIncluded -> "no longer included" + Broken -> "broken" + ident = nameVer name version + remove = FP.removeTree $ + pkgDir env name version + +-------------------------------------------------------------------------------- +-- Target actions + +-- | Initialize the database if there one needs to be, and in any case +-- create the target file. +databaseTarget :: Env -> Action () +databaseTarget env = do + if pbGlobalInstall (envPB env) + then return () + else do + liftIO (FP.removeTree dir) + liftIO (FP.createTree dir) + () <- cmd "ghc-pkg" "init" (FP.encodeString dir) + liftIO $ copyBuiltInHaddocks $ pbDocDir (envPB env) + makeTargetFile (targetForDb env) + where dir = buildDatabase (envShake env) + -- | Generate haddock docs for the package. packageDocs :: Env -> PackagePlan -> PackageName -> Action () packageDocs env@Env{..} plan name = do @@ -124,27 +309,6 @@ packageDocs env@Env{..} plan name = do where version = ppVersion plan haddocksFlag = pcHaddocks $ ppConstraints plan --- | Default environment for running commands. -defaultEnv :: PerformBuild -> FilePath -> FilePath -> [(String, String)] -defaultEnv pb shakeDir pwd = - [( "HASKELL_PACKAGE_SANDBOX" - , FP.encodeString (pwd <> buildDatabase shakeDir)) - | pbGlobalInstall pb] - --- | Initialize the database if there one needs to be, and in any case --- create the target file. -databaseTarget :: Env -> Action () -databaseTarget env = do - if pbGlobalInstall (envPB env) - then return () - else do - liftIO (FP.removeTree dir) - liftIO (FP.createTree dir) - () <- cmd "ghc-pkg" "init" (FP.encodeString dir) - liftIO $ copyBuiltInHaddocks $ pbDocDir (envPB env) - makeTargetFile (targetForDb env) - where dir = buildDatabase (envShake env) - -- | Build, test and generate documentation for the package. packageTarget :: Env -> PackageName -> PackagePlan -> Action () packageTarget env@Env{..} name plan = do @@ -174,6 +338,9 @@ fetchedTarget env@Env{..} = do M.toList $ bpPackages $ pbPlan envPB makeTargetFile (targetForFetched env) +-------------------------------------------------------------------------------- +-- Package actions + -- | Unpack the package. unpack :: Env -> PackageName -> Version -> Action () unpack env@Env{..} name version = do @@ -202,14 +369,16 @@ configure Env{..} pdir env plan = , "--bindir=" ++ FP.encodeString (pbBinDir envPB) , "--datadir=" ++ FP.encodeString (pbDataDir envPB) , "--docdir=" ++ FP.encodeString (pbDocDir envPB) - , "--flags=" ++ planFlags plan] ++ + , "--flags=" ++ planFlags] ++ ["--package-db=" ++ FP.encodeString (buildDatabase envShake) | not (pbGlobalInstall envPB)] + planFlags = unwords $ + map go $ M.toList (pcFlagOverrides (ppConstraints plan)) + where go (name',isOn) = concat + [ if isOn then "" else "-" , T.unpack (unFlagName name')] + -- | Register the package. --- --- TODO: Do a mutex lock in here. Does Shake already support doing --- this out of the box? register :: FilePath -> CmdOption -> MVar () -> Action () register pdir env registerLock = do () <- cmd cwd env "cabal" "copy" @@ -221,7 +390,7 @@ register pdir env registerLock = do -- | Generate haddocks for the package. generateHaddocks :: Env -> FilePath -> CmdOption -> PackageName -> Version -> TestState -> Action () generateHaddocks env@Env{..} pdir envmap name version expected = do - hfs <- liftIO $ readTVarIO envHadLock + hfs <- liftIO $ readTVarIO envHaddocks exitCode <- cmd (Cwd (FP.encodeString pdir)) @@ -253,210 +422,12 @@ generateHaddocks env@Env{..} pdir envmap name version expected = do do let orig = pkgDocDir env name version exists <- FP.isDirectory orig when exists $ - renameOrCopy - orig - (pbDocDir envPB <> FP.decodeString ident) - enewPath <- - liftIO $ - try $ + renameOrCopy orig (pbDocDir envPB <> FP.decodeString ident) + enewPath <- liftIO $ try $ FP.canonicalizePath (pbDocDir envPB <> FP.decodeString ident <> FP.decodeString (display name ++ ".haddock")) case enewPath of Left (_ :: IOException) -> return () -- FIXME: log it with Shake. - Right newPath -> liftIO $ atomically $ modifyTVar envHadLock $ + Right newPath -> liftIO $ atomically $ modifyTVar envHaddocks $ M.insert (ident) newPath - --- | Generate a flags string for the package plan. -planFlags :: PackagePlan -> String -planFlags plan = unwords $ - map go $ M.toList (pcFlagOverrides (ppConstraints plan)) - where go (name',isOn) = concat - [ if isOn then "" else "-" , T.unpack (unFlagName name')] - --- | Database location. -buildDatabase :: FilePath -> FilePath -buildDatabase shakeDir = shakeDir <> "pkgdb" - --- | Print the name and version. -nameVer :: PackageName -> Version -> String -nameVer name version = display name ++ "-" ++ display version - --- | The directory for the package's docs. -pkgDocDir :: Env -> PackageName -> Version -> FilePath -pkgDocDir env@Env{..} name version = pkgDir env name version <> - "dist" <> - "doc" <> - "html" <> - (FP.decodeString (display name)) - --- | The package directory. -pkgDir :: Env -> PackageName -> Version -> FilePath -pkgDir Env{..} name version = envShake <> "packages" <> - (FP.decodeString (nameVer name version)) - --- | Get the target file for confirming that all packages have been --- pre-fetched. -targetForFetched :: Env -> Target -targetForFetched Env{..} = - Target (envShake <> "packages-fetched") - --- | Get the target file for a package. -targetForPackage :: FilePath -> PackageName -> Version -> Target -targetForPackage shakeDir name version = Target $ - shakeDir <> "packages" <> - FP.decodeString - (nameVer name version) <> - "dist" <> - "shake-build" - --- | Get the target file for a package. -targetForDocs :: FilePath -> PackageName -> Version -> Target -targetForDocs shakeDir name version = Target $ - shakeDir <> "packages" <> - FP.decodeString - (nameVer name version) <> - "dist" <> - "shake-docs" - --- | Target for the complete, copied build under builds/date/. -targetForBuild :: PerformBuild -> Target -targetForBuild pb = Target $ (pbInstallDest pb) <> "shake-built" - --- | Get a package database path. -targetForDb :: Env -> Target -targetForDb Env{..} = - Target $ envShake <> "pkgdb-initialized" - --- | Make a file of this name. -makeTargetFile :: Target -> Action () -makeTargetFile fp = liftIO $ FP.writeFile (unTarget fp) "" - -pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath -pbBinDir root = (pbInstallDest root) <> "bin" -pbLibDir root = (pbInstallDest root) <> "lib" -pbDataDir root = (pbInstallDest root) <> "share" -pbDocDir root = (pbInstallDest root) <> "doc" - --- | Reason for purging a package. -data PurgeReason - = NoLongerIncluded - | Replaced Version - | Broken - --- | Print the new packages. -printNewPackages :: Env -> IO () -printNewPackages Env{..} = do - unless - (M.null new) - (do putStrLn - ("There are " ++ - show (M.size new) ++ - " packages to build and install: ") - forM_ - (map fst (take maxDisplay (M.toList new))) - (putStrLn . display) - when (M.size new > maxDisplay) - (putStrLn ("And " ++ show (M.size new - maxDisplay) ++ " more."))) - where maxDisplay = 10 - new = M.filterWithKey - (\name _ -> - isNothing (find ((== name) . pkgName) envRegistered)) - versions - versions = (M.map ppVersion . - M.filter (not . S.null . sdModules . ppDesc) . - bpPackages . pbPlan) envPB - --- | Clean up old versions of packages that are no longer in use. -cleanOldPackages :: Env -> IO () -cleanOldPackages env@Env{..} = do - putStrLn "Collecting garbage" - pkgs <- getRegisteredPackages envShake - let toRemove = mapMaybe - (\(PackageIdentifier name version) -> - case M.lookup name versions of - Just version' - | version' == version -> - Nothing - Just newVersion -> Just - (name, version, (Replaced newVersion)) - Nothing -> Just (name, version, NoLongerIncluded)) - pkgs - unless (null toRemove) - (putStrLn ("There are " ++ show (length toRemove) ++ " packages to be purged.")) - when (length toRemove > 0) - (do putStrLn "Waiting 3 seconds before proceeding to remove ..." - threadDelay (1000 * 1000 * 3)) - forM_ pkgs $ - \(PackageIdentifier name version) -> - case M.lookup name versions of - Just version' - | version' == version -> - return () - Just newVersion -> purgePackage - env - name - version - (Replaced newVersion) - Nothing -> purgePackage env name version NoLongerIncluded - broken <- getBrokenPackages envShake - unless (null broken) - (putStrLn ("There are " ++ show (length broken) ++ " broken packages to be purged.")) - when (length broken > 0) - (do putStrLn "Waiting 3 seconds before proceeding to remove ..." - threadDelay (1000 * 1000 * 3)) - forM_ - broken - (\(PackageIdentifier name version) -> - purgePackage env name version Broken) - where versions = (M.map ppVersion . bpPackages . pbPlan) envPB - --- | Purge the given package and version. -purgePackage :: Env -> PackageName -> Version -> PurgeReason -> IO () -purgePackage env name version reason = do - putStr $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... " - unregister - remove - putStrLn "done." - where showReason = - case reason of - Replaced version' -> "replaced by " ++ ordinal ++ " " ++ display version' - where ordinal | version' > version = "newer" - | otherwise = "older" - NoLongerIncluded -> "no longer included" - Broken -> "broken" - ident = nameVer name version - unregister = do - void (readProcessWithExitCode - "ghc-pkg" - ["unregister", "-f", FP.encodeString (buildDatabase (envShake env)), "--force", ident] - "") - remove = FP.removeTree $ - pkgDir env name version - --- | Get broken packages. -getBrokenPackages :: FilePath -> IO [PackageIdentifier] -getBrokenPackages shakeDir = do - (_,ps) <- sourceProcessWithConsumer - (proc - "ghc-pkg" - ["check", "--simple-output", "-f", FP.encodeString (buildDatabase shakeDir)]) - (CT.decodeUtf8 $= CT.lines $= CL.consume) - return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) - --- | Get available packages. -getRegisteredPackages :: FilePath -> IO [PackageIdentifier] -getRegisteredPackages shakeDir = do - (_,ps) <- sourceProcessWithConsumer - (proc - "ghc-pkg" - ["list", "--simple-output", "-f", FP.encodeString (buildDatabase shakeDir)]) - (CT.decodeUtf8 $= CT.lines $= CL.consume) - return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) - --- | Parse a package identifier: foo-1.2.3 -parsePackageIdent :: Text -> Maybe PackageIdentifier -parsePackageIdent = fmap fst . - listToMaybe . - filter (null . snd) . - readP_to_S parse . T.unpack diff --git a/stackage.cabal b/stackage.cabal index 00fba4d3..dc35af4c 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -31,6 +31,7 @@ library Stackage.PerformBuild Stackage.ShakeBuild Stackage.CompleteBuild + Stackage.GhcPkg other-modules: Development.Shake.FilePath build-depends: