From d3aef9070733094b26ad23e17481ad754ef41703 Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Fri, 13 May 2016 04:25:00 -0700 Subject: [PATCH] WIP usage of store in stack --- src/Data/Binary/VersionTagged.hs | 90 --------------- src/Data/Store/VersionTagged.hs | 79 +++++++++++++ src/Stack/Build.hs | 2 +- src/Stack/Build/Cache.hs | 161 +++++++++++++++++---------- src/Stack/Build/ConstructPlan.hs | 13 ++- src/Stack/Build/Source.hs | 2 +- src/Stack/BuildPlan.hs | 8 +- src/Stack/Ghci.hs | 4 +- src/Stack/PackageDump.hs | 32 +++--- src/Stack/PackageIndex.hs | 2 +- src/Stack/Types/Build.hs | 39 +++---- src/Stack/Types/BuildPlan.hs | 74 ++++++------ src/Stack/Types/Compiler.hs | 5 +- src/Stack/Types/Config.hs | 4 +- src/Stack/Types/FlagName.hs | 8 +- src/Stack/Types/GhcPkgId.hs | 7 +- src/Stack/Types/Nix.hs | 2 +- src/Stack/Types/Package.hs | 19 ++-- src/Stack/Types/PackageIdentifier.hs | 5 +- src/Stack/Types/PackageIndex.hs | 23 ++-- src/Stack/Types/PackageName.hs | 10 +- src/Stack/Types/StackT.hs | 76 +++++++------ src/Stack/Types/Version.hs | 7 +- src/test/Stack/StoreSpec.hs | 85 ++++++++++++++ stack-7.8.yaml | 4 + stack-8.0.yaml | 5 +- stack.cabal | 13 ++- stack.yaml | 4 + 28 files changed, 465 insertions(+), 318 deletions(-) delete mode 100644 src/Data/Binary/VersionTagged.hs create mode 100644 src/Data/Store/VersionTagged.hs create mode 100644 src/test/Stack/StoreSpec.hs diff --git a/src/Data/Binary/VersionTagged.hs b/src/Data/Binary/VersionTagged.hs deleted file mode 100644 index 4533be713d..0000000000 --- a/src/Data/Binary/VersionTagged.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ConstraintKinds #-} --- | Tag a Binary instance with the stack version number to ensure we're --- reading a compatible format. -module Data.Binary.VersionTagged - ( taggedDecodeOrLoad - , taggedEncodeFile - , Binary (..) - , BinarySchema - , HasStructuralInfo - , HasSemanticVersion - , decodeFileOrFailDeep - , NFData (..) - ) where - -import Control.DeepSeq (NFData (..)) -import Control.Exception (Exception) -import Control.Monad.Catch (MonadThrow (..)) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger -import Data.Binary (Binary (..)) -import Data.Binary.Get (ByteOffset) -import Data.Binary.Tagged (HasStructuralInfo, HasSemanticVersion) -import qualified Data.Binary.Tagged as BinaryTagged -import Data.Monoid ((<>)) -import Data.Typeable (Typeable) -import Control.Exception.Enclosed (tryAnyDeep) -import Path -import Path.IO (ensureDir) -import qualified Data.Text as T - -type BinarySchema a = (Binary a, NFData a, HasStructuralInfo a, HasSemanticVersion a) - --- | Write to the given file, with a binary-tagged tag. -taggedEncodeFile :: (BinarySchema a, MonadIO m) - => Path Abs File - -> a - -> m () -taggedEncodeFile fp x = liftIO $ do - ensureDir (parent fp) - BinaryTagged.taggedEncodeFile (toFilePath fp) x - --- | Read from the given file. If the read fails, run the given action and --- write that back to the file. Always starts the file off with the version --- tag. -taggedDecodeOrLoad :: (BinarySchema a, MonadIO m, MonadLogger m) - => Path Abs File - -> m a - -> m a -taggedDecodeOrLoad fp mx = do - let fpt = T.pack (toFilePath fp) - $logDebug $ "Trying to decode " <> fpt - eres <- decodeFileOrFailDeep fp - case eres of - Left _ -> do - $logDebug $ "Failure decoding " <> fpt - x <- mx - taggedEncodeFile fp x - return x - Right x -> do - $logDebug $ "Success decoding " <> fpt - return x - --- | Ensure that there are no lurking exceptions deep inside the parsed --- value... because that happens unfortunately. See --- https://github.com/commercialhaskell/stack/issues/554 -decodeFileOrFailDeep :: (BinarySchema a, MonadIO m, MonadThrow n) - => Path loc File - -> m (n a) -decodeFileOrFailDeep fp = liftIO $ fmap (either throwM return) $ tryAnyDeep $ do - eres <- BinaryTagged.taggedDecodeFileOrFail (toFilePath fp) - case eres of - Left (offset, str) -> throwM $ DecodeFileFailure (toFilePath fp) offset str - Right x -> return x - -data DecodeFileFailure = DecodeFileFailure FilePath ByteOffset String - deriving Typeable -instance Show DecodeFileFailure where - show (DecodeFileFailure fp offset str) = concat - [ "Decoding of " - , fp - , " failed at offset " - , show offset - , ": " - , str - ] -instance Exception DecodeFileFailure diff --git a/src/Data/Store/VersionTagged.hs b/src/Data/Store/VersionTagged.hs new file mode 100644 index 0000000000..b1a39ee177 --- /dev/null +++ b/src/Data/Store/VersionTagged.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +-- | Tag a Store instance with structural version info to ensure we're +-- reading a compatible format. +module Data.Store.VersionTagged + ( taggedDecodeOrLoad + , taggedEncodeFile + , decodeFileMaybe + ) where + +import Control.Exception.Lifted (catch, IOException, assert) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Logger +import Control.Monad.Trans.Control (MonadBaseControl) +import qualified Data.ByteString as BS +import Data.Monoid ((<>)) +import Data.Store +import Data.Store.TypeHash +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Path +import Path.IO (ensureDir) + +-- | Write to the given file, with a binary-tagged tag. +taggedEncodeFile :: (Store a, HasTypeHash a, MonadIO m, MonadLogger m, Eq a) + => Path Abs File + -> a + -> m () +taggedEncodeFile fp x = do + let fpt = T.pack (toFilePath fp) + $logDebug $ "Encoding " <> fpt + ensureDir (parent fp) + let encoded = encode (Tagged x) + -- liftIO $ BS.appendFile "encode-log" $ encodeUtf8 fpt <> " is " <> encoded <> "DONE" + -- $logDebug $ "Encoded: " <> decodeUtf8 (B16.encode encoded) + assert (decodeEx encoded == Tagged x) $ liftIO $ BS.writeFile (toFilePath fp) encoded + $logDebug $ "Finished writing " <> fpt + +-- | Read from the given file. If the read fails, run the given action and +-- write that back to the file. Always starts the file off with the +-- version tag. +taggedDecodeOrLoad :: (Store a, HasTypeHash a, Eq a, MonadIO m, MonadLogger m, MonadBaseControl IO m) + => Path Abs File + -> m a + -> m a +taggedDecodeOrLoad fp mx = do + let fpt = T.pack (toFilePath fp) + $logDebug $ "Trying to decode " <> fpt + mres <- decodeFileMaybe fp + case mres of + Nothing -> do + $logDebug $ "Failure decoding " <> fpt + x <- mx + taggedEncodeFile fp x + return x + Just (Tagged x) -> do + $logDebug $ "Success decoding " <> fpt + return x + +decodeFileMaybe :: (Store a, MonadIO m, MonadLogger m, MonadBaseControl IO m) + => Path loc File + -> m (Maybe a) +decodeFileMaybe fp = do + mbs <- liftIO (Just <$> BS.readFile (toFilePath fp)) `catch` \(err :: IOException) -> do + $logDebug ("Exception ignored when attempting to load " <> T.pack (toFilePath fp) <> ": " <> T.pack (show err)) + return Nothing + case mbs of + Nothing -> return Nothing + Just bs -> do + liftIO (Just <$> decodeIO bs) `catch` \(err :: PeekException) -> do + let fpt = T.pack (toFilePath fp) + $logDebug ("Error while decoding " <> fpt <> ": " <> T.pack (show err) <> " (this might not be an error, when switching between stack versions)") + -- liftIO $ BS.appendFile "decode-error-log" $ encodeUtf8 fpt <> " is " <> bs <> "DONE" + -- $logDebug $ "Input: " <> decodeUtf8 (B16.encode bs) + return Nothing diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 71ba298ef3..8316b7d072 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -69,7 +69,7 @@ import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getCons import qualified Control.Monad.Catch as Catch #endif -type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseUnlift IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env) +type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLoggerIO m,MonadBaseUnlift IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env) -- | Build. -- diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index 1e2f79b2ce..cebfa9333b 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -4,13 +4,16 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Cache information about previous builds module Stack.Build.Cache ( tryGetBuildCache , tryGetConfigCache , tryGetCabalMod , getInstalledExes - , buildCacheTimes , tryGetFlagCache , deleteCaches , markExeInstalled @@ -24,29 +27,40 @@ module Stack.Build.Cache , checkTestSuccess , writePrecompiledCache , readPrecompiledCache + -- Exported for testing + , BuildCache(..) ) where -import Control.Exception.Enclosed (handleIO) +import Control.DeepSeq (NFData) +import Control.Exception.Enclosed (handleIO, tryAnyDeep) import Control.Monad.Catch (MonadThrow, MonadCatch) import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger, logDebug) import Control.Monad.Reader +import Control.Monad.Trans.Control (MonadBaseControl) import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Data.Binary as Binary (encode) -import Data.Binary.VersionTagged -import qualified Data.ByteString.Char8 as S8 +import Data.Binary (Binary (..)) +import qualified Data.Binary as Binary +import Data.Binary.Tagged (HasStructuralInfo, HasSemanticVersion) +import qualified Data.Binary.Tagged as BinaryTagged import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Base64.URL as B64URL +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as LBS import Data.Map (Map) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid ((<>)) import Data.Set (Set) import qualified Data.Set as Set +import Data.Store (Store) +import qualified Data.Store as Store +import Data.Store.TypeHash (HasTypeHash, mkManyHasTypeHash) +import Data.Store.VersionTagged import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) import Path import Path.IO -import Stack.Types.Build import Stack.Constants import Stack.Types @@ -91,38 +105,36 @@ data BuildCache = BuildCache { buildCacheTimes :: !(Map FilePath FileCacheInfo) -- ^ Modification times of files. } - deriving (Generic) -instance Binary BuildCache -instance HasStructuralInfo BuildCache -instance HasSemanticVersion BuildCache + deriving (Generic, Eq, Show) +instance Store BuildCache instance NFData BuildCache -- | Try to read the dirtiness cache for the given package directory. -tryGetBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env) +tryGetBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env, MonadBaseControl IO m) => Path Abs Dir -> m (Maybe (Map FilePath FileCacheInfo)) tryGetBuildCache = liftM (fmap buildCacheTimes) . tryGetCache buildCacheFile -- | Try to read the dirtiness cache for the given package directory. -tryGetConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env) +tryGetConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m) => Path Abs Dir -> m (Maybe ConfigCache) tryGetConfigCache = tryGetCache configCacheFile -- | Try to read the mod time of the cabal file from the last build -tryGetCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env) +tryGetCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m) => Path Abs Dir -> m (Maybe ModTime) tryGetCabalMod = tryGetCache configCabalMod -- | Try to load a cache. -tryGetCache :: (MonadIO m, BinarySchema a) +tryGetCache :: (MonadIO m, Store a, MonadBaseControl IO m, MonadLogger m) => (Path Abs Dir -> m (Path Abs File)) -> Path Abs Dir -> m (Maybe a) tryGetCache get' dir = do fp <- get' dir - decodeFileOrFailDeep fp + decodeFileMaybe fp -- | Write the dirtiness cache for this package's files. -writeBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env) +writeBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) => Path Abs Dir -> Map FilePath FileCacheInfo -> m () writeBuildCache dir times = writeCache @@ -133,14 +145,14 @@ writeBuildCache dir times = } -- | Write the dirtiness cache for this package's configuration. -writeConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env) +writeConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) => Path Abs Dir -> ConfigCache -> m () writeConfigCache dir = writeCache dir configCacheFile -- | See 'tryGetCabalMod' -writeCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env) +writeCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) => Path Abs Dir -> ModTime -> m () @@ -158,7 +170,7 @@ deleteCaches dir = do ignoringAbsence (removeFile cfp) -- | Write to a cache. -writeCache :: (BinarySchema a, MonadIO m) +writeCache :: (Store a, NFData a, HasTypeHash a, Eq a, MonadIO m, MonadLogger m) => Path Abs Dir -> (Path Abs Dir -> m (Path Abs File)) -> a @@ -179,25 +191,24 @@ flagCacheFile installed = do return $ dir rel -- | Loads the flag cache for the given installed extra-deps -tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) +tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m) => Installed -> m (Maybe ConfigCache) tryGetFlagCache gid = do fp <- flagCacheFile gid - decodeFileOrFailDeep fp + decodeFileMaybe fp -writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m) +writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m, MonadLogger m, MonadBaseControl IO m) => Installed -> ConfigCache -> m () writeFlagCache gid cache = do file <- flagCacheFile gid - liftIO $ do - ensureDir (parent file) - taggedEncodeFile file cache + ensureDir (parent file) + taggedEncodeFile file cache -- | Mark a test suite as having succeeded -setTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) +setTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) => Path Abs Dir -> m () setTestSuccess dir = @@ -207,7 +218,7 @@ setTestSuccess dir = True -- | Mark a test suite as not having succeeded -unsetTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) +unsetTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) => Path Abs Dir -> m () unsetTestSuccess dir = @@ -217,7 +228,7 @@ unsetTestSuccess dir = False -- | Check if the test suite already passed -checkTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) +checkTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m) => Path Abs Dir -> m Bool checkTestSuccess dir = @@ -236,48 +247,49 @@ checkTestSuccess dir = -- | The file containing information on the given package/configuration -- combination. The filename contains a hash of the non-directory configure -- options for quick lookup if there's a match. +-- +-- It also returns an action yielding the location of the precompiled +-- path based on the old binary encoding. +-- +-- We only pay attention to non-directory options. We don't want to avoid a +-- cache hit just because it was installed in a different directory. precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) => PackageIdentifier -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies - -> m (Path Abs File) + -> m (Path Abs File, m (Path Abs File)) precompiledCacheFile pkgident copts installedPackageIDs = do ec <- asks getEnvConfig compiler <- parseRelDir $ compilerVersionString $ envConfigCompilerVersion ec cabal <- parseRelDir $ versionString $ envConfigCabalVersion ec pkg <- parseRelDir $ packageIdentifierString pkgident + platformRelDir <- platformGhcRelDir + + let input = (coNoDirs copts, installedPackageIDs) -- In Cabal versions 1.22 and later, the configure options contain the -- installed package IDs, which is what we need for a unique hash. -- Unfortunately, earlier Cabals don't have the information, so we must - -- supplement it with the installed package IDs directly. In 20/20 - -- hindsight, we would simply always do that, but previous Stack releases - -- used only the options, and we don't want to invalidate old caches - -- unnecessarily. - -- + -- supplement it with the installed package IDs directly. -- See issue: https://github.com/commercialhaskell/stack/issues/1103 - let computeCacheSource input = do - $logDebug $ "Precompiled cache input = " <> T.pack (show input) - return $ Binary.encode input - cacheInput <- - if envConfigCabalVersion ec >= $(mkVersion "1.22") - then computeCacheSource (coNoDirs copts) - else computeCacheSource (coNoDirs copts, installedPackageIDs) - - -- We only pay attention to non-directory options. We don't want to avoid a - -- cache hit just because it was installed in a different directory. - copts' <- parseRelFile $ S8.unpack $ B16.encode $ SHA256.hashlazy cacheInput - - platformRelDir <- platformGhcRelDir + let oldHash = B16.encode $ SHA256.hash $ LBS.toStrict $ + if envConfigCabalVersion ec >= $(mkVersion "1.22") + then Binary.encode (coNoDirs copts) + else Binary.encode input + hashToPath hash = do + hashPath <- parseRelFile $ S8.unpack hash + return $ getStackRoot ec + $(mkRelDir "precompiled") + platformRelDir + compiler + cabal + pkg + hashPath - return $ getStackRoot ec - $(mkRelDir "precompiled") - platformRelDir - compiler - cabal - pkg - copts' + $logDebug $ "Precompiled cache input = " <> T.pack (show input) + newPath <- hashToPath $ B64URL.encode $ SHA256.hash $ Store.encode input + return (newPath, hashToPath oldHash) -- | Write out information about a newly built package writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m) @@ -289,7 +301,7 @@ writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, Mon -> Set Text -- ^ executables -> m () writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do - file <- precompiledCacheFile pkgident copts depIDs + (file, _) <- precompiledCacheFile pkgident copts depIDs ensureDir (parent file) mlibpath <- case mghcPkgId of @@ -300,18 +312,49 @@ writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do exes' <- forM (Set.toList exes) $ \exe -> do name <- parseRelFile $ T.unpack exe return $ toFilePath $ bcoSnapInstallRoot baseConfigOpts bindirSuffix name - liftIO $ taggedEncodeFile file PrecompiledCache + taggedEncodeFile file PrecompiledCache { pcLibrary = mlibpath , pcExes = exes' } -- | Check the cache for a precompiled package matching the given -- configuration. -readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m) +readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m, MonadBaseControl IO m) => PackageIdentifier -- ^ target package -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies -> m (Maybe PrecompiledCache) readPrecompiledCache pkgident copts depIDs = do - file <- precompiledCacheFile pkgident copts depIDs - decodeFileOrFailDeep file + (file, getOldFile) <- precompiledCacheFile pkgident copts depIDs + mres <- decodeFileMaybe file + case mres of + Just res -> return res + Nothing -> do + -- Fallback on trying the old binary format. + oldFile <- getOldFile + mpc <- binaryDecodeFileOrFailDeep oldFile + -- Write out file in new format. Keep old file around for + -- the benefit of older stack versions. + forM_ mpc (taggedEncodeFile file) + return mpc + +-- | Ensure that there are no lurking exceptions deep inside the parsed +-- value... because that happens unfortunately. See +-- https://github.com/commercialhaskell/stack/issues/554 +binaryDecodeFileOrFailDeep :: (BinarySchema a, MonadIO m) + => Path loc File + -> m (Maybe a) +binaryDecodeFileOrFailDeep fp = liftIO $ fmap (either (\_ -> Nothing) id) $ tryAnyDeep $ do + eres <- BinaryTagged.taggedDecodeFileOrFail (toFilePath fp) + case eres of + Left _ -> return Nothing + Right x -> return (Just x) + +type BinarySchema a = (Binary a, NFData a, HasStructuralInfo a, HasSemanticVersion a) + +$(mkManyHasTypeHash + [ [t| BuildCache |] + -- TODO: put this orphan elsewhere? Not sure if we want tons of + -- instances of HasTypeHash or not. + , [t| Bool |] + ]) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 8a91ec875b..8f189bcbf5 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -17,7 +17,7 @@ import Control.Exception.Lifted import Control.Monad import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class -import Control.Monad.Logger (MonadLogger, logWarn) +import Control.Monad.Logger import Control.Monad.RWS.Strict import Control.Monad.Trans.Resource import Data.Either @@ -111,6 +111,7 @@ data Ctx = Ctx , getVersions :: !(PackageName -> IO (Set Version)) , wanted :: !(Set PackageName) , localNames :: !(Set PackageName) + , logFunc :: Loc -> LogSource -> LogLevel -> LogStr -> IO () } instance HasStackRoot Ctx @@ -123,7 +124,7 @@ instance HasEnvConfig Ctx where getEnvConfig = ctxEnvConfig constructPlan :: forall env m. - (MonadCatch m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m, MonadBaseControl IO m, HasHttpManager env) + (MonadCatch m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLoggerIO m, MonadBaseControl IO m, HasHttpManager env) => MiniBuildPlan -> BaseConfigOpts -> [LocalPackage] @@ -142,8 +143,9 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackag let inner = do mapM_ onWanted $ filter lpWanted locals mapM_ (addDep False) $ Set.toList extraToBuild0 + lf <- askLoggerIO ((), m, W efinals installExes dirtyReason deps warnings) <- - liftIO $ runRWST inner (ctx econfig getVersions0) M.empty + liftIO $ runRWST inner (ctx econfig getVersions0 lf) M.empty mapM_ $logWarn (warnings []) let toEither (_, Left e) = Left e toEither (k, Right v) = Right (k, v) @@ -171,7 +173,7 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackag } else throwM $ ConstructPlanExceptions errs (bcStackYaml $ getBuildConfig econfig) where - ctx econfig getVersions0 = Ctx + ctx econfig getVersions0 lf = Ctx { mbp = mbp0 , baseConfigOpts = baseConfigOpts0 , loadPackage = loadPackage0 @@ -185,6 +187,7 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackag , getVersions = getVersions0 , wanted = wantedLocalPackages locals , localNames = Set.fromList $ map (packageName . lpPackage) locals + , logFunc = lf } -- TODO Currently, this will only consider and install tools from the -- snapshot. It will not automatically install build tools from extra-deps @@ -498,7 +501,7 @@ checkDirtiness :: PackageSource -> M Bool checkDirtiness ps installed package present wanted = do ctx <- ask - moldOpts <- tryGetFlagCache installed + moldOpts <- flip runLoggingT (logFunc ctx) $ tryGetFlagCache installed let configOpts = configureOpts (getEnvConfig ctx) (baseConfigOpts ctx) diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 6f986c3cc9..105a1515a8 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -312,7 +312,7 @@ splitComponents = -- based on the selected components loadLocalPackage :: forall m env. - (MonadReader env m, HasEnvConfig env, MonadMask m, MonadLogger m, MonadIO m) + (MonadReader env m, HasEnvConfig env, MonadMask m, MonadLogger m, MonadIO m, MonadBaseControl IO m) => BuildOptsCLI -> Map PackageName SimpleTarget -> (PackageName, (LocalPackageView, GenericPackageDescription)) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 2456d162f4..5c210a66e9 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -45,7 +45,7 @@ import Control.Monad.State.Strict (State, execState, get, modify, import Control.Monad.Trans.Control (MonadBaseControl) import qualified Crypto.Hash.SHA256 as SHA256 import Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings) -import Data.Binary.VersionTagged (taggedDecodeOrLoad, decodeFileOrFailDeep, taggedEncodeFile) +import Data.Store.VersionTagged (taggedDecodeOrLoad, decodeFileMaybe, taggedEncodeFile) import qualified Data.ByteString as S import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.ByteString.Char8 as S8 @@ -1024,11 +1024,11 @@ parseCustomMiniBuildPlan mconfigPath0 url0 = do exists <- doesFileExist binaryPath if exists then do - eres <- decodeFileOrFailDeep binaryPath + eres <- decodeFileMaybe binaryPath case eres of - Right (Just mbp) -> return mbp + Just mbp -> return mbp -- Invalid format cache file, remove. - _ -> do + Nothing -> do removeFile binaryPath getMbp0 else getMbp0 diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index ff3813817f..b9856548d6 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -108,7 +108,7 @@ instance Show GhciException where -- given options and configure it with the load paths and extensions -- of those targets. ghci - :: (HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadBaseUnlift IO m) + :: (HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadLoggerIO m, MonadBaseUnlift IO m) => GhciOpts -> m () ghci opts@GhciOpts{..} = do bopts <- asks (configBuild . getConfig) @@ -273,7 +273,7 @@ figureOutMainFile bopts mainIsTargets targets0 packages = -- | Create a list of infos for each target containing necessary -- information to load that package/components. ghciSetup - :: (HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadBaseUnlift IO m) + :: (HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadLoggerIO m, MonadBaseUnlift IO m) => GhciOpts -> m (Map PackageName SimpleTarget, Maybe (Map PackageName SimpleTarget), [GhciPkgInfo]) ghciSetup GhciOpts{..} = do diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index dc5368c04d..9da3048945 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -5,6 +5,8 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} module Stack.PackageDump ( Line , eachSection @@ -14,6 +16,7 @@ module Stack.PackageDump , ghcPkgDump , ghcPkgDescribe , InstalledCache + , InstalledCacheInner (..) , InstalledCacheEntry (..) , newInstalledCache , loadInstalledCache @@ -34,7 +37,7 @@ import Control.Monad.Logger (MonadLogger) import Control.Monad.Trans.Control import Data.Attoparsec.Args import Data.Attoparsec.Text as P -import Data.Binary.VersionTagged +import Data.Store.VersionTagged import Data.Conduit import qualified Data.Conduit.List as CL import qualified Data.Conduit.Text as CT @@ -45,13 +48,15 @@ import qualified Data.Map as Map import Data.Maybe (catMaybes, listToMaybe) import Data.Maybe.Extra (mapMaybeM) import qualified Data.Set as Set -import qualified Data.Text as T +import Data.Store (Store) +import Data.Store.TypeHash (mkManyHasTypeHash) import Data.Text (Text) +import qualified Data.Text as T import Data.Typeable (Typeable) import GHC.Generics (Generic) import Path -import Path.IO (ensureDir) import Path.Extra (toFilePathNoTrailingSep) +import Path.IO (ensureDir) import Prelude -- Fix AMP warning import Stack.GhcPkg import Stack.Types @@ -61,19 +66,15 @@ import System.Process.Read -- | Cached information on whether package have profiling libraries and haddocks. newtype InstalledCache = InstalledCache (IORef InstalledCacheInner) newtype InstalledCacheInner = InstalledCacheInner (Map GhcPkgId InstalledCacheEntry) - deriving (Binary, NFData, Generic) -instance HasStructuralInfo InstalledCacheInner -instance HasSemanticVersion InstalledCacheInner + deriving (Store, Generic, Eq, Show) -- | Cached information on whether a package has profiling libraries and haddocks. data InstalledCacheEntry = InstalledCacheEntry { installedCacheProfiling :: !Bool , installedCacheHaddock :: !Bool , installedCacheIdent :: !PackageIdentifier } - deriving (Eq, Generic) -instance Binary InstalledCacheEntry -instance HasStructuralInfo InstalledCacheEntry -instance NFData InstalledCacheEntry + deriving (Eq, Generic, Show) +instance Store InstalledCacheEntry -- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDump @@ -127,16 +128,17 @@ newInstalledCache = liftIO $ InstalledCache <$> newIORef (InstalledCacheInner Ma -- | Load a @InstalledCache@ from disk, swallowing any errors and returning an -- empty cache. -loadInstalledCache :: (MonadLogger m, MonadIO m) => Path Abs File -> m InstalledCache +loadInstalledCache :: (MonadLogger m, MonadIO m, MonadBaseControl IO m) + => Path Abs File -> m InstalledCache loadInstalledCache path = do m <- taggedDecodeOrLoad path (return $ InstalledCacheInner Map.empty) liftIO $ InstalledCache <$> newIORef m -- | Save a @InstalledCache@ to disk -saveInstalledCache :: MonadIO m => Path Abs File -> InstalledCache -> m () -saveInstalledCache path (InstalledCache ref) = liftIO $ do +saveInstalledCache :: (MonadLogger m, MonadIO m) => Path Abs File -> InstalledCache -> m () +saveInstalledCache path (InstalledCache ref) = do ensureDir (parent path) - readIORef ref >>= taggedEncodeFile path + liftIO (readIORef ref) >>= taggedEncodeFile path -- | Prune a list of possible packages down to those whose dependencies are met. -- @@ -447,3 +449,5 @@ takeWhileC f = go x | f x = yield x >> loop | otherwise = leftover x + +$(mkManyHasTypeHash [ [t| InstalledCacheInner |] ]) diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs index 54d4b85057..ab9411da20 100644 --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -38,7 +38,7 @@ import Control.Monad.Reader (asks) import Control.Monad.Trans.Control import Data.Aeson.Extended -import Data.Binary.VersionTagged +import Data.Store.VersionTagged import qualified Data.ByteString.Lazy as L import Data.Conduit (($$), (=$)) import Data.Conduit.Binary (sinkHandle, diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 2e80a0e8fb..310a74e5f3 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -44,9 +44,8 @@ module Stack.Types.Build import Control.DeepSeq import Control.Exception - -import Data.Binary (getWord8, putWord8, gput, gget) -import Data.Binary.VersionTagged +import Data.Binary (Binary) +import Data.Binary.Tagged (HasSemanticVersion, HasStructuralInfo) import qualified Data.ByteString as S import Data.Char (isSpace) import Data.Data @@ -58,16 +57,18 @@ import Data.Maybe import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set +import Data.Store.Internal (Store) +import Data.Store.TypeHash (mkManyHasTypeHash) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Data.Time.Calendar import Data.Time.Clock -import Distribution.System (Arch) import Distribution.PackageDescription (TestSuiteInterface) +import Distribution.System (Arch) import Distribution.Text (display) -import GHC.Generics (Generic, from, to) +import GHC.Generics (Generic) import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, ()) import Path.Extra (toFilePathNoTrailingSep) import Prelude @@ -450,7 +451,7 @@ instance Show ConstructPlanException where -- | Package dependency oracle. newtype PkgDepsOracle = PkgDeps PackageName - deriving (Show,Typeable,Eq,Hashable,Binary,NFData) + deriving (Show,Typeable,Eq,Hashable,Store,NFData) -- | Stored on disk to know whether the flags have changed or any -- files have changed. @@ -470,23 +471,8 @@ data ConfigCache = ConfigCache -- ^ Are haddocks to be built? } deriving (Generic,Eq,Show) -instance Binary ConfigCache where - put x = do - -- magic string - putWord8 1 - putWord8 3 - putWord8 4 - putWord8 8 - gput $ from x - get = do - 1 <- getWord8 - 3 <- getWord8 - 4 <- getWord8 - 8 <- getWord8 - fmap to gget +instance Store ConfigCache instance NFData ConfigCache -instance HasStructuralInfo ConfigCache -instance HasSemanticVersion ConfigCache -- | A task to perform when building data Task = Task @@ -706,8 +692,7 @@ data ConfigureOpts = ConfigureOpts , coNoDirs :: ![String] } deriving (Show, Eq, Generic) -instance Binary ConfigureOpts -instance HasStructuralInfo ConfigureOpts +instance Store ConfigureOpts instance NFData ConfigureOpts -- | Information on a compiled package: the library conf file (if relevant), @@ -723,4 +708,10 @@ data PrecompiledCache = PrecompiledCache instance Binary PrecompiledCache instance HasSemanticVersion PrecompiledCache instance HasStructuralInfo PrecompiledCache +instance Store PrecompiledCache instance NFData PrecompiledCache + +$(mkManyHasTypeHash + [ [t| PrecompiledCache |] + , [t| ConfigCache |] + ]) diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index a815e880fc..48d9effe5c 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -4,6 +4,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} -- | Shared types for various stackage packages. module Stack.Types.BuildPlan ( -- * Types @@ -30,36 +32,36 @@ module Stack.Types.BuildPlan ) where import Control.Applicative -import Control.Arrow ((&&&)) -import Control.Exception (Exception) -import Control.Monad.Catch (MonadThrow, throwM) -import Data.Aeson (FromJSON (..), ToJSON (..), - object, withObject, withText, - (.!=), (.:), (.:?), (.=)) -import Data.Binary.VersionTagged -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Hashable (Hashable) -import qualified Data.HashMap.Strict as HashMap -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) +import Control.Arrow ((&&&)) +import Control.DeepSeq (NFData) +import Control.Exception (Exception) +import Control.Monad.Catch (MonadThrow, throwM) +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, withText, (.!=), (.:), (.:?), (.=)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.HashMap.Strict as HashMap +import Data.Hashable (Hashable) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import Data.Monoid -import Data.Set (Set) -import Data.String (IsString, fromString) -import Data.Text (Text, pack, unpack) -import qualified Data.Text as T -import Data.Text.Read (decimal) -import Data.Time (Day) -import qualified Data.Traversable as T -import Data.Typeable (TypeRep, Typeable, typeOf) -import Data.Vector (Vector) -import Distribution.System (Arch, OS (..)) -import qualified Distribution.Text as DT -import qualified Distribution.Version as C -import GHC.Generics (Generic) +import Data.Set (Set) +import Data.Store (Store) +import Data.Store.TypeHash (mkManyHasTypeHash) +import Data.String (IsString, fromString) +import Data.Text (Text, pack, unpack) +import qualified Data.Text as T +import Data.Text.Read (decimal) +import Data.Time (Day) +import qualified Data.Traversable as T +import Data.Typeable (TypeRep, Typeable, typeOf) +import Data.Vector (Vector) +import Distribution.System (Arch, OS (..)) +import qualified Distribution.Text as DT +import qualified Distribution.Version as C +import GHC.Generics (Generic) import Prelude -- Fix AMP warning import Safe (readMay) import Stack.Types.Compiler @@ -277,8 +279,7 @@ newtype Maintainer = Maintainer { unMaintainer :: Text } -- | Name of an executable. newtype ExeName = ExeName { unExeName :: Text } - deriving (Show, Eq, Ord, Hashable, IsString, Generic, Binary, NFData) -instance HasStructuralInfo ExeName + deriving (Show, Eq, Ord, Hashable, IsString, Generic, Store, NFData) instance ToJSON ExeName where toJSON = toJSON . unExeName instance FromJSON ExeName where @@ -429,10 +430,8 @@ data MiniBuildPlan = MiniBuildPlan , mbpPackages :: !(Map PackageName MiniPackageInfo) } deriving (Generic, Show, Eq) -instance Binary MiniBuildPlan +instance Store MiniBuildPlan instance NFData MiniBuildPlan -instance HasStructuralInfo MiniBuildPlan -instance HasSemanticVersion MiniBuildPlan -- | Information on a single package for the 'MiniBuildPlan'. data MiniPackageInfo = MiniPackageInfo @@ -455,15 +454,16 @@ data MiniPackageInfo = MiniPackageInfo -- revision directly from a Git repo } deriving (Generic, Show, Eq) -instance Binary MiniPackageInfo -instance HasStructuralInfo MiniPackageInfo +instance Store MiniPackageInfo instance NFData MiniPackageInfo newtype GitSHA1 = GitSHA1 ByteString - deriving (Generic, Show, Eq, NFData, HasStructuralInfo, Binary) + deriving (Generic, Show, Eq, NFData, Store) newtype SnapshotHash = SnapshotHash { unShapshotHash :: ByteString } deriving (Generic, Show, Eq) trimmedSnapshotHash :: SnapshotHash -> ByteString trimmedSnapshotHash = BS.take 12 . unShapshotHash + +$(mkManyHasTypeHash [ [t| MiniBuildPlan |] ]) diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs index 63bc6e22a4..7d25df194d 100644 --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -6,10 +6,10 @@ module Stack.Types.Compiler where import Control.DeepSeq import Data.Aeson -import Data.Binary.VersionTagged (Binary, HasStructuralInfo) import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid ((<>)) +import Data.Store (Store) import qualified Data.Text as T import GHC.Generics (Generic) import Stack.Types.Version @@ -34,8 +34,7 @@ data CompilerVersion {-# UNPACK #-} !Version -- GHCJS version {-# UNPACK #-} !Version -- GHC version deriving (Generic, Show, Eq, Ord) -instance Binary CompilerVersion -instance HasStructuralInfo CompilerVersion +instance Store CompilerVersion instance NFData CompilerVersion instance ToJSON CompilerVersion where toJSON = toJSON . compilerVersionText diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 83e8ef050e..0b89629299 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -157,7 +157,6 @@ import Data.Aeson.Extended withObjectWarnings, WarningParser, Object, jsonSubWarnings, jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings) import Data.Attoparsec.Args -import Data.Binary (Binary) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Either (partitionEithers) @@ -173,6 +172,7 @@ import Data.Maybe import Data.Monoid.Extra import Data.Set (Set) import qualified Data.Set as Set +import Data.Store (Store) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) @@ -375,7 +375,7 @@ instance FromJSON (WithJSONWarnings PackageIndex) where -- | Unique name for a package index newtype IndexName = IndexName { unIndexName :: ByteString } - deriving (Show, Eq, Ord, Hashable, Binary) + deriving (Show, Eq, Ord, Hashable, Store) indexNameText :: IndexName -> Text indexNameText = decodeUtf8 . unIndexName instance ToJSON IndexName where diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs index dce9daa869..816991008f 100644 --- a/src/Stack/Types/FlagName.hs +++ b/src/Stack/Types/FlagName.hs @@ -22,16 +22,17 @@ module Stack.Types.FlagName where import Control.Applicative +import Control.DeepSeq (NFData) import Control.Monad.Catch import Data.Aeson.Extended -import Data.Attoparsec.Text import Data.Attoparsec.Combinators -import Data.Binary.VersionTagged +import Data.Attoparsec.Text import Data.Char (isLetter, isDigit, toLower) import Data.Data import Data.Hashable import Data.Map (Map) import qualified Data.Map as Map +import Data.Store (Store) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Binary () @@ -51,8 +52,7 @@ instance Show FlagNameParseFail where -- | A flag name. newtype FlagName = FlagName Text - deriving (Typeable,Data,Generic,Hashable,Binary,NFData) -instance HasStructuralInfo FlagName + deriving (Typeable,Data,Generic,Hashable,Store,NFData) instance Eq FlagName where x == y = compare x y == EQ instance Ord FlagName where diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs index ce52455860..2fdb0ea0e6 100644 --- a/src/Stack/Types/GhcPkgId.hs +++ b/src/Stack/Types/GhcPkgId.hs @@ -11,13 +11,15 @@ module Stack.Types.GhcPkgId where import Control.Applicative +import Control.DeepSeq import Control.Monad.Catch import Data.Aeson.Extended import Data.Attoparsec.Text -import Data.Binary (getWord8, putWord8) -import Data.Binary.VersionTagged +import Data.Binary (Binary(..), putWord8, getWord8) +import Data.Binary.Tagged import Data.Data import Data.Hashable +import Data.Store import Data.Text (Text) import qualified Data.Text as T import GHC.Generics @@ -52,6 +54,7 @@ instance Binary GhcPkgId where fmap GhcPkgId get instance NFData GhcPkgId instance HasStructuralInfo GhcPkgId +instance Store GhcPkgId instance Show GhcPkgId where show = show . ghcPkgIdString diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs index c297e27187..6b9b0bf8bb 100644 --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -9,8 +9,8 @@ module Stack.Types.Nix where import Control.Applicative import Data.Aeson.Extended -import Data.Text (Text) import Data.Monoid +import Data.Text (Text) import GHC.Generics (Generic) import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Prelude diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 3f51c6fbe3..9d23ed008b 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -3,6 +3,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} -- | module Stack.Types.Package where @@ -13,8 +15,6 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader -import Data.Binary -import Data.Binary.VersionTagged import qualified Data.ByteString as S import Data.Data import Data.Function @@ -25,9 +25,12 @@ import Data.Maybe import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set +import Data.Store (Store) +import Data.Store.TypeHash (mkManyHasTypeHash) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Word (Word64) import Distribution.InstalledPackageInfo (PError) import Distribution.ModuleName (ModuleName) import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier) @@ -347,17 +350,13 @@ data FileCacheInfo = FileCacheInfo , fciSize :: !Word64 , fciHash :: !S.ByteString } - deriving (Generic, Show) -instance Binary FileCacheInfo -instance HasStructuralInfo FileCacheInfo + deriving (Generic, Show, Eq) +instance Store FileCacheInfo instance NFData FileCacheInfo -- | Used for storage and comparison. newtype ModTime = ModTime (Integer,Rational) - deriving (Ord,Show,Generic,Eq,NFData,Binary) - -instance HasStructuralInfo ModTime -instance HasSemanticVersion ModTime + deriving (Ord,Show,Generic,Eq,NFData,Store) -- | A descriptor from a .cabal file indicating one of the following: -- @@ -428,3 +427,5 @@ installedPackageIdentifier (Executable pid) = pid -- | Get the installed Version. installedVersion :: Installed -> Version installedVersion = packageIdentifierVersion . installedPackageIdentifier + +$(mkManyHasTypeHash [ [t| ModTime |] ]) diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index 6e5b6420cf..4c649791b8 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -22,9 +22,9 @@ import Control.Exception (Exception) import Control.Monad.Catch (MonadThrow, throwM) import Data.Aeson.Extended import Data.Attoparsec.Text -import Data.Binary.VersionTagged (Binary, HasStructuralInfo) import Data.Data import Data.Hashable +import Data.Store (Store) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics @@ -53,8 +53,7 @@ instance NFData PackageIdentifier where seq (rnf p) (rnf v) instance Hashable PackageIdentifier -instance Binary PackageIdentifier -instance HasStructuralInfo PackageIdentifier +instance Store PackageIdentifier instance Show PackageIdentifier where show = show . packageIdentifierString diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs index 0aff54b86e..03703dd195 100644 --- a/src/Stack/Types/PackageIndex.hs +++ b/src/Stack/Types/PackageIndex.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} module Stack.Types.PackageIndex ( PackageDownload (..) @@ -8,14 +10,15 @@ module Stack.Types.PackageIndex , PackageCacheMap (..) ) where +import Control.DeepSeq (NFData) import Control.Monad (mzero) import Data.Aeson.Extended -import qualified Data.Binary as Binary -import Data.Binary.VersionTagged import Data.ByteString (ByteString) import Data.Int (Int64) import Data.Map (Map) import qualified Data.Map.Strict as Map +import Data.Store (Store) +import Data.Store.TypeHash (mkManyHasTypeHash) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Word (Word64) @@ -29,25 +32,21 @@ data PackageCache = PackageCache -- ^ size in bytes of the .cabal file , pcDownload :: !(Maybe PackageDownload) } - deriving (Generic) + deriving (Generic, Eq, Show) -instance Binary PackageCache +instance Store PackageCache instance NFData PackageCache -instance HasStructuralInfo PackageCache newtype PackageCacheMap = PackageCacheMap (Map PackageIdentifier PackageCache) - deriving (Generic, Binary, NFData) -instance HasStructuralInfo PackageCacheMap -instance HasSemanticVersion PackageCacheMap + deriving (Generic, Store, NFData, Eq, Show) data PackageDownload = PackageDownload { pdSHA512 :: !ByteString , pdUrl :: !ByteString , pdSize :: !Word64 } - deriving (Show, Generic) -instance Binary.Binary PackageDownload -instance HasStructuralInfo PackageDownload + deriving (Show, Generic, Eq) +instance Store PackageDownload instance NFData PackageDownload instance FromJSON PackageDownload where parseJSON = withObject "Package" $ \o -> do @@ -64,3 +63,5 @@ instance FromJSON PackageDownload where , pdUrl = encodeUtf8 url , pdSize = size } + +$(mkManyHasTypeHash [ [t| PackageCacheMap |] ]) diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs index 929d25e89e..2a35fab887 100644 --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -28,14 +28,14 @@ import Control.DeepSeq import Control.Monad import Control.Monad.Catch import Data.Aeson.Extended -import Data.Attoparsec.Text import Data.Attoparsec.Combinators -import Data.Binary.VersionTagged (Binary, HasStructuralInfo) +import Data.Attoparsec.Text import Data.Data import Data.Hashable import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map +import Data.Store (Store) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Binary () @@ -43,8 +43,8 @@ import qualified Distribution.Package as Cabal import GHC.Generics import Language.Haskell.TH import Language.Haskell.TH.Syntax -import Path import qualified Options.Applicative as O +import Path -- | A parse fail. data PackageNameParseFail @@ -61,7 +61,7 @@ instance Show PackageNameParseFail where -- | A package name. newtype PackageName = PackageName Text - deriving (Eq,Ord,Typeable,Data,Generic,Hashable,Binary,NFData) + deriving (Eq,Ord,Typeable,Data,Generic,Hashable,NFData,Store) instance Lift PackageName where lift (PackageName n) = @@ -71,8 +71,6 @@ instance Lift PackageName where instance Show PackageName where show (PackageName n) = T.unpack n -instance HasStructuralInfo PackageName - instance ToJSON PackageName where toJSON = toJSON . packageNameText instance FromJSON PackageName where diff --git a/src/Stack/Types/StackT.hs b/src/Stack/Types/StackT.hs index 938c160829..9e7558acf3 100644 --- a/src/Stack/Types/StackT.hs +++ b/src/Stack/Types/StackT.hs @@ -84,7 +84,10 @@ instance MonadTransControl (StackT config) where -- | Takes the configured log level into account. instance (MonadIO m) => MonadLogger (StackT config m) where - monadLoggerLog = stickyLoggerFunc + monadLoggerLog = stickyLoggerFunc + +instance MonadIO m => MonadLoggerIO (StackT config m) where + askLoggerIO = getStickyLoggerFunc -- | Run a Stack action, using global options. runStackTGlobal :: (MonadIO m) @@ -216,13 +219,30 @@ newTLSManager = liftIO $ newManager tlsManagerSettings -------------------------------------------------------------------------------- -- Logging functionality -stickyLoggerFunc :: (HasSticky r, HasLogLevel r, HasSupportsUnicode r, ToLogStr msg, MonadReader r m, MonadIO m) - => Loc -> LogSource -> LogLevel -> msg -> m () +stickyLoggerFunc + :: (HasSticky r, HasLogLevel r, HasSupportsUnicode r, ToLogStr msg, MonadReader r m, MonadIO m) + => Loc -> LogSource -> LogLevel -> msg -> m () stickyLoggerFunc loc src level msg = do - Sticky mref <- asks getSticky + func <- getStickyLoggerFunc + liftIO $ func loc src level msg + +getStickyLoggerFunc + :: (HasSticky r, HasLogLevel r, HasSupportsUnicode r, ToLogStr msg, MonadReader r m, MonadIO m) + => m (Loc -> LogSource -> LogLevel -> msg -> IO ()) +getStickyLoggerFunc = stickyLoggerFuncImpl + <$> asks getSticky + <*> asks getLogLevel + <*> asks getSupportsUnicode + +stickyLoggerFuncImpl + :: ToLogStr msg + => Sticky -> LogLevel -> Bool + -> (Loc -> LogSource -> LogLevel -> msg -> IO ()) +stickyLoggerFuncImpl (Sticky mref) maxLogLevel supportsUnicode loc src level msg = case mref of Nothing -> loggerFunc + maxLogLevel out loc src @@ -232,22 +252,15 @@ stickyLoggerFunc loc src level msg = do _ -> level) msg Just ref -> do - sticky <- liftIO (takeMVar ref) - let backSpaceChar = - '\8' - repeating = - S8.replicate - (maybe 0 T.length sticky) - clear = - liftIO - (S8.hPutStr out - (repeating backSpaceChar <> - repeating ' ' <> - repeating backSpaceChar)) - maxLogLevel <- asks getLogLevel + sticky <- takeMVar ref + let backSpaceChar = '\8' + repeating = S8.replicate (maybe 0 T.length sticky) + clear = S8.hPutStr out + (repeating backSpaceChar <> + repeating ' ' <> + repeating backSpaceChar) -- Convert some GHC-generated Unicode characters as necessary - supportsUnicode <- asks getSupportsUnicode let msgText | supportsUnicode = msgTextRaw | otherwise = T.map replaceUnicode msgTextRaw @@ -256,25 +269,27 @@ stickyLoggerFunc loc src level msg = do case level of LevelOther "sticky-done" -> do clear - liftIO (T.hPutStrLn out msgText >> hFlush out) + T.hPutStrLn out msgText + hFlush out return Nothing LevelOther "sticky" -> do clear - liftIO (T.hPutStr out msgText >> hFlush out) + T.hPutStr out msgText + hFlush out return (Just msgText) _ | level >= maxLogLevel -> do clear - loggerFunc out loc src level $ toLogStr msgText + loggerFunc maxLogLevel out loc src level $ toLogStr msgText case sticky of Nothing -> return Nothing Just line -> do - liftIO (T.hPutStr out line >> hFlush out) + T.hPutStr out line >> hFlush out return sticky | otherwise -> return sticky - liftIO (putMVar ref newState) + putMVar ref newState where out = stderr msgTextRaw = T.decodeUtf8With T.lenientDecode msgBytes @@ -287,14 +302,13 @@ replaceUnicode '\x2019' = '\'' replaceUnicode c = c -- | Logging function takes the log level into account. -loggerFunc :: (MonadIO m,ToLogStr msg,MonadReader r m,HasLogLevel r) - => Handle -> Loc -> Text -> LogLevel -> msg -> m () -loggerFunc outputChannel loc _src level msg = - do maxLogLevel <- asks getLogLevel - when (level >= maxLogLevel) - (liftIO (do out <- getOutput maxLogLevel - T.hPutStrLn outputChannel out)) - where getOutput maxLogLevel = +loggerFunc :: ToLogStr msg + => LogLevel -> Handle -> Loc -> Text -> LogLevel -> msg -> IO () +loggerFunc maxLogLevel outputChannel loc _src level msg = + when (level >= maxLogLevel) + (liftIO (do out <- getOutput + T.hPutStrLn outputChannel out)) + where getOutput = do timestamp <- getTimestamp l <- getLevel lc <- getLoc diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs index 50f0f10bea..753765ef40 100644 --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -35,7 +35,6 @@ import Control.DeepSeq import Control.Monad.Catch import Data.Aeson.Extended import Data.Attoparsec.Text -import Data.Binary.VersionTagged (Binary, HasStructuralInfo) import Data.Data import Data.Hashable import Data.List @@ -45,10 +44,9 @@ import Data.Maybe (listToMaybe) import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set +import Data.Store (Store) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Binary () -import Data.Vector.Binary () import Data.Vector.Unboxed (Vector) import qualified Data.Vector.Unboxed as V import Data.Word @@ -71,8 +69,7 @@ instance Show VersionParseFail where -- | A package version. newtype Version = Version {unVersion :: Vector Word} - deriving (Eq,Ord,Typeable,Data,Generic,Binary,NFData) -instance HasStructuralInfo Version + deriving (Eq,Ord,Typeable,Data,Generic,Store,NFData) instance Hashable Version where hashWithSalt i = hashWithSalt i . V.toList . unVersion diff --git a/src/test/Stack/StoreSpec.hs b/src/test/Stack/StoreSpec.hs new file mode 100644 index 0000000000..facbe160b1 --- /dev/null +++ b/src/test/Stack/StoreSpec.hs @@ -0,0 +1,85 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +module Stack.StoreSpec where + +import qualified Data.ByteString as BS +import Data.Containers (mapFromList, setFromList) +import Data.Int +import Data.Map (Map) +import Data.Sequences (fromList) +import Data.Set (Set) +import Data.Store.TH +import Data.Text (Text) +import qualified Data.Vector.Unboxed as UV +import Data.Word +import Language.Haskell.TH +import Language.Haskell.TH.ReifyMany +import Stack.PackageDump +import Stack.Types +import Test.Hspec +import Test.SmallCheck.Series +import Stack.Build.Cache (BuildCache(..)) + +-- NOTE: these were copied from Data.Store. Should probably be moved to +-- smallcheck. + +instance (Monad m, Serial m k, Serial m a, Ord k) => Serial m (Map k a) where + series = fmap mapFromList series + +instance Monad m => Serial m Text where + series = fmap fromList series + +instance (Monad m, Serial m a, UV.Unbox a) => Serial m (UV.Vector a) where + series = fmap fromList series + +instance Monad m => Serial m BS.ByteString where + series = fmap BS.pack series + +instance (Monad m, Serial m a, Ord a) => Serial m (Set a) where + series = fmap setFromList series + +addMinAndMaxBounds :: forall a. (Bounded a, Eq a, Num a) => [a] -> [a] +addMinAndMaxBounds xs = + (if (minBound :: a) `notElem` xs then [minBound] else []) ++ + (if (maxBound :: a) `notElem` xs && (maxBound :: a) /= minBound then maxBound : xs else xs) + +$(do let ns = [ ''Int64, ''Word64, ''Word, ''Word8 + ] + f n = [d| instance Monad m => Serial m $(conT n) where + series = generate (\_ -> addMinAndMaxBounds [0, 1]) |] + concat <$> mapM f ns) + +$(do let tys = [ ''InstalledCacheInner + , ''PackageCacheMap + , ''MiniBuildPlan + , ''BuildCache + , ''ConfigCache + ] + ns <- reifyManyWithoutInstances ''Serial tys (`notElem` [''UV.Vector]) + let f n = [d| instance Monad m => Serial m $(conT n) |] + concat <$> mapM f ns) + +verbose :: Bool +verbose = False + +spec :: Spec +spec = do + describe "Roundtrips binary formats" $ do + $(smallcheckManyStore False 6 + [ [t| InstalledCacheInner |] + , [t| PackageCacheMap |] + , [t| BuildCache |] + ]) + -- Blows up with > 5 + $(smallcheckManyStore False 5 + [ [t| MiniBuildPlan |] + ]) + -- Blows up with > 4 + $(smallcheckManyStore False 4 + [ [t| ConfigCache |] + ]) diff --git a/stack-7.8.yaml b/stack-7.8.yaml index 06a0aa586f..782efe87c3 100644 --- a/stack-7.8.yaml +++ b/stack-7.8.yaml @@ -6,6 +6,10 @@ extra-deps: - hpack-0.14.0 - QuickCheck-2.8.2 - nats-1 +- th-reify-many-0.1.6 +- th-utilities-0.1.0.1 +- store-0.1.0.0 +- th-orphans-0.13.1 flags: QuickCheck: base4point8: false diff --git a/stack-8.0.yaml b/stack-8.0.yaml index 5339077127..f10f14117a 100644 --- a/stack-8.0.yaml +++ b/stack-8.0.yaml @@ -18,7 +18,6 @@ extra-deps: - persistent-2.5 - monad-unlift-0.1.2.0 - aeson-0.11.2.0 - - Cabal-1.24.0.0 - array-0.5.1.1 - binary-0.8.3.0 @@ -38,6 +37,10 @@ extra-deps: - transformers-0.5.2.0 - transformers-compat-0.5.1.4 - unix-2.7.2.0 +- th-reify-many-0.1.6 +- th-utilities-0.1.0.1 +- store-0.1.0.0 +- th-orphans-0.13.1 packages: - . - location: diff --git a/stack.cabal b/stack.cabal index e4e54faf74..32fd507de7 100644 --- a/stack.cabal +++ b/stack.cabal @@ -51,16 +51,16 @@ flag static library hs-source-dirs: src/ - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-identities exposed-modules: Control.Concurrent.Execute Data.Aeson.Extended Data.Attoparsec.Args Data.Attoparsec.Combinators Data.Attoparsec.Interpreter - Data.Binary.VersionTagged Data.IORef.RunOnce Data.Maybe.Extra Data.Monoid.Extra + Data.Store.VersionTagged Distribution.Version.Extra Network.HTTP.Download Network.HTTP.Download.Verified @@ -219,6 +219,7 @@ library , project-template >= 0.2 , zip-archive , hpack >= 0.14.0 && < 0.15 + , store if os(windows) cpp-options: -DWINDOWS build-depends: Win32 @@ -276,6 +277,7 @@ test-suite stack-test , Stack.PackageDumpSpec , Stack.ArgsSpec , Stack.NixSpec + , Stack.StoreSpec , Network.HTTP.Download.VerifiedSpec ghc-options: -threaded -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates build-depends: Cabal >= 1.18.1.5 && < 1.25 @@ -299,6 +301,13 @@ test-suite stack-test , temporary , text , transformers + , mono-traversable + , th-reify-many + , smallcheck + , bytestring + , store + , vector + , template-haskell default-language: Haskell2010 test-suite stack-integration-test diff --git a/stack.yaml b/stack.yaml index f7f6974f9e..9667939dce 100644 --- a/stack.yaml +++ b/stack.yaml @@ -16,3 +16,7 @@ extra-deps: - path-io-1.1.0 - th-lift-instances-0.1.6 - aeson-0.11.2.0 +- th-reify-many-0.1.6 +- th-utilities-0.1.0.1 +- store-0.1.0.0 +- th-orphans-0.13.1