From 8bcb154de9b84dd22a867c3c3f66c42993a98d4b Mon Sep 17 00:00:00 2001 From: Hussein Ait-Lahcen Date: Sat, 26 Jan 2019 13:33:24 +0100 Subject: [PATCH 01/65] refact(build): introduce binary and avoid dumping plain text hi files --- package.yaml | 1 + src/Stack/Build/Execute.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 2d26fa2771..85b2d57119 100644 --- a/package.yaml +++ b/package.yaml @@ -123,6 +123,7 @@ dependencies: - yaml - zip-archive - zlib +- binary when: - condition: os(windows) then: diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 6db13a1c6d..945491203b 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -1974,7 +1974,7 @@ extraBuildOptions :: (HasEnvConfig env, HasRunner env) => WhichCompiler -> BuildOpts -> RIO env [String] extraBuildOptions wc bopts = do colorOpt <- appropriateGhcColorFlag - let ddumpOpts = " -ddump-hi -ddump-to-file" + let ddumpOpts = " -keep-hi-files" optsFlag = compilerOptionsCabalFlag wc baseOpts = ddumpOpts ++ maybe "" (" " ++) colorOpt if toCoverage (boptsTestOpts bopts) From 7fd53710b2f494e7dcf79b3505feaae2e31ee849 Mon Sep 17 00:00:00 2001 From: Hussein Ait-Lahcen Date: Sat, 26 Jan 2019 15:57:46 +0100 Subject: [PATCH 02/65] add(build): binary deserialization of module interface --- src/Stack/ModuleInterface.hs | 423 +++++++++++++++++++++++++++++++++++ 1 file changed, 423 insertions(+) create mode 100644 src/Stack/ModuleInterface.hs diff --git a/src/Stack/ModuleInterface.hs b/src/Stack/ModuleInterface.hs new file mode 100644 index 0000000000..1c346b8af6 --- /dev/null +++ b/src/Stack/ModuleInterface.hs @@ -0,0 +1,423 @@ +module Stack.ModuleInterface + ( Interface(..) + , FastString(..) + , List(..) + , Dictionary(..) + , Module(..) + , Usage(..) + , Dependencies(..) + , getInterface + ) where + +import Control.Monad (replicateM, replicateM_, when) +import Data.Binary +import Data.Binary.Get (bytesRead, getInt64be, getWord32be, + getWord64be, getWord8, lookAhead, skip) +import Data.Bool (bool) +import Data.Char (chr) +import Data.Functor (void, ($>)) +import Data.List (find) +import Data.Maybe (catMaybes) +import Data.Semigroup ((<>)) +import qualified Data.Vector as V +import Foreign (sizeOf) +import Numeric (showHex) + +type IsBoot = Bool + +type ModuleName = FastString + +newtype List a = List + { unList :: [a] + } deriving (Show) + +newtype FastString = FastString + { unFastString :: String + } deriving (Show) + +newtype Dictionary = Dictionary + { unDictionary :: V.Vector FastString + } deriving (Show) + +newtype Module = Module + { unModule :: ModuleName + } deriving (Show) + +newtype Usage = Usage + { unUsage :: FilePath + } deriving (Show) + +data Dependencies = Dependencies + { dmods :: List (ModuleName, IsBoot) + , dpkgs :: List (ModuleName, Bool) + , dorphs :: List Module + , dfinsts :: List Module + , dplugins :: List ModuleName + } deriving (Show) + +data Interface = Interface + { deps :: Dependencies + , usage :: List Usage + } deriving (Show) + +-- | Read a block prefixed with its length +withBlockPrefix :: Get a -> Get a +withBlockPrefix f = getWord32be *> f + +getBool :: Get Bool +getBool = toEnum . fromIntegral <$> getWord8 + +getString :: Get String +getString = fmap (chr . fromIntegral) . unList <$> getList getWord32be + +getMaybe :: Get a -> Get (Maybe a) +getMaybe f = bool (pure Nothing) (Just <$> f) =<< getBool + +getList :: Get a -> Get (List a) +getList f = do + i <- getWord8 + l <- + if i == 0xff + then getWord32be + else pure (fromIntegral i :: Word32) + List <$> replicateM (fromIntegral l) f + +getTuple :: Get a -> Get b -> Get (a, b) +getTuple f g = (,) <$> f <*> g + +getFastString :: Get FastString +getFastString = do + size <- getInt64be + FastString . fmap (chr . fromIntegral) <$> + replicateM (fromIntegral size) getWord8 + +getDictionary :: Int -> Get Dictionary +getDictionary ptr = do + offset <- bytesRead + skip $ ptr - fromIntegral offset + size <- fromIntegral <$> getInt64be + Dictionary <$> V.replicateM size getFastString + +getCachedFS :: Dictionary -> Get FastString +getCachedFS d = go =<< getWord32be + where + go i = + case unDictionary d V.!? fromIntegral i of + Just fs -> pure fs + Nothing -> fail $ "Invalid dictionary index: " <> show i + +getFP :: Get () +getFP = void $ getWord64be *> getWord64be + +getInterface721 :: Dictionary -> Get Interface +getInterface721 d = do + void getModule + void getBool + replicateM_ 2 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedFS d *> (Module <$> getCachedFS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> + getList (getTuple (getCachedFS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedFS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getBool $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface741 :: Dictionary -> Get Interface +getInterface741 d = do + void getModule + void getBool + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedFS d *> (Module <$> getCachedFS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> + getList (getTuple (getCachedFS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedFS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getWord64be <* getWord64be + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface761 :: Dictionary -> Get Interface +getInterface761 d = do + void getModule + void getBool + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedFS d *> (Module <$> getCachedFS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> + getList (getTuple (getCachedFS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedFS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getWord64be <* getWord64be + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface781 :: Dictionary -> Get Interface +getInterface781 d = do + void getModule + void getBool + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedFS d *> (Module <$> getCachedFS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> + getList (getTuple (getCachedFS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedFS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface801 :: Dictionary -> Get Interface +getInterface801 d = do + void getModule + void getWord8 + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = getCachedFS d *> (Module <$> getCachedFS d) + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> + getList (getTuple (getCachedFS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedFS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + 3 -> getModule *> getFP $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface821 :: Dictionary -> Get Interface +getInterface821 d = do + void getModule + void $ getMaybe getModule + void getWord8 + replicateM_ 3 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = do + idType <- getWord8 + case idType of + 0 -> void $ getCachedFS d + _ -> + void $ + getCachedFS d *> getList (getTuple (getCachedFS d) getModule) + Module <$> getCachedFS d + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> + getList (getTuple (getCachedFS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedFS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + 3 -> getModule *> getFP $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface841 :: Dictionary -> Get Interface +getInterface841 d = do + void getModule + void $ getMaybe getModule + void getWord8 + replicateM_ 5 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = do + idType <- getWord8 + case idType of + 0 -> void $ getCachedFS d + _ -> + void $ + getCachedFS d *> getList (getTuple (getCachedFS d) getModule) + Module <$> getCachedFS d + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> + getList (getTuple (getCachedFS d) getBool) <*> + getList getModule <*> + getList getModule <*> + pure (List []) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedFS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + 3 -> getModule *> getFP $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface861 :: Dictionary -> Get Interface +getInterface861 d = do + void getModule + void $ getMaybe getModule + void getWord8 + replicateM_ 6 getFP + void getBool + void getBool + Interface <$> getDependencies <*> getUsage + where + getModule = do + idType <- getWord8 + case idType of + 0 -> void $ getCachedFS d + _ -> + void $ + getCachedFS d *> getList (getTuple (getCachedFS d) getModule) + Module <$> getCachedFS d + getDependencies = + withBlockPrefix $ + Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> + getList (getTuple (getCachedFS d) getBool) <*> + getList getModule <*> + getList getModule <*> + getList (getCachedFS d) + getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go + where + go :: Get (Maybe Usage) + go = do + usageType <- getWord8 + case usageType of + 0 -> getModule *> getFP *> getBool $> Nothing + 1 -> + getCachedFS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getBool $> Nothing + 2 -> Just . Usage <$> getString <* getFP + 3 -> getModule *> getFP $> Nothing + _ -> fail $ "Invalid usageType: " <> show usageType + +getInterface :: Get Interface +getInterface = do + magic <- getWord32be + when (magic /= 0x1face64) (fail $ "Invalid magic: " <> showHex magic "") + {- + dummy value depending on the wORD_SIZE + wORD_SIZE :: Int + wORD_SIZE = (#const SIZEOF_HSINT) + + This was used to serialize pointers + -} + if sizeOf (undefined :: Int) == 4 + then void getWord32be + else void getWord64be + -- ghc version + version <- getString + -- way + void getString + -- dict_ptr + dictPtr <- getWord32be + -- dict + dict <- lookAhead $ getDictionary $ fromIntegral dictPtr + -- symtable_ptr + void getWord32be + let versions = + [ ("8061", getInterface861) + , ("8041", getInterface841) + , ("8021", getInterface821) + , ("8001", getInterface801) + , ("7081", getInterface781) + , ("7061", getInterface761) + , ("7041", getInterface741) + , ("7021", getInterface721) + ] + case snd <$> find ((version >=) . fst) versions of + Just f -> f dict + Nothing -> fail $ "Unsupported version: " <> version From b27698c62fc463fae0a731e8e87c619382447c63 Mon Sep 17 00:00:00 2001 From: Hussein Ait-Lahcen Date: Sat, 26 Jan 2019 15:58:16 +0100 Subject: [PATCH 03/65] refact(build): read binary interface instead of dumped plain text --- src/Stack/ModuleInterface.hs | 24 +++++----- src/Stack/Package.hs | 93 ++++++++++++++---------------------- 2 files changed, 50 insertions(+), 67 deletions(-) diff --git a/src/Stack/ModuleInterface.hs b/src/Stack/ModuleInterface.hs index 1c346b8af6..3a9bfc7311 100644 --- a/src/Stack/ModuleInterface.hs +++ b/src/Stack/ModuleInterface.hs @@ -9,6 +9,8 @@ module Stack.ModuleInterface , getInterface ) where +{- HLINT ignore "Reduce duplication" -} + import Control.Monad (replicateM, replicateM_, when) import Data.Binary import Data.Binary.Get (bytesRead, getInt64be, getWord32be, @@ -388,25 +390,25 @@ getInterface :: Get Interface getInterface = do magic <- getWord32be when (magic /= 0x1face64) (fail $ "Invalid magic: " <> showHex magic "") - {- - dummy value depending on the wORD_SIZE - wORD_SIZE :: Int - wORD_SIZE = (#const SIZEOF_HSINT) + {- + dummy value depending on the wORD_SIZE + wORD_SIZE :: Int + wORD_SIZE = (#const SIZEOF_HSINT) - This was used to serialize pointers - -} + This was used to serialize pointers + -} if sizeOf (undefined :: Int) == 4 then void getWord32be else void getWord64be - -- ghc version + -- ghc version version <- getString - -- way + -- way void getString - -- dict_ptr + -- dict_ptr dictPtr <- getWord32be - -- dict + -- dict dict <- lookAhead $ getDictionary $ fromIntegral dictPtr - -- symtable_ptr + -- symtable_ptr void getWord32be let versions = [ ("8061", getInterface861) diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 39378cea28..969aebfe86 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -26,14 +26,13 @@ module Stack.Package ,packageDependencies ) where +import Data.Binary.Get (runGetOrFail) import qualified Data.ByteString.Lazy.Char8 as CL8 -import Data.List (isPrefixOf, unzip) -import Data.Maybe (maybe) +import Data.List (isPrefixOf, unzip, find) +import Data.Maybe (maybe, fromMaybe) import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TLE import Distribution.Compiler import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as Cabal @@ -59,6 +58,7 @@ import Path.IO hiding (findFiles) import Stack.Build.Installed import Stack.Constants import Stack.Constants.Config +import Stack.ModuleInterface import Stack.Prelude hiding (Display (..)) import Stack.Types.BuildPlan (ExeName (..)) import Stack.Types.Compiler @@ -1018,7 +1018,7 @@ resolveFilesAndDeps component dirs names0 = do let foundFiles = mapMaybe snd resolved foundModules = mapMaybe toResolvedModule resolved missingModules = mapMaybe toMissingModule resolved - pairs <- mapM (getDependencies component) foundFiles + pairs <- mapM (getDependencies component dirs) foundFiles let doneModules = S.union doneModules0 @@ -1079,8 +1079,8 @@ resolveFilesAndDeps component dirs names0 = do -- | Get the dependencies of a Haskell module file. getDependencies - :: NamedComponent -> DotCabalPath -> RIO Ctx (Set ModuleName, [Path Abs File]) -getDependencies component dotCabalPath = + :: NamedComponent -> [Path Abs Dir] -> DotCabalPath -> RIO Ctx (Set ModuleName, [Path Abs File]) +getDependencies component dirs dotCabalPath = case dotCabalPath of DotCabalModulePath resolvedFile -> readResolvedHi resolvedFile DotCabalMainPath resolvedFile -> readResolvedHi resolvedFile @@ -1090,13 +1090,15 @@ getDependencies component dotCabalPath = readResolvedHi resolvedFile = do dumpHIDir <- componentOutputDir component <$> asks ctxDistDir dir <- asks (parent . ctxFile) - case stripProperPrefix dir resolvedFile of + let sourceDir = fromMaybe dir $ find (`isProperPrefixOf` resolvedFile) dirs + stripSourceDir d = stripProperPrefix d resolvedFile + case stripSourceDir sourceDir of Nothing -> return (S.empty, []) Just fileRel -> do let dumpHIPath = FilePath.replaceExtension (toFilePath (dumpHIDir fileRel)) - ".dump-hi" + ".hi" dumpHIExists <- liftIO $ D.doesFileExist dumpHIPath if dumpHIExists then parseDumpHI dumpHIPath @@ -1106,54 +1108,33 @@ getDependencies component dotCabalPath = parseDumpHI :: FilePath -> RIO Ctx (Set ModuleName, [Path Abs File]) parseDumpHI dumpHIPath = do - dir <- asks (parent . ctxFile) - dumpHI <- liftIO $ filterDumpHi <$> fmap CL8.lines (CL8.readFile dumpHIPath) - let startModuleDeps = - dropWhile (not . ("module dependencies:" `CL8.isPrefixOf`)) dumpHI - moduleDeps = - S.fromList $ - mapMaybe (D.simpleParse . TL.unpack . TLE.decodeUtf8) $ - CL8.words $ - CL8.concat $ - CL8.dropWhile (/= ' ') (fromMaybe "" $ listToMaybe startModuleDeps) : - takeWhile (" " `CL8.isPrefixOf`) (drop 1 startModuleDeps) - thDeps = - -- The dependent file path is surrounded by quotes but is not escaped. - -- It can be an absolute or relative path. - TL.unpack . - -- Starting with GHC 8.4.3, there's a hash following - -- the path. See - -- https://github.com/yesodweb/yesod/issues/1551 - TLE.decodeUtf8 . - CL8.takeWhile (/= '\"') <$> - mapMaybe (CL8.stripPrefix "addDependentFile \"") dumpHI - thDepsResolved <- liftM catMaybes $ forM thDeps $ \x -> do - mresolved <- liftIO (forgivingAbsence (resolveFile dir x)) >>= rejectMissingFile - when (isNothing mresolved) $ + dir <- asks (parent . ctxFile) + content <- liftIO $ CL8.readFile dumpHIPath + case runGetOrFail getInterface content of + Left (_, _, msg) -> do + prettyWarnL + [ flow "Failed to decode module interface:" + , style File $ fromString dumpHIPath + , flow "Decoding failure:" + , style Error $ fromString msg + ] + pure (S.empty, []) + Right (_, _, iface) -> do + let + moduleNames = fmap (fromString . unFastString . fst) . unList . dmods . deps + resolveFileDependency file = do + resolved <- liftIO (forgivingAbsence (resolveFile dir file)) >>= rejectMissingFile + when (isNothing resolved) $ prettyWarnL - [ flow "addDependentFile path (Template Haskell) listed in" - , style File $ fromString dumpHIPath - , flow "does not exist:" - , style File $ fromString x - ] - return mresolved - return (moduleDeps, thDepsResolved) - where - -- | Filtering step fixing RAM usage upon a big dump-hi file. See - -- https://github.com/commercialhaskell/stack/issues/4027 It is - -- an optional step from a functionality stand-point. - filterDumpHi dumpHI = - let dl x xs = x ++ xs - isLineInteresting (acc, moduleDepsStarted) l - | moduleDepsStarted && " " `CL8.isPrefixOf` l = - (acc . dl [l], True) - | "module dependencies:" `CL8.isPrefixOf` l = - (acc . dl [l], True) - | "addDependentFile \"" `CL8.isPrefixOf` l = - (acc . dl [l], False) - | otherwise = (acc, False) - in fst (foldl' isLineInteresting (dl [], False) dumpHI) [] - + [ flow "Dependent file listed in:" + , style File $ fromString dumpHIPath + , flow "does not exist:" + , style File $ fromString file + ] + pure resolved + resolveUsages = traverse (resolveFileDependency . unUsage) . unList . usage + resolvedUsages <- catMaybes <$> resolveUsages iface + pure (S.fromList $ moduleNames iface, resolvedUsages) -- | Try to resolve the list of base names in the given directory by -- looking for unique instances of base names applied with the given From 48f39b950ca465fd8b24e9842420d979592489ca Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 9 Apr 2019 12:03:33 +0300 Subject: [PATCH 04/65] Avoid lazy I/O --- src/Stack/Package.hs | 36 ++++++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 1d50ff2d22..eaaa20c349 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -27,8 +27,8 @@ module Stack.Package ,applyForceCustomBuild ) where -import Data.Binary.Get (runGetOrFail) -import qualified Data.ByteString.Lazy.Char8 as CL8 +import qualified Data.Binary.Get as Binary +import qualified Data.ByteString.Lazy.Internal as BL (defaultChunkSize) import Data.List (isPrefixOf, unzip, find) import Data.Maybe (maybe, fromMaybe) import qualified Data.Map.Strict as M @@ -71,6 +71,7 @@ import qualified System.Directory as D import System.FilePath (replaceExtension) import qualified System.FilePath as FilePath import System.IO.Error +import qualified RIO.ByteString as B import RIO.Process import RIO.PrettyPrint import qualified RIO.PrettyPrint as PP (Style (Module)) @@ -1092,31 +1093,38 @@ getDependencies component dirs dotCabalPath = case stripSourceDir sourceDir of Nothing -> return (S.empty, []) Just fileRel -> do - let dumpHIPath = + let hiPath = FilePath.replaceExtension (toFilePath (dumpHIDir fileRel)) ".hi" - dumpHIExists <- liftIO $ D.doesFileExist dumpHIPath + dumpHIExists <- liftIO $ D.doesFileExist hiPath if dumpHIExists - then parseDumpHI dumpHIPath + then parseHI hiPath else return (S.empty, []) --- | Parse a .dump-hi file into a set of modules and files. -parseDumpHI +-- | Parse a .hi file into a set of modules and files. +parseHI :: FilePath -> RIO Ctx (Set ModuleName, [Path Abs File]) -parseDumpHI dumpHIPath = do +parseHI hiPath = do dir <- asks (parent . ctxFile) - content <- liftIO $ CL8.readFile dumpHIPath - case runGetOrFail getInterface content of - Left (_, _, msg) -> do + result <- liftIO $ withBinaryFile hiPath ReadMode $ \h -> + let feed :: Binary.Decoder Interface -> IO (Either String Interface) + feed (Binary.Done _ _ x) = pure $ Right x + feed (Binary.Fail _ _ str) = pure $ Left str + feed (Binary.Partial k) = do + chunk <- B.hGetSome h BL.defaultChunkSize + feed $ k $ if B.null chunk then Nothing else Just chunk + in feed (Binary.runGetIncremental getInterface :: Binary.Decoder Interface) + case result of + Left msg -> do prettyWarnL [ flow "Failed to decode module interface:" - , style File $ fromString dumpHIPath + , style File $ fromString hiPath , flow "Decoding failure:" , style Error $ fromString msg ] pure (S.empty, []) - Right (_, _, iface) -> do + Right iface -> do let moduleNames = fmap (fromString . unFastString . fst) . unList . dmods . deps resolveFileDependency file = do @@ -1124,7 +1132,7 @@ parseDumpHI dumpHIPath = do when (isNothing resolved) $ prettyWarnL [ flow "Dependent file listed in:" - , style File $ fromString dumpHIPath + , style File $ fromString hiPath , flow "does not exist:" , style File $ fromString file ] From 4f2273661ea108f4567acf81d2389f6181f6ee04 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 9 Apr 2019 12:21:31 +0300 Subject: [PATCH 05/65] Don't set redundant setting --- src/Stack/Build/Execute.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index d67d5e12d6..0763b050b4 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -2080,9 +2080,8 @@ extraBuildOptions :: (HasEnvConfig env, HasRunner env) => WhichCompiler -> BuildOpts -> RIO env [String] extraBuildOptions wc bopts = do colorOpt <- appropriateGhcColorFlag - let ddumpOpts = " -keep-hi-files" - optsFlag = compilerOptionsCabalFlag wc - baseOpts = ddumpOpts ++ maybe "" (" " ++) colorOpt + let optsFlag = compilerOptionsCabalFlag wc + baseOpts = maybe "" (" " ++) colorOpt if toCoverage (boptsTestOpts bopts) then do hpcIndexDir <- toFilePathNoTrailingSep <$> hpcRelativeDir From 60cc29b1c00c0d0bee13986b5e34a8c33567b38d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 9 Apr 2019 12:34:06 +0300 Subject: [PATCH 06/65] Remove FastString --- src/Stack/ModuleInterface.hs | 122 +++++++++++++++++------------------ src/Stack/Package.hs | 3 +- 2 files changed, 61 insertions(+), 64 deletions(-) diff --git a/src/Stack/ModuleInterface.hs b/src/Stack/ModuleInterface.hs index 3a9bfc7311..7c848a03d5 100644 --- a/src/Stack/ModuleInterface.hs +++ b/src/Stack/ModuleInterface.hs @@ -1,6 +1,5 @@ module Stack.ModuleInterface ( Interface(..) - , FastString(..) , List(..) , Dictionary(..) , Module(..) @@ -14,7 +13,9 @@ module Stack.ModuleInterface import Control.Monad (replicateM, replicateM_, when) import Data.Binary import Data.Binary.Get (bytesRead, getInt64be, getWord32be, - getWord64be, getWord8, lookAhead, skip) + getWord64be, getWord8, lookAhead, skip, + getByteString) +import Data.ByteString (ByteString) import Data.Bool (bool) import Data.Char (chr) import Data.Functor (void, ($>)) @@ -27,18 +28,14 @@ import Numeric (showHex) type IsBoot = Bool -type ModuleName = FastString +type ModuleName = ByteString newtype List a = List { unList :: [a] } deriving (Show) -newtype FastString = FastString - { unFastString :: String - } deriving (Show) - newtype Dictionary = Dictionary - { unDictionary :: V.Vector FastString + { unDictionary :: V.Vector ByteString } deriving (Show) newtype Module = Module @@ -87,25 +84,24 @@ getList f = do getTuple :: Get a -> Get b -> Get (a, b) getTuple f g = (,) <$> f <*> g -getFastString :: Get FastString -getFastString = do +getByteStringSized :: Get ByteString +getByteStringSized = do size <- getInt64be - FastString . fmap (chr . fromIntegral) <$> - replicateM (fromIntegral size) getWord8 + getByteString (fromIntegral size) getDictionary :: Int -> Get Dictionary getDictionary ptr = do offset <- bytesRead skip $ ptr - fromIntegral offset size <- fromIntegral <$> getInt64be - Dictionary <$> V.replicateM size getFastString + Dictionary <$> V.replicateM size getByteStringSized -getCachedFS :: Dictionary -> Get FastString -getCachedFS d = go =<< getWord32be +getCachedBS :: Dictionary -> Get ByteString +getCachedBS d = go =<< getWord32be where go i = case unDictionary d V.!? fromIntegral i of - Just fs -> pure fs + Just bs -> pure bs Nothing -> fail $ "Invalid dictionary index: " <> show i getFP :: Get () @@ -120,11 +116,11 @@ getInterface721 d = do void getBool Interface <$> getDependencies <*> getUsage where - getModule = getCachedFS d *> (Module <$> getCachedFS d) + getModule = getCachedBS d *> (Module <$> getCachedBS d) getDependencies = withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> - getList (getTuple (getCachedFS d) getBool) <*> + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> getList getModule <*> getList getModule <*> pure (List []) @@ -136,8 +132,8 @@ getInterface721 d = do case usageType of 0 -> getModule *> getFP *> getBool $> Nothing 1 -> - getCachedFS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> getBool $> Nothing _ -> fail $ "Invalid usageType: " <> show usageType @@ -150,11 +146,11 @@ getInterface741 d = do void getBool Interface <$> getDependencies <*> getUsage where - getModule = getCachedFS d *> (Module <$> getCachedFS d) + getModule = getCachedBS d *> (Module <$> getCachedBS d) getDependencies = withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> - getList (getTuple (getCachedFS d) getBool) <*> + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> getList getModule <*> getList getModule <*> pure (List []) @@ -166,8 +162,8 @@ getInterface741 d = do case usageType of 0 -> getModule *> getFP *> getBool $> Nothing 1 -> - getCachedFS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> getBool $> Nothing 2 -> Just . Usage <$> getString <* getWord64be <* getWord64be _ -> fail $ "Invalid usageType: " <> show usageType @@ -181,11 +177,11 @@ getInterface761 d = do void getBool Interface <$> getDependencies <*> getUsage where - getModule = getCachedFS d *> (Module <$> getCachedFS d) + getModule = getCachedBS d *> (Module <$> getCachedBS d) getDependencies = withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> - getList (getTuple (getCachedFS d) getBool) <*> + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> getList getModule <*> getList getModule <*> pure (List []) @@ -197,8 +193,8 @@ getInterface761 d = do case usageType of 0 -> getModule *> getFP *> getBool $> Nothing 1 -> - getCachedFS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> getBool $> Nothing 2 -> Just . Usage <$> getString <* getWord64be <* getWord64be _ -> fail $ "Invalid usageType: " <> show usageType @@ -212,11 +208,11 @@ getInterface781 d = do void getBool Interface <$> getDependencies <*> getUsage where - getModule = getCachedFS d *> (Module <$> getCachedFS d) + getModule = getCachedBS d *> (Module <$> getCachedBS d) getDependencies = withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> - getList (getTuple (getCachedFS d) getBool) <*> + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> getList getModule <*> getList getModule <*> pure (List []) @@ -228,8 +224,8 @@ getInterface781 d = do case usageType of 0 -> getModule *> getFP *> getBool $> Nothing 1 -> - getCachedFS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> getBool $> Nothing 2 -> Just . Usage <$> getString <* getFP _ -> fail $ "Invalid usageType: " <> show usageType @@ -243,11 +239,11 @@ getInterface801 d = do void getBool Interface <$> getDependencies <*> getUsage where - getModule = getCachedFS d *> (Module <$> getCachedFS d) + getModule = getCachedBS d *> (Module <$> getCachedBS d) getDependencies = withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> - getList (getTuple (getCachedFS d) getBool) <*> + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> getList getModule <*> getList getModule <*> pure (List []) @@ -259,8 +255,8 @@ getInterface801 d = do case usageType of 0 -> getModule *> getFP *> getBool $> Nothing 1 -> - getCachedFS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> getBool $> Nothing 2 -> Just . Usage <$> getString <* getFP 3 -> getModule *> getFP $> Nothing @@ -279,15 +275,15 @@ getInterface821 d = do getModule = do idType <- getWord8 case idType of - 0 -> void $ getCachedFS d + 0 -> void $ getCachedBS d _ -> void $ - getCachedFS d *> getList (getTuple (getCachedFS d) getModule) - Module <$> getCachedFS d + getCachedBS d *> getList (getTuple (getCachedBS d) getModule) + Module <$> getCachedBS d getDependencies = withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> - getList (getTuple (getCachedFS d) getBool) <*> + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> getList getModule <*> getList getModule <*> pure (List []) @@ -299,8 +295,8 @@ getInterface821 d = do case usageType of 0 -> getModule *> getFP *> getBool $> Nothing 1 -> - getCachedFS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> getBool $> Nothing 2 -> Just . Usage <$> getString <* getFP 3 -> getModule *> getFP $> Nothing @@ -319,15 +315,15 @@ getInterface841 d = do getModule = do idType <- getWord8 case idType of - 0 -> void $ getCachedFS d + 0 -> void $ getCachedBS d _ -> void $ - getCachedFS d *> getList (getTuple (getCachedFS d) getModule) - Module <$> getCachedFS d + getCachedBS d *> getList (getTuple (getCachedBS d) getModule) + Module <$> getCachedBS d getDependencies = withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> - getList (getTuple (getCachedFS d) getBool) <*> + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> getList getModule <*> getList getModule <*> pure (List []) @@ -339,8 +335,8 @@ getInterface841 d = do case usageType of 0 -> getModule *> getFP *> getBool $> Nothing 1 -> - getCachedFS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> getBool $> Nothing 2 -> Just . Usage <$> getString <* getFP 3 -> getModule *> getFP $> Nothing @@ -359,18 +355,18 @@ getInterface861 d = do getModule = do idType <- getWord8 case idType of - 0 -> void $ getCachedFS d + 0 -> void $ getCachedBS d _ -> void $ - getCachedFS d *> getList (getTuple (getCachedFS d) getModule) - Module <$> getCachedFS d + getCachedBS d *> getList (getTuple (getCachedBS d) getModule) + Module <$> getCachedBS d getDependencies = withBlockPrefix $ - Dependencies <$> getList (getTuple (getCachedFS d) getBool) <*> - getList (getTuple (getCachedFS d) getBool) <*> + Dependencies <$> getList (getTuple (getCachedBS d) getBool) <*> + getList (getTuple (getCachedBS d) getBool) <*> getList getModule <*> getList getModule <*> - getList (getCachedFS d) + getList (getCachedBS d) getUsage = withBlockPrefix $ List . catMaybes . unList <$> getList go where go :: Get (Maybe Usage) @@ -379,8 +375,8 @@ getInterface861 d = do case usageType of 0 -> getModule *> getFP *> getBool $> Nothing 1 -> - getCachedFS d *> getFP *> getMaybe getFP *> - getList (getTuple (getWord8 *> getCachedFS d) getFP) *> + getCachedBS d *> getFP *> getMaybe getFP *> + getList (getTuple (getWord8 *> getCachedBS d) getFP) *> getBool $> Nothing 2 -> Just . Usage <$> getString <* getFP 3 -> getModule *> getFP $> Nothing diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index eaaa20c349..5ca111da71 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -28,6 +28,7 @@ module Stack.Package ) where import qualified Data.Binary.Get as Binary +import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Internal as BL (defaultChunkSize) import Data.List (isPrefixOf, unzip, find) import Data.Maybe (maybe, fromMaybe) @@ -1126,7 +1127,7 @@ parseHI hiPath = do pure (S.empty, []) Right iface -> do let - moduleNames = fmap (fromString . unFastString . fst) . unList . dmods . deps + moduleNames = fmap (fromString . B8.unpack . fst) . unList . dmods . deps resolveFileDependency file = do resolved <- liftIO (forgivingAbsence (resolveFile dir file)) >>= rejectMissingFile when (isNothing resolved) $ From 2169b501f013027409e93eea824331581cde0c9e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 15 Apr 2019 16:40:10 +0300 Subject: [PATCH 07/65] Lock the dist directory (fixes #2730) --- ChangeLog.md | 5 +++++ src/Stack/Build/Execute.hs | 15 ++++++++++++++- src/Stack/Constants.hs | 5 +++++ src/Stack/Types/Build.hs | 6 ++++++ 4 files changed, 30 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 79a7aee506..770b8b7550 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -113,6 +113,11 @@ Behavior changes: means that Stack will no longer have to force reconfigures as often. See [#3554](https://github.com/commercialhaskell/stack/issues/3554). +* When building a package, Stack takes a lock on the dist directory in + use to avoid multiple runs of Stack from trampling each others' + files. See + [#2730](https://github.com/commercialhaskell/stack/issues/2730). + Other enhancements: * Defer loading up of files for local packages. This allows us to get diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 4570542049..c7596adfdb 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -84,6 +84,7 @@ import Stack.Types.Version import qualified System.Directory as D import System.Environment (getExecutablePath, lookupEnv) import System.Exit (ExitCode (..)) +import System.FileLock (withTryFileLock, SharedExclusive (Exclusive)) import qualified System.FilePath as FP import System.IO (stderr, stdout) import System.PosixCompat.Files (createLink, modificationTime, getFileStatus) @@ -995,7 +996,19 @@ withSingleContext ActionContext {..} ee@ExecuteEnv {..} task@Task {..} mdeps msu withPackage inner = case taskType of - TTLocalMutable lp -> inner (lpPackage lp) (lpCabalFile lp) (parent $ lpCabalFile lp) + TTLocalMutable lp -> do + let root = parent $ lpCabalFile lp + distDir <- distRelativeDir + let lockFile = root distDir relFileBuildLock + ensureDir $ parent lockFile + -- Make sure we're the only ones, see https://github.com/commercialhaskell/stack/issues/2730 + mres <- + withRunInIO $ \run -> + withTryFileLock (toFilePath lockFile) Exclusive $ \_lock -> + run $ inner (lpPackage lp) (lpCabalFile lp) root + case mres of + Just res -> pure res + Nothing -> throwIO $ CouldNotLockDistDir lockFile TTRemotePackage _ package pkgloc -> do suffix <- parseRelDir $ packageIdentifierString $ packageIdent package let dir = eeTempDir suffix diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs index ceec2f9186..89da9f9a2c 100644 --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -120,6 +120,7 @@ module Stack.Constants ,hadrianCmdPosix ,usrLibDirs ,testGhcEnvRelFile + ,relFileBuildLock ) where @@ -599,3 +600,7 @@ usrLibDirs = [$(mkAbsDir "/usr/lib"),$(mkAbsDir "/usr/lib64")] -- | Relative file path for a temporary GHC environment file for tests testGhcEnvRelFile :: Path Rel File testGhcEnvRelFile = $(mkRelFile "test-ghc-env") + +-- | File inside a dist directory to use for locking +relFileBuildLock :: Path Rel File +relFileBuildLock = $(mkRelFile "build-lock") diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 7a384decce..5f210bf40e 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -124,6 +124,7 @@ data StackBuildException | TestSuiteExeMissing Bool String String String | CabalCopyFailed Bool String | LocalPackagesPresent [PackageIdentifier] + | CouldNotLockDistDir !(Path Abs File) deriving Typeable data FlagSource = FSCommandLine | FSStackYaml @@ -310,6 +311,11 @@ instance Show StackBuildException where show (LocalPackagesPresent locals) = unlines $ "Local packages are not allowed when using the script command. Packages found:" : map (\ident -> "- " ++ packageIdentifierString ident) locals + show (CouldNotLockDistDir lockFile) = unlines + [ "Locking the dist directory failed, try to lock file:" + , " " ++ toFilePath lockFile + , "Maybe you're running another copy of Stack?" + ] missingExeError :: Bool -> String -> String missingExeError isSimpleBuildType msg = From 56ad46254ad3260a57c87a497504a1b2bdb0c7be Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 16 Apr 2019 10:29:12 +0300 Subject: [PATCH 08/65] Fix lock files logic description --- doc/lock_files.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/lock_files.md b/doc/lock_files.md index fc6260158b..ff559ffc88 100644 --- a/doc/lock_files.md +++ b/doc/lock_files.md @@ -211,7 +211,7 @@ If the lock file does not exist, it will be created by: If the `stack.yaml.lock` file exists, its last modification time is compared against the last modification time of the `stack.yaml` file and any local snapshot files. If any of those files is more recent -than the `stack.yaml` file, and the file hashes in the lock file +than the `stack.yaml.lock` file, and the file hashes in the lock file do not match the files on the filesystem, then the update procedure is triggered. Otherwise, the `stack.yaml.lock` file can be used as the definition of the snapshot. From 868328852cc58cd5003e4f87ad314b18ef83f1fd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 16 Apr 2019 14:19:27 +0300 Subject: [PATCH 09/65] announce takes a Utf8Builder --- src/Stack/Build/Execute.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index c7596adfdb..63f0f78029 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -925,10 +925,10 @@ packageNamePrefix ee name' = Just len -> assert (len >= length name) $ RIO.take len $ name ++ repeat ' ' in fromString paddedName <> "> " -announceTask :: HasLogFunc env => ExecuteEnv -> Task -> Text -> RIO env () +announceTask :: HasLogFunc env => ExecuteEnv -> Task -> Utf8Builder -> RIO env () announceTask ee task action = logInfo $ packageNamePrefix ee (pkgName (taskProvides task)) <> - RIO.display action + action -- | How we deal with output from GHC, either dumping to a log file or the -- console (with some prefix). @@ -963,7 +963,7 @@ withSingleContext :: forall env a. HasEnvConfig env -- argument, but we provide both to avoid recalculating `parent` of the `File`. -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()) -- Function to run Cabal with args - -> (Text -> RIO env ()) -- An 'announce' function, for different build phases + -> (Utf8Builder -> RIO env ()) -- An 'announce' function, for different build phases -> OutputType -> RIO env a) -> RIO env a @@ -1491,7 +1491,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap ("Building all executables for `" <> fromString (packageNameString (packageName package)) <> "' once. After a successful build of all of them, only specified executables will be rebuilt.")) - _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix executableBuildStatuses)) cabal cabalfp task + _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> RIO.display (annSuffix executableBuildStatuses))) cabal cabalfp task let installedMapHasThisPkg :: Bool installedMapHasThisPkg = @@ -1514,7 +1514,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap Just <$> realBuild cache package pkgDir cabal0 announce executableBuildStatuses initialBuildSteps executableBuildStatuses cabal announce = do - () <- announce ("initial-build-steps" <> annSuffix executableBuildStatuses) + announce ("initial-build-steps" <> RIO.display (annSuffix executableBuildStatuses)) cabal KeepTHLoading ["repl", "stack-initial-build-steps"] realBuild @@ -1522,7 +1522,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap -> Package -> Path Abs Dir -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()) - -> (Text -> RIO env ()) + -> (Utf8Builder -> RIO env ()) -> Map Text ExecutableBuildStatus -> RIO env Installed realBuild cache package pkgDir cabal0 announce executableBuildStatuses = do @@ -1565,7 +1565,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap line <> line <> "Missing modules in the cabal file are likely to cause undefined reference errors from the linker, along with other problems." - () <- announce ("build" <> annSuffix executableBuildStatuses) + () <- announce ("build" <> RIO.display (annSuffix executableBuildStatuses)) config <- view configL extraOpts <- extraBuildOptions wc eeBuildOpts let stripTHLoading @@ -1906,7 +1906,7 @@ singleTest topts testsToRun ac ee task installedMap = do argsDisplay = case args of [] -> "" _ -> ", args: " <> T.intercalate " " (map showProcessArgDebug args) - announce $ "test (suite: " <> testName <> argsDisplay <> ")" + announce $ "test (suite: " <> RIO.display testName <> RIO.display argsDisplay <> ")" -- Clear "Progress: ..." message before -- redirecting output. @@ -1964,7 +1964,7 @@ singleTest topts testsToRun ac ee task installedMap = do -- tidiness. when needHpc $ updateTixFile (packageName package) tixPath testName' - let announceResult result = announce $ "Test suite " <> testName <> " " <> result + let announceResult result = announce $ "Test suite " <> RIO.display testName <> " " <> result case mec of Just ExitSuccess -> do announceResult "passed" From 1f149827b50408325c2f505bf66d83c9ca4adad6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 16 Apr 2019 14:19:40 +0300 Subject: [PATCH 10/65] withLockedDir that blocks Previous implementation errored out when a lock failed. However, it appears that this is a bit of a race condition within a process: some integration tests fail because the previous unlock for the same dist dir hasn't fully synced on the system. This change makes it so that we block until the lock is available. This not only addresses that problem, but may have been better behavior in the first place. While blocking, Stack will print a message every 30 seconds indicating that the block is still in effect. --- src/Stack/Build/Execute.hs | 57 ++++++++++++++++++++++++++++++-------- 1 file changed, 45 insertions(+), 12 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 63f0f78029..49a812112f 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -84,7 +84,7 @@ import Stack.Types.Version import qualified System.Directory as D import System.Environment (getExecutablePath, lookupEnv) import System.Exit (ExitCode (..)) -import System.FileLock (withTryFileLock, SharedExclusive (Exclusive)) +import System.FileLock (withTryFileLock, SharedExclusive (Exclusive), withFileLock) import qualified System.FilePath as FP import System.IO (stderr, stdout) import System.PosixCompat.Files (createLink, modificationTime, getFileStatus) @@ -930,6 +930,48 @@ announceTask ee task action = logInfo $ packageNamePrefix ee (pkgName (taskProvides task)) <> action +-- | Ensure we're the only action using the directory. See +-- +withLockedDistDir + :: HasEnvConfig env + => (Utf8Builder -> RIO env ()) -- ^ announce + -> Path Abs Dir -- ^ root directory for package + -> RIO env a + -> RIO env a +withLockedDistDir announce root inner = do + distDir <- distRelativeDir + let lockFP = root distDir relFileBuildLock + ensureDir $ parent lockFP + + mres <- + withRunInIO $ \run -> + withTryFileLock (toFilePath lockFP) Exclusive $ \_lock -> + run inner + + case mres of + Just res -> pure res + Nothing -> do + announce $ "blocking for directory lock on " <> fromString (toFilePath lockFP) + stopYellingVar <- newTVarIO False + let yell = do + doneDelayingVar <- registerDelay 30000000 -- 30 seconds + join $ atomically $ + (do stopYelling' <- readTVar stopYellingVar + checkSTM stopYelling' + pure $ pure ()) <|> + (do doneDelaying <- readTVar doneDelayingVar + checkSTM doneDelaying + pure $ do + announce $ "still blocking for directory lock on " <> + fromString (toFilePath lockFP) <> + "; maybe another Stack process is running?" + yell) + stopYelling = atomically $ writeTVar stopYellingVar True + block = withRunInIO $ \run -> + withFileLock (toFilePath lockFP) Exclusive (\_ -> stopYelling *> run inner) + `finally` stopYelling + runConcurrently $ Concurrently yell *> Concurrently block + -- | How we deal with output from GHC, either dumping to a log file or the -- console (with some prefix). data OutputType @@ -998,17 +1040,8 @@ withSingleContext ActionContext {..} ee@ExecuteEnv {..} task@Task {..} mdeps msu case taskType of TTLocalMutable lp -> do let root = parent $ lpCabalFile lp - distDir <- distRelativeDir - let lockFile = root distDir relFileBuildLock - ensureDir $ parent lockFile - -- Make sure we're the only ones, see https://github.com/commercialhaskell/stack/issues/2730 - mres <- - withRunInIO $ \run -> - withTryFileLock (toFilePath lockFile) Exclusive $ \_lock -> - run $ inner (lpPackage lp) (lpCabalFile lp) root - case mres of - Just res -> pure res - Nothing -> throwIO $ CouldNotLockDistDir lockFile + withLockedDistDir announce root $ + inner (lpPackage lp) (lpCabalFile lp) root TTRemotePackage _ package pkgloc -> do suffix <- parseRelDir $ packageIdentifierString $ packageIdent package let dir = eeTempDir suffix From a21ce5661b7f102318c820b5b5f7c97ff9dc187f Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 16 Apr 2019 15:12:52 +0300 Subject: [PATCH 11/65] Implement stack.yaml lock files --- package.yaml | 2 + src/Stack/Config.hs | 98 ++++---- src/Stack/Lock.hs | 334 +++++++++++++++++++++++++++ src/Stack/SourceMap.hs | 2 +- src/Stack/Types/SourceMap.hs | 2 +- src/test/Stack/LockSpec.hs | 258 +++++++++++++++++++++ subs/pantry/package.yaml | 1 + subs/pantry/src/Pantry.hs | 93 +++++--- subs/pantry/src/Pantry/Internal.hs | 1 + subs/pantry/src/Pantry/Types.hs | 121 +++++++++- subs/pantry/test/Pantry/TypesSpec.hs | 104 ++++++++- 11 files changed, 930 insertions(+), 86 deletions(-) create mode 100644 src/Stack/Lock.hs create mode 100644 src/test/Stack/LockSpec.hs diff --git a/package.yaml b/package.yaml index ddf427abe0..8e7c8a419c 100644 --- a/package.yaml +++ b/package.yaml @@ -183,6 +183,7 @@ library: - Stack.IDE - Stack.Init - Stack.Ls + - Stack.Lock - Stack.New - Stack.Nix - Stack.Options.BenchParser @@ -302,6 +303,7 @@ tests: dependencies: - QuickCheck - hspec + - raw-strings-qq - stack - smallcheck flags: diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 1b69107aec..700e0b8a09 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -62,6 +62,7 @@ import Stack.Config.Docker import Stack.Config.Nix import Stack.Constants import Stack.Build.Haddock (shouldHaddockDeps) +import Stack.Lock (lockCachedWanted) import Stack.Storage (initStorage) import Stack.SourceMap import Stack.Types.Build @@ -76,6 +77,7 @@ import System.Console.ANSI (hSupportsANSIWithoutEmulation) import System.Environment import System.PosixCompat.Files (fileOwner, getFileStatus) import System.PosixCompat.User (getEffectiveUserID) +import RIO.List (unzip) import RIO.PrettyPrint (stylesUpdateL, useColorL) import RIO.Process @@ -501,12 +503,51 @@ loadBuildConfig = do { projectCompiler = mcompiler <|> projectCompiler project' , projectResolver = fromMaybe (projectResolver project') mresolver } + extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) - resolver <- completeSnapshotLocation $ projectResolver project - (snapshot, _completed) <- loadAndCompleteSnapshot resolver + wanted <- lockCachedWanted stackYamlFP (projectResolver project) $ + fillProjectWanted stackYamlFP config project - extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) + return BuildConfig + { bcConfig = config + , bcSMWanted = wanted + , bcExtraPackageDBs = extraPackageDBs + , bcStackYaml = stackYamlFP + , bcCurator = projectCurator project + } + where + getEmptyProject :: Maybe RawSnapshotLocation -> [PackageIdentifierRevision] -> RIO Config Project + getEmptyProject mresolver extraDeps = do + r <- case mresolver of + Just resolver -> do + logInfo ("Using resolver: " <> display resolver <> " specified on command line") + return resolver + Nothing -> do + r'' <- getLatestResolver + logInfo ("Using latest snapshot resolver: " <> display r'') + return r'' + return Project + { projectUserMsg = Nothing + , projectPackages = [] + , projectDependencies = map (RPLImmutable . flip RPLIHackage Nothing) extraDeps + , projectFlags = mempty + , projectResolver = r + , projectCompiler = Nothing + , projectExtraPackageDBs = [] + , projectCurator = Nothing + , projectDropPackages = mempty + } +fillProjectWanted :: + (HasProcessContext env, HasLogFunc env, HasPantryConfig env) + => Path Abs t + -> Config + -> Project + -> Map RawPackageLocationImmutable PackageLocationImmutable + -> WantedCompiler + -> Map PackageName (Bool -> RIO env DepPackage) + -> RIO env (SMWanted, [CompletedPLI]) +fillProjectWanted stackYamlFP config project locCache snapCompiler snapPackages = do let bopts = configBuild config packages0 <- for (projectPackages project) $ \fp@(RelFilePath t) -> do @@ -515,25 +556,27 @@ loadBuildConfig = do pp <- mkProjectPackage YesPrintWarnings resolved (boptsHaddock bopts) pure (cpName $ ppCommon pp, pp) - let completeLocation (RPLMutable m) = pure $ PLMutable m - completeLocation (RPLImmutable im) = PLImmutable <$> completePackageLocation im - - deps0 <- forM (projectDependencies project) $ \rpl -> do - pl <- completeLocation rpl + (deps0, mcompleted) <- fmap unzip . forM (projectDependencies project) $ \rpl -> do + (pl, mCompleted) <- case rpl of + RPLImmutable rpli -> do + compl <- maybe (completePackageLocation rpli) pure (Map.lookup rpli locCache) + pure (PLImmutable compl, Just (rpli, compl)) + RPLMutable p -> + pure (PLMutable p, Nothing) dp <- additionalDepPackage (shouldHaddockDeps bopts) pl - pure (cpName $ dpCommon dp, dp) + pure ((cpName $ dpCommon dp, dp), mCompleted) checkDuplicateNames $ map (second (PLMutable . ppResolvedDir)) packages0 ++ map (second dpLocation) deps0 let packages1 = Map.fromList packages0 - snPackages = snapshotPackages snapshot + snPackages = snapPackages `Map.difference` packages1 `Map.difference` Map.fromList deps0 `Map.withoutKeys` projectDropPackages project - snDeps <- Map.traverseWithKey (snapToDepPackage (shouldHaddockDeps bopts)) snPackages + snDeps <- for snPackages $ \getDep -> getDep (shouldHaddockDeps bopts) let deps1 = Map.fromList deps0 `Map.union` snDeps @@ -559,41 +602,14 @@ loadBuildConfig = do throwM $ InvalidGhcOptionsSpecification (Map.keys unusedPkgGhcOptions) let wanted = SMWanted - { smwCompiler = fromMaybe (snapshotCompiler snapshot) (projectCompiler project) + { smwCompiler = fromMaybe snapCompiler (projectCompiler project) , smwProject = packages , smwDeps = deps , smwSnapshotLocation = projectResolver project } - return BuildConfig - { bcConfig = config - , bcSMWanted = wanted - , bcExtraPackageDBs = extraPackageDBs - , bcStackYaml = stackYamlFP - , bcCurator = projectCurator project - } - where - getEmptyProject :: Maybe RawSnapshotLocation -> [PackageIdentifierRevision] -> RIO Config Project - getEmptyProject mresolver extraDeps = do - r <- case mresolver of - Just resolver -> do - logInfo ("Using resolver: " <> display resolver <> " specified on command line") - return resolver - Nothing -> do - r'' <- getLatestResolver - logInfo ("Using latest snapshot resolver: " <> display r'') - return r'' - return Project - { projectUserMsg = Nothing - , projectPackages = [] - , projectDependencies = map (RPLImmutable . flip RPLIHackage Nothing) extraDeps - , projectFlags = mempty - , projectResolver = r - , projectCompiler = Nothing - , projectExtraPackageDBs = [] - , projectCurator = Nothing - , projectDropPackages = mempty - } + pure (wanted, catMaybes mcompleted) + -- | Check if there are any duplicate package names and, if so, throw an -- exception. diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs new file mode 100644 index 0000000000..e37f527357 --- /dev/null +++ b/src/Stack/Lock.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Stack.Lock + ( lockCachedWanted + , LockedLocation(..) + , LockedPackage(..) + , Locked(..) + ) where + +import Data.Aeson.Extended +import qualified Data.List.NonEmpty as NE +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Yaml as Yaml +import Pantry +import Pantry.Internal (Unresolved(..)) +import qualified Pantry.SHA256 as SHA256 +import Path (addFileExtension, parent) +import Path.IO (doesFileExist, getModificationTime, resolveFile) +import qualified RIO.ByteString as B +import RIO.Process +import qualified RIO.Text as T +import RIO.Time (UTCTime) +import Stack.Prelude +import Stack.SourceMap +import Stack.Types.Config +import Stack.Types.SourceMap + +data CompletedSnapshotLocation + = CSLFilePath !(ResolvedPath File) + !SHA256 + !FileSize + | CSLCompiler !WantedCompiler + | CSLUrl !Text !BlobKey + deriving (Show, Eq) + +instance ToJSON CompletedSnapshotLocation where + toJSON (CSLFilePath fp sha size) = + object [ "file" .= resolvedRelative fp + , "sha" .= sha + , "size" .= size + ] + toJSON (CSLCompiler c) = + object ["compiler" .= toJSON c] + toJSON (CSLUrl url (BlobKey sha size)) = + object [ "url" .= url + , "sha" .= sha + , "size" .= size + ] + +instance FromJSON (WithJSONWarnings (Unresolved CompletedSnapshotLocation)) where + parseJSON v = file v <|> url v <|> compiler v + where + file = withObjectWarnings "CSLFilepath" $ \o -> do + ufp <- o ..: "file" + sha <- o ..: "sha" + size <- o ..: "size" + pure $ Unresolved $ \mdir -> + case mdir of + Nothing -> throwIO $ InvalidFilePathSnapshot ufp + Just dir -> do + absolute <- resolveFile dir (T.unpack ufp) + let fp = ResolvedPath (RelFilePath ufp) absolute + pure $ CSLFilePath fp sha size + url = withObjectWarnings "CSLUrl" $ \o -> do + url' <- o ..: "url" + sha <- o ..: "sha" + size <- o ..: "size" + pure $ Unresolved $ \_ -> pure $ CSLUrl url' (BlobKey sha size) + compiler = withObjectWarnings "CSLCompiler" $ \o -> do + c <- o ..: "compiler" + pure $ Unresolved $ \_ -> pure $ CSLCompiler c + +data LockedLocation a b = LockedLocation + { llOriginal :: a + , llCompleted :: b + } deriving (Show, Eq) + +instance (ToJSON a, ToJSON b) => ToJSON (LockedLocation a b) where + toJSON LockedLocation{..} = + object [ "original" .= llOriginal, "completed" .= llCompleted ] + +instance ( FromJSON (WithJSONWarnings (Unresolved a)) + , FromJSON (WithJSONWarnings (Unresolved b))) => + FromJSON (WithJSONWarnings (Unresolved (LockedLocation a b))) where + parseJSON = + withObjectWarnings "LockedLocation" $ \o -> do + llOriginal <- jsonSubWarnings $ o ..: "original" + llCompleted <- jsonSubWarnings $ o ..: "completed" + pure $ LockedLocation <$> llOriginal <*> llCompleted + +data LockedPackage = LockedPackage + { lpLocation :: !(LockedLocation RawPackageLocationImmutable PackageLocationImmutable) + , lpFlags :: !(Map FlagName Bool) + , lpHidden :: !Bool + , lpGhcOptions :: ![Text] + , lpFromSnapshot :: !FromSnapshot + } deriving (Show, Eq) + +instance ToJSON LockedPackage where + toJSON LockedPackage {..} = + let toBoolean FromSnapshot = True + toBoolean NotFromSnapshot = False + in object $ concat + [ ["location" .= lpLocation] + , if Map.null lpFlags then [] else ["flags" .= toCabalStringMap lpFlags] + , if lpFromSnapshot == FromSnapshot then [] else ["from-snapshot" .= toBoolean lpFromSnapshot] + , if not lpHidden then [] else ["hidden" .= lpHidden] + , if null lpGhcOptions then [] else ["ghc-options" .= lpGhcOptions] + ] + +-- Special wrapper extracting only 1 RawPackageLocationImmutable +-- serialization should not produce locations with multiple subdirs +-- so we should be OK using just a head element +newtype SingleRPLI = SingleRPLI { unSingleRPLI :: RawPackageLocationImmutable} + +instance FromJSON (WithJSONWarnings (Unresolved SingleRPLI)) where + parseJSON v = + do + WithJSONWarnings unresolvedRPLIs ws <- parseJSON v + let withWarnings x = WithJSONWarnings x ws + pure $ withWarnings $ Unresolved $ \mdir -> do + rpli <- NE.head <$> resolvePaths mdir unresolvedRPLIs + pure $ SingleRPLI rpli + +instance FromJSON (WithJSONWarnings (Unresolved LockedPackage)) where + parseJSON = withObjectWarnings "LockedPackage" $ \o -> do + let unwrap (LockedLocation single c) = LockedLocation (unSingleRPLI single) c + location <- jsonSubWarnings $ o ..: "location" + lpFlags <- fmap unCabalStringMap $ o ..:? "flags" ..!= Map.empty + lpHidden <- o ..:? "hidden" ..!= False + lpGhcOptions <- o ..:? "ghc-options" ..!= [] + let fromBoolean True = FromSnapshot + fromBoolean False = NotFromSnapshot + lpFromSnapshot <- fmap fromBoolean $ o ..:? "from-snapshot" ..!= True + pure $ (\lpLocation -> LockedPackage {..}) <$> fmap unwrap location + +data Locked = Locked + { lckStackSha :: !SHA256 + , lckStackSize :: !FileSize + , lckCompiler :: WantedCompiler + , lckSnapshots :: NE.NonEmpty (LockedLocation RawSnapshotLocation CompletedSnapshotLocation) + , lckPackages :: Map PackageName LockedPackage + } + deriving (Show, Eq) + +instance FromJSON (WithJSONWarnings (Unresolved Locked)) where + parseJSON = withObjectWarnings "Locked" $ \o -> do + stackYaml <- o ..: "stack-yaml" + lckStackSha <- stackYaml ..: "sha256" + lckStackSize <- stackYaml ..: "size" + lckCompiler <- o ..: "compiler" + snapshots <- jsonSubWarningsT $ o ..: "snapshots" + packages <- fmap unCabalStringMap $ jsonSubWarningsT $ o ..: "packages" + pure $ (\lckSnapshots lckPackages -> Locked {..}) <$> sequenceA snapshots <*> sequenceA packages + +instance ToJSON Locked where + toJSON Locked {..} = + object + [ "stack-yaml" .= object ["sha256" .= lckStackSha, "size" .= lckStackSize] + , "compiler" .= lckCompiler + , "snapshots" .= lckSnapshots + , "packages" .= toCabalStringMap lckPackages + ] + +loadYamlThrow + :: HasLogFunc env + => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a +loadYamlThrow parser path = do + val <- liftIO $ Yaml.decodeFileThrow (toFilePath path) + case Yaml.parseEither parser val of + Left err -> throwIO $ Yaml.AesonException err + Right (WithJSONWarnings res warnings) -> do + logJSONWarnings (toFilePath path) warnings + return res + +lockCachedWanted :: + (HasPantryConfig env, HasProcessContext env, HasLogFunc env) + => Path Abs File + -> RawSnapshotLocation + -> (Map RawPackageLocationImmutable PackageLocationImmutable + -> WantedCompiler + -> Map PackageName (Bool -> RIO env DepPackage) + -> RIO env ( SMWanted, [CompletedPLI])) + -> RIO env SMWanted +lockCachedWanted stackFile resolver fillWanted = do + lockFile <- liftIO $ addFileExtension "lock" stackFile + lockExists <- doesFileExist lockFile + if not lockExists + then do + (snap, slocs, completed) <- + loadAndCompleteSnapshotRaw resolver Map.empty + let compiler = snapshotCompiler snap + snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap) + (wanted, prjCompleted) <- fillWanted Map.empty compiler snPkgs + (stackSha, stackSize) <- shaSize stackFile + let pkgs = mapMaybe (uncurry $ maybeWantedLockedPackage wanted) + (completed <> prjCompleted) + snapshots <- for slocs $ \(orig, sloc) -> do + compl <- case sloc of + SLFilePath fp -> do + (sha, size) <- shaSize (resolvedAbsolute fp) + pure $ CSLFilePath fp sha size + SLCompiler c -> + pure $ CSLCompiler c + SLUrl url blobKey -> + pure $ CSLUrl url blobKey + pure $ LockedLocation orig compl + liftIO $ Yaml.encodeFile (toFilePath lockFile) $ + Locked { lckStackSha = stackSha + , lckStackSize = stackSize + , lckCompiler = smwCompiler wanted + , lckSnapshots = snapshots + , lckPackages = Map.fromList pkgs + } + pure wanted + else do + lmt <- liftIO $ getModificationTime lockFile + unresolvedLocked <- loadYamlThrow parseJSON lockFile + locked0 <- resolvePaths (Just $ parent stackFile) unresolvedLocked + let pkgLocCache = Map.fromList + [ (llOriginal ll, llCompleted ll) + | ll <- map lpLocation $ Map.elems (lckPackages locked0) ] + sha0 = lckStackSha locked0 + size0 = lckStackSize locked0 + result <- liftIO $ checkOutdated stackFile lmt size0 sha0 + let (syOutdated, sySha, sySize) = + case result of + Right () -> (False, sha0, size0) + Left (sha, sz) -> (True, sha, sz) + let lockedSnapshots = Map.fromList + [ (orig, compl) + | LockedLocation orig compl <- NE.toList (lckSnapshots locked0) + ] + layers <- readSnapshotLayers resolver + (outdated, valid) <- + fmap partitionEithers . forM (NE.toList layers) $ \(rsloc, sloc) -> liftIO $ + let outdatedLoc = Left . LockedLocation rsloc + validLoc = Right . LockedLocation rsloc + in case Map.lookup rsloc lockedSnapshots of + Nothing -> + case sloc of + SLFilePath fp -> do + (sha, size) <- shaSize $ resolvedAbsolute fp + pure $ outdatedLoc (CSLFilePath fp sha size) + SLCompiler c -> + pure $ outdatedLoc (CSLCompiler c) + SLUrl u bk -> + pure $ outdatedLoc (CSLUrl u bk) + Just loc@(CSLFilePath fp sha size) -> do + result' <- checkOutdated (resolvedAbsolute fp) lmt size sha + case result' of + Right () -> pure $ validLoc loc + Left (sha', size') -> + pure $ outdatedLoc (CSLFilePath fp sha' size') + Just immutable -> + pure $ validLoc immutable + let lockIsUpToDate = not syOutdated && null outdated + if lockIsUpToDate + then do + let compiler = lckCompiler locked0 + pkgs = flip Map.mapWithKey (lckPackages locked0) $ \nm lp haddocks -> do + run <- askRunInIO + let location = llCompleted (lpLocation lp) + common = CommonPackage + { cpName = nm + , cpGPD = run $ loadCabalFileImmutable location + , cpFlags = lpFlags lp + , cpGhcOptions = lpGhcOptions lp + , cpHaddocks = haddocks + } + pure $ DepPackage{ dpLocation = PLImmutable location + , dpCommon = common + , dpHidden = lpHidden lp + , dpFromSnapshot = lpFromSnapshot lp + } + (wanted, _prjCompleted) <- fillWanted pkgLocCache compiler pkgs + pure wanted + else do + (snap, _slocs, completed) <- + loadAndCompleteSnapshotRaw resolver pkgLocCache + let compiler = snapshotCompiler snap + snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap) + (wanted, prjCompleted) <- fillWanted pkgLocCache compiler snPkgs + let pkgs = mapMaybe (uncurry $ maybeWantedLockedPackage wanted) + (completed <> prjCompleted) + liftIO $ Yaml.encodeFile (toFilePath lockFile) $ + Locked { lckStackSha = sySha + , lckStackSize = sySize + , lckCompiler = smwCompiler wanted + , lckSnapshots = NE.fromList $ outdated ++ valid + , lckPackages = Map.fromList pkgs + } + pure wanted + where + maybeWantedLockedPackage wanted rpli pli = do + let name = pkgName (packageLocationIdent pli) + dp <- Map.lookup name (smwDeps wanted) + let common = dpCommon dp + pure ( name + , LockedPackage { lpFlags = cpFlags common + , lpFromSnapshot = dpFromSnapshot dp + , lpGhcOptions = cpGhcOptions common + , lpHidden = dpHidden dp + , lpLocation = LockedLocation rpli pli + } + ) + shaSize fp = do + bs <- B.readFile $ toFilePath fp + let size = FileSize . fromIntegral $ B.length bs + sha = SHA256.hashBytes bs + return (sha, size) + +checkOutdated :: + Path Abs File + -> UTCTime + -> FileSize + -> SHA256 + -> IO (Either (SHA256, FileSize) ()) +checkOutdated fp dt size sha = do + mt <- getModificationTime fp + if mt < dt + then pure $ Right () + else do + bs <- B.readFile $ toFilePath fp + let newSize = FileSize . fromIntegral $ B.length bs + newSha = SHA256.hashBytes bs + if newSize /= size || sha /= newSha + then pure $ Left (newSha, newSize) + else pure $ Right () diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs index f6c1c67500..e16467c59f 100644 --- a/src/Stack/SourceMap.hs +++ b/src/Stack/SourceMap.hs @@ -260,7 +260,7 @@ loadProjectSnapshotCandidate :: -> Bool -> RIO env (SnapshotCandidate env) loadProjectSnapshotCandidate loc printWarnings buildHaddocks = do - snapshot <- fmap fst . loadAndCompleteSnapshot =<< completeSnapshotLocation loc + (snapshot, _, _) <- loadAndCompleteSnapshotRaw loc Map.empty deps <- Map.traverseWithKey (snapToDepPackage False) (snapshotPackages snapshot) let wc = snapshotCompiler snapshot globals <- Map.map GlobalPackageVersion <$> globalsFromHints wc diff --git a/src/Stack/Types/SourceMap.hs b/src/Stack/Types/SourceMap.hs index 56b712ff61..4af5ed4731 100644 --- a/src/Stack/Types/SourceMap.hs +++ b/src/Stack/Types/SourceMap.hs @@ -46,7 +46,7 @@ data CommonPackage = CommonPackage data FromSnapshot = FromSnapshot | NotFromSnapshot - deriving (Show) + deriving (Show, Eq) -- | A view of a dependency package, specified in stack.yaml data DepPackage = DepPackage diff --git a/src/test/Stack/LockSpec.hs b/src/test/Stack/LockSpec.hs new file mode 100644 index 0000000000..1b35852261 --- /dev/null +++ b/src/test/Stack/LockSpec.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Stack.LockSpec where + +import Data.Aeson.Extended (WithJSONWarnings(..)) +import Data.ByteString (ByteString) +import qualified Data.Map as Map +import qualified Data.Yaml as Yaml +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Types.Version (mkVersion) +import Pantry +import qualified Pantry.SHA256 as SHA256 +import RIO +import Stack.Lock +import Stack.Types.SourceMap (FromSnapshot(..)) +import Test.Hspec +import Text.RawString.QQ + +toBlobKey :: ByteString -> Word -> BlobKey +toBlobKey string size = BlobKey (decodeSHA string) (FileSize size) + +decodeSHA :: ByteString -> SHA256 +decodeSHA string = + case SHA256.fromHexBytes string of + Right csha -> csha + Left err -> error $ "Failed decoding. Error: " <> show err + +decodeLocked :: ByteString -> IO Locked +decodeLocked bs = do + val <- Yaml.decodeThrow bs + case Yaml.parseEither Yaml.parseJSON val of + Left err -> throwIO $ Yaml.AesonException err + Right (WithJSONWarnings res warnings) -> do + unless (null warnings) $ + throwIO $ Yaml.AesonException $ "Unexpected warnings: " ++ show warnings + -- we just assume no file references + resolvePaths Nothing res + +spec :: Spec +spec = do + it "parses lock file (empty with GHC resolver)" $ do + let lockFile :: ByteString + lockFile = + [r|#some +packages: {} +snapshots: +- completed: + compiler: ghc-8.2.2 + original: + compiler: ghc-8.2.2 +stack-yaml: + size: 90 + sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 +compiler: ghc-8.2.2 +|] + pkgImm <- lckPackages <$> decodeLocked lockFile + Map.toList pkgImm `shouldBe` [] + it "parses lock file (empty with LTS)" $ do + let lockFile :: ByteString + lockFile = + [r|#some +packages: {} +snapshots: +- completed: + sha: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a + size: 527801 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml + original: lts-11.22 +- completed: + compiler: ghc-8.2.2 + original: + compiler: ghc-8.2.2 +stack-yaml: + size: 90 + sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 +compiler: ghc-8.2.2 +|] + pkgImm <- lckPackages <$> decodeLocked lockFile + Map.toList pkgImm `shouldBe` [] + it "parses lock file (non empty)" $ do + let lockFile :: ByteString + lockFile = + [r|#some +packages: + wai: + location: + original: + subdir: wai + git: https://github.com/yesodweb/wai.git + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 + completed: + subdir: wai + cabal-file: + size: 1765 + sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 + name: wai + version: 3.2.1.2 + git: https://github.com/yesodweb/wai.git + pantry-tree: + size: 714 + sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 + warp: + location: + original: + subdir: warp + git: https://github.com/yesodweb/wai.git + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 + completed: + subdir: warp + cabal-file: + size: 10725 + sha256: cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758 + name: warp + version: 3.2.25 + git: https://github.com/yesodweb/wai.git + pantry-tree: + size: 5103 + sha256: f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 +snapshots: +- completed: + sha: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a + size: 527801 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml + original: lts-11.22 +- completed: + compiler: ghc-8.2.2 + original: + compiler: ghc-8.2.2 +stack-yaml: + size: 90 + sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 +compiler: ghc-8.2.2 +|] + pkgImm <- Map.toList . lckPackages <$> decodeLocked lockFile + let waiSubdirRepo subdir = + Repo { repoType = RepoGit + , repoUrl = "https://github.com/yesodweb/wai.git" + , repoCommit = + "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoSubdir = subdir + } + emptyRPM = RawPackageMetadata { rpmName = Nothing + , rpmVersion = Nothing + , rpmTreeKey = Nothing + , rpmCabal = Nothing + } + pkgImm `shouldBe` + [ ( "wai" + , lockedPackageWithLocations + (RPLIRepo (waiSubdirRepo "wai") emptyRPM) + (PLIRepo (waiSubdirRepo "wai") + (PackageMetadata { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "wai" + , pkgVersion = mkVersion [3, 2, 1, 2] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") + (FileSize 714)) + , pmCabal = + toBlobKey + "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" + 1765 + })) + ) + , ( "warp" + , lockedPackageWithLocations + (RPLIRepo (waiSubdirRepo "warp") emptyRPM) + (PLIRepo (waiSubdirRepo "warp") + (PackageMetadata { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "warp" + , pkgVersion = mkVersion [3, 2, 25] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a") + (FileSize 5103)) + , pmCabal = + toBlobKey + "cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758" + 10725 + })) + ) + ] + it "parses snapshot lock file (non empty)" $ do + let lockFile :: ByteString + lockFile = + [r|#some +packages: + string-quote: + location: + original: + hackage: string-quote-0.0.1 + completed: + hackage: string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3,758 + pantry-tree: + size: 273 + sha256: d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f +snapshots: +- completed: + sha: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a + size: 527801 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml + original: lts-11.22 +- completed: + compiler: ghc-8.2.2 + original: + compiler: ghc-8.2.2 +stack-yaml: + size: 90 + sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 +compiler: ghc-8.2.2 +|] + pkgImm <- Map.toList . lckPackages <$> decodeLocked lockFile + pkgImm `shouldBe` + [("string-quote" + , lockedPackageWithLocations + ( RPLIHackage + (PackageIdentifierRevision + (mkPackageName "string-quote") + (mkVersion [0, 0, 1]) + CFILatest) + Nothing) + ( PLIHackage + (PackageIdentifier + { pkgName = mkPackageName "string-quote" + , pkgVersion = mkVersion [0, 0, 1] + }) + (toBlobKey + "7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3" + 758) + (TreeKey + (BlobKey + (decodeSHA + "d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f") + (FileSize 273)))) + ) + ] + + +lockedPackageWithLocations :: RawPackageLocationImmutable -> PackageLocationImmutable -> LockedPackage +lockedPackageWithLocations rpli pli = + LockedPackage{ lpLocation = LockedLocation rpli pli + , lpFlags = mempty + , lpGhcOptions = mempty + , lpFromSnapshot = FromSnapshot + , lpHidden = False + } diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index bbbd842967..6a7f440fc2 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -118,3 +118,4 @@ tests: - exceptions - hedgehog - QuickCheck + - raw-strings-qq diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 167ba1ced5..43ead38f6e 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -92,7 +92,10 @@ module Pantry , loadRawSnapshotLayer , loadSnapshotLayer , loadSnapshot + , readSnapshotLayers , loadAndCompleteSnapshot + , loadAndCompleteSnapshotRaw + , CompletedPLI , addPackagesToSnapshot , AddPackagesConfig (..) @@ -105,6 +108,7 @@ module Pantry , parseWantedCompiler , parseRawSnapshotLocation , parsePackageIdentifierRevision + , parseHackageText -- ** Cabal values , parsePackageIdentifier @@ -199,6 +203,7 @@ import Data.Aeson.Types (parseEither) import Data.Monoid (Endo (..)) import Pantry.HTTP import Data.Char (isHexDigit) +import Data.List.NonEmpty (NonEmpty((:|)), (<|)) -- | Create a new 'PantryConfig' with the given settings. -- @@ -392,7 +397,7 @@ loadCabalFileImmutable loadCabalFileImmutable loc = withCache $ do logDebug $ "Parsing cabal file for " <> display loc bs <- loadCabalFileBytes loc - let foundCabalKey = BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) + let foundCabalKey = bsToBlobKey bs (_warnings, gpd) <- rawParseGPD (Left $ toRawPLI loc) bs let pm = case loc of @@ -438,7 +443,7 @@ loadCabalFileRawImmutable loadCabalFileRawImmutable loc = withCache $ do logDebug $ "Parsing cabal file for " <> display loc bs <- loadRawCabalFileBytes loc - let foundCabalKey = BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) + let foundCabalKey = bsToBlobKey bs (_warnings, gpd) <- rawParseGPD (Left loc) bs let rpm = case loc of @@ -791,8 +796,7 @@ completeSnapshotLocation (RSLFilePath f) = pure $ SLFilePath f completeSnapshotLocation (RSLUrl url (Just blobKey)) = pure $ SLUrl url blobKey completeSnapshotLocation (RSLUrl url Nothing) = do bs <- loadFromURL url Nothing - let blobKey = BlobKey (SHA256.hashBytes bs) (FileSize $ fromIntegral $ B.length bs) - pure $ SLUrl url blobKey + pure $ SLUrl url (bsToBlobKey bs) -- | Fill in optional fields in a 'SnapshotLayer' for more reproducible builds. -- @@ -957,6 +961,22 @@ loadSnapshot loc = do } type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) +type CompletedSL = (RawSnapshotLocation, SnapshotLocation) + +-- | Get completed locations of all snapshot layers from a 'RawSnapshotLocation' +-- +-- @since 0.1.0.0 +readSnapshotLayers :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawSnapshotLocation + -> RIO env (NonEmpty CompletedSL) +readSnapshotLayers loc = do + eres <- loadRawSnapshotLayer loc + case eres of + Left wc -> + pure $ (RSLCompiler wc, SLCompiler wc) :| [] + Right (rsl, sloc) -> + (sloc <|) <$> readSnapshotLayers (rslParent rsl) -- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting -- any incomplete package locations @@ -965,9 +985,10 @@ type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) loadAndCompleteSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation - -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshot loc = - loadAndCompleteSnapshotRaw (toRawSL loc) + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file + -> RIO env (Snapshot, NonEmpty CompletedSL, [CompletedPLI]) +loadAndCompleteSnapshot loc cachedPL = + loadAndCompleteSnapshotRaw (toRawSL loc) cachedPL -- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing -- any incomplete package locations @@ -976,8 +997,9 @@ loadAndCompleteSnapshot loc = loadAndCompleteSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation - -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshotRaw loc = do + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file + -> RIO env (Snapshot, NonEmpty CompletedSL, [CompletedPLI]) +loadAndCompleteSnapshotRaw loc cachePL = do eres <- loadRawSnapshotLayer loc case eres of Left wc -> @@ -986,12 +1008,13 @@ loadAndCompleteSnapshotRaw loc = do , snapshotPackages = mempty , snapshotDrop = mempty } - in pure (snapshot, []) - Right (rsl, _sha) -> do - (snap0, completed0) <- loadAndCompleteSnapshotRaw $ rslParent rsl + in pure (snapshot, (RSLCompiler wc, SLCompiler wc) :| [], []) + Right (rsl, sloc) -> do + (snap0, slocs0, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cachePL (packages, completed, unused) <- addAndCompletePackagesToSnapshot - (display loc) + loc + cachePL (rslLocations rsl) AddPackagesConfig { apcDrop = rslDropPackages rsl @@ -1006,7 +1029,7 @@ loadAndCompleteSnapshotRaw loc = do , snapshotPackages = packages , snapshotDrop = apcDrop unused } - return (snapshot, completed ++ completed0) + return (snapshot, sloc <| slocs0, completed ++ completed0) data SingleOrNot a = Single !a @@ -1120,6 +1143,16 @@ addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens pure (allPackages, unused) +cachedSnapshotCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Map RawPackageLocationImmutable PackageLocationImmutable + -> RawPackageLocationImmutable + -> RIO env PackageLocationImmutable +cachedSnapshotCompletePackageLocation cachePackages rpli = do + let xs = Map.lookup rpli cachePackages + case xs of + Nothing -> completePackageLocation rpli + Just x -> pure x + -- | Add more packages to a snapshot completing their locations if needed -- -- Note that any settings on a parent flag which is being replaced will be @@ -1127,31 +1160,36 @@ addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens -- set, and @foo@ also appears in new packages, then @bar@ will no longer be -- set. -- --- Returns any of the 'AddPackagesConfig' values not used. +-- Returns any of the 'AddPackagesConfig' values not used and also all +-- package location completions. -- -- @since 0.1.0.0 addAndCompletePackagesToSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Utf8Builder + => RawSnapshotLocation -- ^ Text description of where these new packages are coming from, for error -- messages only + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file -> [RawPackageLocationImmutable] -- ^ new packages -> AddPackagesConfig -> Map PackageName SnapshotPackage -- ^ packages from parent -> RIO env (Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig) -addAndCompletePackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens options) old = do - let addPackage (ps, completed) loc = do - name <- getPackageLocationName loc - loc' <- completePackageLocation loc +addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig drops flags hiddens options) old = do + let source = display loc + addPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => ([(PackageName, SnapshotPackage)],[CompletedPLI]) + -> RawPackageLocationImmutable + -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) + addPackage (ps, completed) rawLoc = do + name <- getPackageLocationName rawLoc + complLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc let p = (name, SnapshotPackage - { spLocation = loc' + { spLocation = complLoc , spFlags = Map.findWithDefault mempty name flags , spHidden = Map.findWithDefault False name hiddens , spGhcOptions = Map.findWithDefault [] name options }) - if toRawPLI loc' == loc - then pure (p:ps, completed) - else pure (p:ps, (loc, loc'):completed) + pure (p:ps, (rawLoc, complLoc):completed) (revNew, revCompleted) <- foldM addPackage ([], []) newPackages let (newSingles, newMultiples) = partitionEithers @@ -1188,20 +1226,19 @@ addAndCompletePackagesToSnapshot source newPackages (AddPackagesConfig drops fla loadRawSnapshotLayer :: (HasPantryConfig env, HasLogFunc env) => RawSnapshotLocation - -> RIO env (Either WantedCompiler (RawSnapshotLayer, SHA256)) -- FIXME remove SHA? Be smart? + -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)) loadRawSnapshotLayer (RSLCompiler compiler) = pure $ Left compiler loadRawSnapshotLayer sl@(RSLUrl url blob) = handleAny (throwIO . InvalidSnapshot sl) $ do bs <- loadFromURL url blob value <- Yaml.decodeThrow bs snapshot <- warningsParserHelperRaw sl value Nothing - pure $ Right (snapshot, SHA256.hashBytes bs) + pure $ Right (snapshot, (sl, SLUrl url (bsToBlobKey bs))) loadRawSnapshotLayer sl@(RSLFilePath fp) = handleAny (throwIO . InvalidSnapshot sl) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - sha <- SHA256.hashFile $ toFilePath $ resolvedAbsolute fp snapshot <- warningsParserHelperRaw sl value $ Just $ parent $ resolvedAbsolute fp - pure $ Right (snapshot, sha) + pure $ Right (snapshot, (sl, SLFilePath fp)) -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- diff --git a/subs/pantry/src/Pantry/Internal.hs b/subs/pantry/src/Pantry/Internal.hs index be603a94f9..1423dee364 100644 --- a/subs/pantry/src/Pantry/Internal.hs +++ b/subs/pantry/src/Pantry/Internal.hs @@ -9,6 +9,7 @@ module Pantry.Internal , pcHpackExecutable , normalizeParents , makeTarRelative + , Unresolved (..) ) where import Control.Exception (assert) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 44a6318d41..0b2148e050 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -44,7 +44,7 @@ module Pantry.Types , renderTree , parseTree , SHA256 - , Unresolved + , Unresolved (..) , resolvePaths , Package (..) , PackageCabal (..) @@ -91,6 +91,7 @@ module Pantry.Types , RawSnapshotLocation (..) , SnapshotLocation (..) , toRawSL + , parseHackageText , parseRawSnapshotLocation , RawSnapshotLayer (..) , SnapshotLayer (..) @@ -105,6 +106,7 @@ module Pantry.Types , toRawPM , cabalFileName , SnapshotCacheHash (..) + , bsToBlobKey ) where import RIO @@ -292,7 +294,7 @@ instance NFData (ResolvedPath t) data RawPackageLocation = RPLImmutable !RawPackageLocationImmutable | RPLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Generic) + deriving (Show, Eq, Ord, Generic) instance NFData RawPackageLocation -- | Location to load a package from. Can either be immutable (see @@ -303,13 +305,17 @@ instance NFData RawPackageLocation data PackageLocation = PLImmutable !PackageLocationImmutable | PLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Generic) + deriving (Show, Eq, Ord, Generic) instance NFData PackageLocation instance Display PackageLocation where display (PLImmutable loc) = display loc display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp +instance ToJSON PackageLocation where + toJSON (PLImmutable pli) = toJSON pli + toJSON (PLMutable resolved) = toJSON (resolvedRelative resolved) + -- | Convert `PackageLocation` to its "raw" equivalent -- -- @since 0.1.0.0 @@ -503,6 +509,16 @@ instance Display Repo where (if T.null subdir then mempty else " in subdirectory " <> display subdir) +instance FromJSON Repo where + parseJSON = + withObject "Repo" $ \o -> do + repoSubdir <- o .: "subdir" + repoCommit <- o .: "commit" + (repoType, repoUrl) <- + (o .: "git" >>= \url -> pure (RepoGit, url)) <|> + (o .: "hg" >>= \url -> pure (RepoHg, url)) + pure Repo {..} + -- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains -- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar". @@ -683,6 +699,32 @@ instance FromJSON PackageIdentifierRevision where Left e -> fail $ show e Right pir -> pure pir +-- | Parse a hackage text. +parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey) +parseHackageText t = maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do + let (identT, cfiT) = T.break (== '@') t + PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT + (csha, csize) <- + case splitColon cfiT of + Just ("@sha256", shaSizeT) -> do + let (shaT, sizeT) = T.break (== ',') shaSizeT + sha <- either (const Nothing) Just $ SHA256.fromHexText shaT + msize <- + case T.stripPrefix "," sizeT of + Nothing -> Nothing + Just sizeT' -> + case decimal sizeT' of + Right (size', "") -> Just $ (sha, FileSize size') + _ -> Nothing + pure msize + _ -> Nothing + pure $ (PackageIdentifier name version, BlobKey csha csize) + +splitColon :: Text -> Maybe (Text, Text) +splitColon t' = + let (x, y) = T.break (== ':') t' + in (x, ) <$> T.stripPrefix ":" y + -- | Parse a 'PackageIdentifierRevision' -- -- @since 0.1.0.0 @@ -710,10 +752,6 @@ parsePackageIdentifierRevision t = maybe (Left $ PackageIdentifierRevisionParseF Nothing -> pure CFILatest _ -> Nothing pure $ PackageIdentifierRevision name version cfi - where - splitColon t' = - let (x, y) = T.break (== ':') t' - in (x, ) <$> T.stripPrefix ":" y data Mismatch a = Mismatch { mismatchExpected :: !a @@ -1350,6 +1388,18 @@ instance Display PackageMetadata where , "cabal file == " <> display (pmCabal pm) ] +instance FromJSON PackageMetadata where + parseJSON = + withObject "PackageMetadata" $ \o -> do + pmCabal :: BlobKey <- o .: "cabal-file" + pantryTree :: BlobKey <- o .: "pantry-tree" + CabalString pkgName <- o .: "name" + CabalString pkgVersion <- o .: "version" + let pmTreeKey = TreeKey pantryTree + pmIdent = PackageIdentifier {..} + pure PackageMetadata {..} + + -- | Conver package metadata to its "raw" equivalent. -- -- @since 0.1.0.0 @@ -1462,6 +1512,54 @@ rpmToPairs (RawPackageMetadata mname mversion mtree mcabal) = concat , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal ] +instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where + parseJSON v = repoObject v <|> archiveObject v <|> hackageObject v <|> github v + <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) + where + repoObject :: Value -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable)) + repoObject value = do + pm <- parseJSON value + repo <- parseJSON value + pure $ noJSONWarnings $ pure $ PLIRepo repo pm + + archiveObject value = do + pm <- parseJSON value + withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" (\o -> do + Unresolved mkArchiveLocation <- parseArchiveLocationObject o + archiveHash <- o ..: "sha256" + archiveSize <- o ..: "size" + archiveSubdir <- o ..:? "subdir" ..!= "" + pure $ Unresolved $ \mdir -> do + archiveLocation <- mkArchiveLocation mdir + pure $ PLIArchive Archive {..} pm + ) value + + hackageObject value = + withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" (\o -> do + treeKey <- o ..: "pantry-tree" + htxt <- o ..: "hackage" + case parseHackageText htxt of + Left e -> fail $ show e + Right (pkgIdentifier, blobKey) -> + pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey)) value + + github value = do + pm <- parseJSON value + withObjectWarnings "UnresolvedPackagelocationimmutable.PLIArchive:github" (\o -> do + GitHubRepo ghRepo <- o ..: "github" + commit <- o ..: "commit" + let archiveLocation = ALUrl $ T.concat + [ "https://github.com/" + , ghRepo + , "/archive/" + , commit + , ".tar.gz" + ] + archiveHash <- o ..: "sha256" + archiveSize <- o ..: "size" + archiveSubdir <- o ..: "subdir" + pure $ pure $ PLIArchive Archive {..} pm) value + instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where parseJSON v = http v @@ -1470,7 +1568,7 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmu <|> repo v <|> archiveObject v <|> github v - <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) + <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v) where http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) http = withText "UnresolvedPackageLocationImmutable.UPLIArchive (Text)" $ \t -> @@ -2102,3 +2200,10 @@ toRawSnapshotLayer sl = RawSnapshotLayer newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256} deriving (Show) + +-- | Creates BlobKey for an input ByteString +-- +-- @sinc 0.1.0.0 +bsToBlobKey :: ByteString -> BlobKey +bsToBlobKey bs = + BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index c45898ed26..010049df5e 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -1,22 +1,43 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} -module Pantry.TypesSpec (spec) where +{-# LANGUAGE FlexibleInstances #-} -import Test.Hspec +module Pantry.TypesSpec + ( spec + ) where + +import Data.Aeson.Extended +import qualified Data.ByteString.Char8 as S8 +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty hiding (map) +import Data.Semigroup +import qualified Data.Vector as Vector +import qualified Data.Yaml as Yaml +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Types.Version (mkVersion) import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Pantry +import Pantry.Internal + ( Tree(..) + , TreeEntry(..) + , mkSafeFilePath + , parseTree + , renderTree + ) import qualified Pantry.SHA256 as SHA256 -import Pantry.Internal (parseTree, renderTree, Tree (..), TreeEntry (..), mkSafeFilePath) +import qualified Path as Path import RIO -import Distribution.Types.Version (mkVersion) +import qualified RIO.HashMap as HM import qualified RIO.Text as T -import qualified Data.Yaml as Yaml -import Data.Aeson.Extended (WithJSONWarnings (..)) -import qualified Data.ByteString.Char8 as S8 +import Test.Hspec +import Text.RawString.QQ import RIO.Time (Day (..)) hh :: HasCallStack => String -> Property -> Spec @@ -30,6 +51,22 @@ genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> (Gen.word (Range.linear 1 1 genSha256 :: Gen SHA256 genSha256 = SHA256.hashBytes <$> Gen.bytes (Range.linear 1 500) +samplePLIRepo :: ByteString +samplePLIRepo = + [r| +subdir: wai +cabal-file: + size: 1765 + sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 +name: wai +version: 3.2.1.2 +git: https://github.com/yesodweb/wai.git +pantry-tree: + size: 714 + sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 +commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 +|] + spec :: Spec spec = do describe "WantedCompiler" $ do @@ -110,3 +147,56 @@ spec = do liftIO $ Yaml.toJSON (nightlySnapshotLocation day) `shouldBe` Yaml.String (T.pack $ "nightly-" ++ show day) + it "FromJSON instance for Repo" $ do + repValue <- + case Yaml.decodeThrow samplePLIRepo of + Just x -> pure x + Nothing -> fail "Can't parse Repo" + let repoValue = + Repo + { repoSubdir = "wai" + , repoType = RepoGit + , repoCommit = + "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoUrl = "https://github.com/yesodweb/wai.git" + } + repValue `shouldBe` repoValue + it "FromJSON instance for PackageMetadata" $ do + pkgMeta <- + case Yaml.decodeThrow samplePLIRepo of + Just x -> pure x + Nothing -> fail "Can't parse Repo" + let cabalSha = + SHA256.fromHexBytes + "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" + pantrySha = + SHA256.fromHexBytes + "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2" + (csha, psha) <- case (cabalSha, pantrySha) of + (Right csha, Right psha) -> pure (csha, psha) + _ -> fail "Failed decoding sha256" + let pkgValue = + PackageMetadata + { pmIdent = + PackageIdentifier + (mkPackageName "wai") + (mkVersion [3, 2, 1, 2]) + , pmTreeKey = TreeKey (BlobKey psha (FileSize 714)) + , pmCabal = BlobKey csha (FileSize 1765) + } + pkgMeta `shouldBe` pkgValue + it "parseHackageText parses" $ do + let txt = + "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058" + hsha = + SHA256.fromHexBytes + "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" + sha <- case hsha of + Right sha' -> pure sha' + _ -> fail "parseHackagetext: failed decoding the sha256" + let Right (pkgIdentifier, blobKey) = parseHackageText txt + blobKey `shouldBe` (BlobKey sha (FileSize 5058)) + pkgIdentifier `shouldBe` + PackageIdentifier + (mkPackageName "persistent") + (mkVersion [2, 8, 2]) From d33805c6dc0ef086ea230200c811f76c02dea961 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 16 Apr 2019 15:18:59 +0300 Subject: [PATCH 12/65] Changelog entry --- ChangeLog.md | 1 + 1 file changed, 1 insertion(+) diff --git a/ChangeLog.md b/ChangeLog.md index 79a7aee506..9c61299dd5 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -60,6 +60,7 @@ Major changes: is uniquely identified by a commit id and an Hadrian "flavour" (Hadrian is the newer GHC build system), hence `compiler` can be set to use a GHC built from source with `ghc-git-COMMIT-FLAVOUR` +* Support for lock files for pinning exact project dependency versions Behavior changes: * `stack.yaml` now supports `snapshot`: a synonym for `resolver`. See [#4256](https://github.com/commercialhaskell/stack/issues/4256) From e82067e2d3a517069ec211d018913705c7060c87 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 16 Apr 2019 16:44:00 +0300 Subject: [PATCH 13/65] Add configure-options settings (fixes #1438) --- ChangeLog.md | 3 ++ doc/yaml_configuration.md | 18 ++++++++++ src/Stack/Build.hs | 6 ++-- src/Stack/Build/ConstructPlan.hs | 12 +++---- src/Stack/Build/Source.hs | 33 ++++++++++++++++--- src/Stack/BuildPlan.hs | 1 + src/Stack/Config.hs | 1 + src/Stack/Dot.hs | 9 ++--- src/Stack/Ghci.hs | 5 +++ src/Stack/Package.hs | 1 + src/Stack/SDist.hs | 1 + src/Stack/SourceMap.hs | 3 ++ src/Stack/Types/Build.hs | 1 + src/Stack/Types/Config.hs | 30 +++++++++++++++++ src/Stack/Types/Package.hs | 2 ++ src/Stack/Types/SourceMap.hs | 1 + .../tests/1438-configure-options/Main.hs | 18 ++++++++++ .../1438-configure-options/files/.gitignore | 1 + .../1438-configure-options/files/package.yaml | 5 +++ .../files/stack-everything.yaml | 8 +++++ .../files/stack-locals.yaml | 8 +++++ .../files/stack-name.yaml | 10 ++++++ .../files/stack-targets.yaml | 8 +++++ 23 files changed, 168 insertions(+), 17 deletions(-) create mode 100644 test/integration/tests/1438-configure-options/Main.hs create mode 100644 test/integration/tests/1438-configure-options/files/.gitignore create mode 100644 test/integration/tests/1438-configure-options/files/package.yaml create mode 100644 test/integration/tests/1438-configure-options/files/stack-everything.yaml create mode 100644 test/integration/tests/1438-configure-options/files/stack-locals.yaml create mode 100644 test/integration/tests/1438-configure-options/files/stack-name.yaml create mode 100644 test/integration/tests/1438-configure-options/files/stack-targets.yaml diff --git a/ChangeLog.md b/ChangeLog.md index 79a7aee506..2c67242dcf 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -60,6 +60,9 @@ Major changes: is uniquely identified by a commit id and an Hadrian "flavour" (Hadrian is the newer GHC build system), hence `compiler` can be set to use a GHC built from source with `ghc-git-COMMIT-FLAVOUR` +* `stack.yaml` now supports a `configure-options`, which are passed directly to + the `configure` step in the Cabal build process. See + [#1438](https://github.com/commercialhaskell/stack/issues/1438) Behavior changes: * `stack.yaml` now supports `snapshot`: a synonym for `resolver`. See [#4256](https://github.com/commercialhaskell/stack/issues/4256) diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index 1743e4a0a0..b7def5aa5d 100644 --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -585,6 +585,24 @@ on an options change, but this behavior can be changed back with the following: rebuild-ghc-options: true ``` +### configure-options + +Options which are passed to the configure step of the Cabal build process. +These can either be set by package name, or using the `$everything`, +`$targets`, and `$locals` special keys. These special keys have the same +meaning as in `ghc-options`. + +```yaml +configure-options: + $everything: + - --with-gcc + - /some/path + my-package: + - --another-flag +``` + +(Since 2.0) + ### ghc-variant (Since 0.1.5) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index fe52dc4b22..557baa07c7 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -244,9 +244,10 @@ loadPackage :: (HasBuildConfig env, HasSourceMap env) => PackageLocationImmutable -> Map FlagName Bool - -> [Text] + -> [Text] -- ^ GHC options + -> [Text] -- ^ Cabal configure options -> RIO env Package -loadPackage loc flags ghcOptions = do +loadPackage loc flags ghcOptions cabalConfigOpts = do compiler <- view actualCompilerVersionL platform <- view platformL let pkgConfig = PackageConfig @@ -254,6 +255,7 @@ loadPackage loc flags ghcOptions = do , packageConfigEnableBenchmarks = False , packageConfigFlags = flags , packageConfigGhcOptions = ghcOptions + , packageConfigCabalConfigOpts = cabalConfigOpts , packageConfigCompilerVersion = compiler , packageConfigPlatform = platform } diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index d2d29970d3..f184ff2908 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -118,7 +118,7 @@ type M = RWST -- TODO replace with more efficient WS stack on top of StackT data Ctx = Ctx { baseConfigOpts :: !BaseConfigOpts - , loadPackage :: !(PackageLocationImmutable -> Map FlagName Bool -> [Text] -> M Package) + , loadPackage :: !(PackageLocationImmutable -> Map FlagName Bool -> [Text] -> [Text] -> M Package) , combinedMap :: !CombinedMap , ctxEnvConfig :: !EnvConfig , callStack :: ![PackageName] @@ -171,7 +171,7 @@ instance HasEnvConfig Ctx where constructPlan :: forall env. HasEnvConfig env => BaseConfigOpts -> [DumpPackage] -- ^ locally registered - -> (PackageLocationImmutable -> Map FlagName Bool -> [Text] -> RIO EnvConfig Package) -- ^ load upstream package + -> (PackageLocationImmutable -> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package) -- ^ load upstream package -> SourceMap -> InstalledMap -> Bool @@ -231,8 +231,8 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap mkCtx econfig globalCabalVersion sources mcur pathEnvVar' = Ctx { baseConfigOpts = baseConfigOpts0 - , loadPackage = \x y z -> runRIO econfig $ - applyForceCustomBuild globalCabalVersion <$> loadPackage0 x y z + , loadPackage = \w x y z -> runRIO econfig $ + applyForceCustomBuild globalCabalVersion <$> loadPackage0 w x y z , combinedMap = combineMap sources installedMap , ctxEnvConfig = econfig , callStack = [] @@ -469,7 +469,7 @@ tellExecutablesUpstream name retrievePkgLoc loc flags = do when (name `Set.member` wanted ctx) $ do mPkgLoc <- retrievePkgLoc forM_ mPkgLoc $ \pkgLoc -> do - p <- loadPackage ctx pkgLoc flags [] + p <- loadPackage ctx pkgLoc flags [] [] tellExecutablesPackage loc p tellExecutablesPackage :: InstallLocation -> Package -> M () @@ -505,7 +505,7 @@ installPackage name ps minstalled = do case ps of PSRemote pkgLoc _version _fromSnaphot cp -> do planDebug $ "installPackage: Doing all-in-one build for upstream package " ++ show name - package <- loadPackage ctx pkgLoc (cpFlags cp) (cpGhcOptions cp) + package <- loadPackage ctx pkgLoc (cpFlags cp) (cpGhcOptions cp) (cpCabalConfigOpts cp) resolveDepsAndInstall True (cpHaddocks cp) ps package minstalled PSFilePath lp -> do case lpTestBench lp of diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 1b77fd31a2..0e69ea8a7f 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -85,6 +85,8 @@ loadSourceMap smt boptsCli sma = do flags = getLocalFlags boptsCli name ghcOptions = generalGhcOptions bconfig boptsCli isTarget isProjectPackage + cabalConfigOpts = + loadCabalConfigOpts bconfig (cpName common) isTarget isProjectPackage in common { cpFlags = if M.null flags @@ -92,6 +94,8 @@ loadSourceMap smt boptsCli sma = do else flags , cpGhcOptions = ghcOptions ++ cpGhcOptions common + , cpCabalConfigOpts = + cabalConfigOpts ++ cpCabalConfigOpts common , cpHaddocks = if isTarget then boptsHaddock bopts @@ -165,10 +169,12 @@ depPackageHashableContent DepPackage {..} = do else "-" <> fromString (C.unFlagName f) flags = map flagToBs $ Map.toList (cpFlags dpCommon) ghcOptions = map display (cpGhcOptions dpCommon) + cabalConfigOpts = map display (cpCabalConfigOpts dpCommon) haddocks = if cpHaddocks dpCommon then "haddocks" else "" hash = immutableLocSha pli return $ hash <> haddocks <> getUtf8Builder (mconcat flags) <> - getUtf8Builder (mconcat ghcOptions) + getUtf8Builder (mconcat ghcOptions) <> + getUtf8Builder (mconcat cabalConfigOpts) -- | All flags for a local package. getLocalFlags @@ -182,6 +188,21 @@ getLocalFlags boptsCli name = Map.unions where cliFlags = boptsCLIFlags boptsCli +-- | Get the options to pass to @./Setup.hs configure@ +loadCabalConfigOpts :: BuildConfig -> PackageName -> Bool -> Bool -> [Text] +loadCabalConfigOpts bconfig name isTarget isLocal = concat + [ Map.findWithDefault [] CCKEverything (configCabalConfigOpts config) + , if isLocal + then Map.findWithDefault [] CCKLocals (configCabalConfigOpts config) + else [] + , if isTarget + then Map.findWithDefault [] CCKTargets (configCabalConfigOpts config) + else [] + , Map.findWithDefault [] (CCKPackage name) (configCabalConfigOpts config) + ] + where + config = view configL bconfig + -- | Get the configured options to pass from GHC, based on the build -- configuration and commandline. generalGhcOptions :: BuildConfig -> BuildOptsCLI -> Bool -> Bool -> [Text] @@ -230,7 +251,7 @@ loadCommonPackage :: => CommonPackage -> RIO env Package loadCommonPackage common = do - config <- getPackageConfig (cpFlags common) (cpGhcOptions common) + config <- getPackageConfig (cpFlags common) (cpGhcOptions common) (cpCabalConfigOpts common) gpkg <- liftIO $ cpGPD common return $ resolvePackage config gpkg @@ -245,7 +266,7 @@ loadLocalPackage pp = do let common = ppCommon pp bopts <- view buildOptsL mcurator <- view $ buildConfigL.to bcCurator - config <- getPackageConfig (cpFlags common) (cpGhcOptions common) + config <- getPackageConfig (cpFlags common) (cpGhcOptions common) (cpCabalConfigOpts common) gpkg <- ppGPD pp let name = cpName common mtarget = M.lookup name (smtTargets $ smTargets sm) @@ -496,9 +517,10 @@ calcFci modTime' fp = liftIO $ getPackageConfig :: (HasBuildConfig env, HasSourceMap env) => Map FlagName Bool - -> [Text] + -> [Text] -- ^ GHC options + -> [Text] -- ^ cabal config opts -> RIO env PackageConfig -getPackageConfig flags ghcOptions = do +getPackageConfig flags ghcOptions cabalConfigOpts = do platform <- view platformL compilerVersion <- view actualCompilerVersionL return PackageConfig @@ -506,6 +528,7 @@ getPackageConfig flags ghcOptions = do , packageConfigEnableBenchmarks = False , packageConfigFlags = flags , packageConfigGhcOptions = ghcOptions + , packageConfigCabalConfigOpts = cabalConfigOpts , packageConfigCompilerVersion = compilerVersion , packageConfigPlatform = platform } diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 0dd5cc7d8c..3412ffeb17 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -165,6 +165,7 @@ gpdPackageDeps gpd ac platform flags = , packageConfigEnableBenchmarks = True , packageConfigFlags = flags , packageConfigGhcOptions = [] + , packageConfigCabalConfigOpts = [] , packageConfigCompilerVersion = ac , packageConfigPlatform = platform } diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 1b69107aec..ee50f77a66 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -296,6 +296,7 @@ configFromConfigMonoid let configTemplateParams = configMonoidTemplateParameters configScmInit = getFirst configMonoidScmInit + configCabalConfigOpts = coerce configMonoidCabalConfigOpts configGhcOptionsByName = coerce configMonoidGhcOptionsByName configGhcOptionsByCat = coerce configMonoidGhcOptionsByCat configSetupInfoLocations = configMonoidSetupInfoLocations diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 1234dcc9ed..0278e47daf 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -127,12 +127,12 @@ createDependencyGraph dotOpts = do let globalDumpMap = Map.fromList $ map (\dp -> (Stack.Prelude.pkgName (dpPackageIdent dp), dp)) globalDump globalIdMap = Map.fromList $ map (\dp -> (dpGhcPkgId dp, dpPackageIdent dp)) globalDump let depLoader = createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps - loadPackageDeps name version loc flags ghcOptions + loadPackageDeps name version loc flags ghcOptions cabalConfigOpts -- Skip packages that can't be loaded - see -- https://github.com/commercialhaskell/stack/issues/2967 | name `elem` [mkPackageName "rts", mkPackageName "ghc"] = return (Set.empty, DotPayload (Just version) (Just $ Right BSD3)) - | otherwise = fmap (packageAllDeps &&& makePayload) (loadPackage loc flags ghcOptions) + | otherwise = fmap (packageAllDeps &&& makePayload) (loadPackage loc flags ghcOptions cabalConfigOpts) resolveDependencies (dotDependencyDepth dotOpts) graph depLoader where makePayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) @@ -265,7 +265,7 @@ createDepLoader :: SourceMap -> Map PackageName DumpPackage -> Map GhcPkgId PackageIdentifier -> (PackageName -> Version -> PackageLocationImmutable -> - Map FlagName Bool -> [Text] -> RIO DotConfig (Set PackageName, DotPayload)) + Map FlagName Bool -> [Text] -> [Text] -> RIO DotConfig (Set PackageName, DotPayload)) -> PackageName -> RIO DotConfig (Set PackageName, DotPayload) createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps pkgName = do @@ -293,7 +293,8 @@ createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps pkgName = do let PackageIdentifier name version = PD.package $ PD.packageDescription gpd flags = cpFlags common ghcOptions = cpGhcOptions common - assert (pkgName == name) (loadPackageDeps pkgName version loc flags ghcOptions) + cabalConfigOpts = cpCabalConfigOpts common + assert (pkgName == name) (loadPackageDeps pkgName version loc flags ghcOptions cabalConfigOpts) -- If package is a global package, use info from ghc-pkg (#4324, #3084) globalDeps = diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index c2e27553a3..e7c4015f95 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -627,12 +627,17 @@ loadGhciPkgDesc buildOptsCLI name cabalfp target = do (cpGhcOptions . ppCommon <$> M.lookup name smProject) <|> (cpGhcOptions . dpCommon <$> M.lookup name smDeps) + sourceMapCabalConfigOpts = fromMaybe [] $ + (cpCabalConfigOpts . ppCommon <$> M.lookup name smProject) + <|> + (cpCabalConfigOpts . dpCommon <$> M.lookup name smDeps) config = PackageConfig { packageConfigEnableTests = True , packageConfigEnableBenchmarks = True , packageConfigFlags = getLocalFlags buildOptsCLI name , packageConfigGhcOptions = sourceMapGhcOptions + , packageConfigCabalConfigOpts = sourceMapCabalConfigOpts , packageConfigCompilerVersion = compilerVersion , packageConfigPlatform = view platformL econfig } diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 81816594f1..57474f4921 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -135,6 +135,7 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg , packageFiles = pkgFiles , packageUnknownTools = unknownTools , packageGhcOptions = packageConfigGhcOptions packageConfig + , packageCabalConfigOpts = packageConfigCabalConfigOpts packageConfig , packageFlags = packageConfigFlags packageConfig , packageDefaultFlags = M.fromList [(flagName flag, flagDefault flag) | flag <- pkgFlags] diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 03cc46fc2f..4e2a994cfe 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -511,6 +511,7 @@ getDefaultPackageConfig = do , packageConfigEnableBenchmarks = False , packageConfigFlags = mempty , packageConfigGhcOptions = [] + , packageConfigCabalConfigOpts = [] , packageConfigCompilerVersion = compilerVersion , packageConfigPlatform = platform } diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs index f6c1c67500..986525ab5e 100644 --- a/src/Stack/SourceMap.hs +++ b/src/Stack/SourceMap.hs @@ -56,6 +56,7 @@ mkProjectPackage printWarnings dir buildHaddocks = do , cpName = name , cpFlags = mempty , cpGhcOptions = mempty + , cpCabalConfigOpts = mempty , cpHaddocks = buildHaddocks } } @@ -86,6 +87,7 @@ additionalDepPackage buildHaddocks pl = do , cpName = name , cpFlags = mempty , cpGhcOptions = mempty + , cpCabalConfigOpts = mempty , cpHaddocks = buildHaddocks } } @@ -107,6 +109,7 @@ snapToDepPackage buildHaddocks name SnapshotPackage{..} = do , cpName = name , cpFlags = spFlags , cpGhcOptions = spGhcOptions + , cpCabalConfigOpts = [] -- No spCabalConfigOpts, not present in snapshots , cpHaddocks = buildHaddocks } } diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 7a384decce..48cf3028a3 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -625,6 +625,7 @@ configureOptsNoDir econfig bco deps isLocal package = concat else "-") <> flagNameString name) (Map.toList flags) + , map T.unpack $ packageCabalConfigOpts package , concatMap (\x -> [compilerOptionsCabalFlag wc, T.unpack x]) (packageGhcOptions package) , map ("--extra-include-dirs=" ++) (configExtraIncludeDirs config) , map ("--extra-lib-dirs=" ++) (configExtraLibDirs config) diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 68df7e9bdc..3cca23e03f 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -62,6 +62,8 @@ module Stack.Types.Config -- * Details -- ** ApplyGhcOptions ,ApplyGhcOptions(..) + -- ** CabalConfigKey + ,CabalConfigKey(..) -- ** ConfigException ,HpackExecutable(..) ,ConfigException(..) @@ -321,6 +323,8 @@ data Config = -- ^ Additional GHC options to apply to specific packages. ,configGhcOptionsByCat :: !(Map ApplyGhcOptions [Text]) -- ^ Additional GHC options to apply to categories of packages + ,configCabalConfigOpts :: !(Map CabalConfigKey [Text]) + -- ^ Additional options to be passed to ./Setup.hs configure ,configSetupInfoLocations :: ![SetupInfoLocation] -- ^ Additional SetupInfo (inline or remote) to use to find tools. ,configPvpBounds :: !PvpBounds @@ -372,6 +376,27 @@ configProjectRoot c = PCGlobalProject -> Nothing PCNoProject _deps -> Nothing +-- | Which packages do configure opts apply to? +data CabalConfigKey + = CCKTargets -- ^ See AGOTargets + | CCKLocals -- ^ See AGOLocals + | CCKEverything -- ^ See AGOEverything + | CCKPackage !PackageName -- ^ A specific package + deriving (Show, Read, Eq, Ord) +instance FromJSON CabalConfigKey where + parseJSON = withText "CabalConfigKey" parseCabalConfigKey +instance FromJSONKey CabalConfigKey where + fromJSONKey = FromJSONKeyTextParser parseCabalConfigKey + +parseCabalConfigKey :: Monad m => Text -> m CabalConfigKey +parseCabalConfigKey "$targets" = pure CCKTargets +parseCabalConfigKey "$locals" = pure CCKLocals +parseCabalConfigKey "$everything" = pure CCKEverything +parseCabalConfigKey name = + case parsePackageName $ T.unpack name of + Nothing -> fail $ "Invalid CabalConfigKey: " ++ show name + Just x -> pure $ CCKPackage x + -- | Which packages do ghc-options on the command line apply to? data ApplyGhcOptions = AGOTargets -- ^ all local targets | AGOLocals -- ^ all local packages, even non-targets @@ -733,6 +758,8 @@ data ConfigMonoid = -- ^ See 'configGhcOptionsAll'. Uses 'Monoid.Dual' so that options -- from the configs on the right come first, so that they can be -- overridden. + ,configMonoidCabalConfigOpts :: !(MonoidMap CabalConfigKey (Monoid.Dual [Text])) + -- ^ See 'configCabalConfigOpts'. ,configMonoidExtraPath :: ![Path Abs Dir] -- ^ Additional paths to search for executables in ,configMonoidSetupInfoLocations :: ![SetupInfoLocation] @@ -855,6 +882,9 @@ parseConfigMonoidObject rootDir obj = do configMonoidGhcOptionsByName = coerce $ Map.fromList [(name, opts) | (GOKPackage name, opts) <- Map.toList options] + configMonoidCabalConfigOpts' <- obj ..:? "configure-options" ..!= mempty + let configMonoidCabalConfigOpts = coerce (configMonoidCabalConfigOpts' :: Map CabalConfigKey [Text]) + configMonoidExtraPath <- obj ..:? configMonoidExtraPathName ..!= [] configMonoidSetupInfoLocations <- maybeToList <$> jsonSubWarningsT (obj ..:? configMonoidSetupInfoLocationsName) diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index ddea4e3080..69e23b33b3 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -102,6 +102,7 @@ data Package = ,packageUnknownTools :: !(Set ExeName) -- ^ Build tools specified in the legacy manner (build-tools:) that failed the hard-coded lookup. ,packageAllDeps :: !(Set PackageName) -- ^ Original dependencies (not sieved). ,packageGhcOptions :: ![Text] -- ^ Ghc options used on package. + ,packageCabalConfigOpts :: ![Text] -- ^ Additional options passed to ./Setup.hs configure ,packageFlags :: !(Map FlagName Bool) -- ^ Flags used on package. ,packageDefaultFlags :: !(Map FlagName Bool) -- ^ Defaults for unspecified flags. ,packageLibraries :: !PackageLibraries -- ^ does the package have a buildable library stanza? @@ -216,6 +217,7 @@ data PackageConfig = ,packageConfigEnableBenchmarks :: !Bool -- ^ Are benchmarks enabled? ,packageConfigFlags :: !(Map FlagName Bool) -- ^ Configured flags. ,packageConfigGhcOptions :: ![Text] -- ^ Configured ghc options. + ,packageConfigCabalConfigOpts :: ![Text] -- ^ ./Setup.hs configure options ,packageConfigCompilerVersion :: ActualCompiler -- ^ GHC version ,packageConfigPlatform :: !Platform -- ^ host platform } diff --git a/src/Stack/Types/SourceMap.hs b/src/Stack/Types/SourceMap.hs index 56b712ff61..bda2a8eeb8 100644 --- a/src/Stack/Types/SourceMap.hs +++ b/src/Stack/Types/SourceMap.hs @@ -38,6 +38,7 @@ data CommonPackage = CommonPackage , cpFlags :: !(Map FlagName Bool) -- ^ overrides default flags , cpGhcOptions :: ![Text] -- also lets us know if we're doing profiling + , cpCabalConfigOpts :: ![Text] , cpHaddocks :: !Bool } diff --git a/test/integration/tests/1438-configure-options/Main.hs b/test/integration/tests/1438-configure-options/Main.hs new file mode 100644 index 0000000000..77c05c8ede --- /dev/null +++ b/test/integration/tests/1438-configure-options/Main.hs @@ -0,0 +1,18 @@ +import StackTest +import Control.Monad (unless) +import Data.Foldable (for_) +import Data.List (isInfixOf) + +main :: IO () +main = do + stack ["clean", "--full"] + let stackYamlFiles = words "stack-locals.yaml stack-everything.yaml stack-targets.yaml stack-name.yaml" + for_ stackYamlFiles $ \stackYaml -> + stackErrStderr ["build", "--stack-yaml", stackYaml] $ \str -> + unless ("this is an invalid option" `isInfixOf` str) $ + error "Configure option is not present" + + stack ["build", "--stack-yaml", "stack-locals.yaml", "acme-missiles"] + stack ["build", "--stack-yaml", "stack-targets.yaml", "acme-missiles"] + stackErr ["build", "--stack-yaml", "stack-name.yaml", "acme-missiles"] + stackErr ["build", "--stack-yaml", "stack-everything.yaml", "acme-missiles"] diff --git a/test/integration/tests/1438-configure-options/files/.gitignore b/test/integration/tests/1438-configure-options/files/.gitignore new file mode 100644 index 0000000000..e9c64431ea --- /dev/null +++ b/test/integration/tests/1438-configure-options/files/.gitignore @@ -0,0 +1 @@ +name.cabal diff --git a/test/integration/tests/1438-configure-options/files/package.yaml b/test/integration/tests/1438-configure-options/files/package.yaml new file mode 100644 index 0000000000..13ccbf73ec --- /dev/null +++ b/test/integration/tests/1438-configure-options/files/package.yaml @@ -0,0 +1,5 @@ +name: name +version: 0 + +dependencies: base +library: {} diff --git a/test/integration/tests/1438-configure-options/files/stack-everything.yaml b/test/integration/tests/1438-configure-options/files/stack-everything.yaml new file mode 100644 index 0000000000..97466037f3 --- /dev/null +++ b/test/integration/tests/1438-configure-options/files/stack-everything.yaml @@ -0,0 +1,8 @@ +resolver: ghc-8.2.2 + +extra-deps: +- acme-missiles-0.3@rev:0 + +configure-options: + $everything: + - this is an invalid option diff --git a/test/integration/tests/1438-configure-options/files/stack-locals.yaml b/test/integration/tests/1438-configure-options/files/stack-locals.yaml new file mode 100644 index 0000000000..b51962c094 --- /dev/null +++ b/test/integration/tests/1438-configure-options/files/stack-locals.yaml @@ -0,0 +1,8 @@ +resolver: ghc-8.2.2 + +extra-deps: +- acme-missiles-0.3@rev:0 + +configure-options: + $locals: + - this is an invalid option diff --git a/test/integration/tests/1438-configure-options/files/stack-name.yaml b/test/integration/tests/1438-configure-options/files/stack-name.yaml new file mode 100644 index 0000000000..3f2ec3e77c --- /dev/null +++ b/test/integration/tests/1438-configure-options/files/stack-name.yaml @@ -0,0 +1,10 @@ +resolver: ghc-8.2.2 + +extra-deps: +- acme-missiles-0.3@rev:0 + +configure-options: + name: + - this is an invalid option + acme-missiles: + - this is an invalid option diff --git a/test/integration/tests/1438-configure-options/files/stack-targets.yaml b/test/integration/tests/1438-configure-options/files/stack-targets.yaml new file mode 100644 index 0000000000..5a3b3490bf --- /dev/null +++ b/test/integration/tests/1438-configure-options/files/stack-targets.yaml @@ -0,0 +1,8 @@ +resolver: ghc-8.2.2 + +extra-deps: +- acme-missiles-0.3@rev:0 + +configure-options: + $targets: + - this is an invalid option From 1dd99dab6d803e2f4ac3e94add8e9c15dfd390b4 Mon Sep 17 00:00:00 2001 From: Hussein Ait-Lahcen Date: Tue, 16 Apr 2019 17:09:06 +0200 Subject: [PATCH 14/65] refactor interface module --- src/Stack/ModuleInterface.hs | 58 ++++++---- src/Stack/Package.hs | 204 +++++++++++++++++------------------ 2 files changed, 139 insertions(+), 123 deletions(-) diff --git a/src/Stack/ModuleInterface.hs b/src/Stack/ModuleInterface.hs index 7c848a03d5..572cc88824 100644 --- a/src/Stack/ModuleInterface.hs +++ b/src/Stack/ModuleInterface.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Stack.ModuleInterface ( Interface(..) , List(..) @@ -6,25 +9,31 @@ module Stack.ModuleInterface , Usage(..) , Dependencies(..) , getInterface + , fromFile ) where {- HLINT ignore "Reduce duplication" -} -import Control.Monad (replicateM, replicateM_, when) -import Data.Binary -import Data.Binary.Get (bytesRead, getInt64be, getWord32be, - getWord64be, getWord8, lookAhead, skip, - getByteString) -import Data.ByteString (ByteString) -import Data.Bool (bool) -import Data.Char (chr) -import Data.Functor (void, ($>)) -import Data.List (find) -import Data.Maybe (catMaybes) -import Data.Semigroup ((<>)) -import qualified Data.Vector as V -import Foreign (sizeOf) -import Numeric (showHex) +import Control.Monad (replicateM, replicateM_, when) +import Data.Binary (Get, Word32) +import Data.Binary.Get (Decoder (..), bytesRead, + getByteString, getInt64be, + getWord32be, getWord64be, + getWord8, lookAhead, + runGetIncremental, skip) +import Data.Bool (bool) +import Data.ByteString.Lazy.Internal (defaultChunkSize) +import Data.Char (chr) +import Data.Functor (void, ($>)) +import Data.List (find) +import Data.Maybe (catMaybes) +import Data.Semigroup ((<>)) +import qualified Data.Vector as V +import Foreign (sizeOf) +import GHC.IO.IOMode (IOMode (..)) +import Numeric (showHex) +import RIO.ByteString as B (ByteString, hGetSome, null) +import System.IO (withBinaryFile) type IsBoot = Bool @@ -32,19 +41,19 @@ type ModuleName = ByteString newtype List a = List { unList :: [a] - } deriving (Show) + } deriving newtype (Show) newtype Dictionary = Dictionary { unDictionary :: V.Vector ByteString - } deriving (Show) + } deriving newtype (Show) newtype Module = Module { unModule :: ModuleName - } deriving (Show) + } deriving newtype (Show) newtype Usage = Usage { unUsage :: FilePath - } deriving (Show) + } deriving newtype (Show) data Dependencies = Dependencies { dmods :: List (ModuleName, IsBoot) @@ -419,3 +428,14 @@ getInterface = do case snd <$> find ((version >=) . fst) versions of Just f -> f dict Nothing -> fail $ "Unsupported version: " <> version + +fromFile :: FilePath -> IO (Either String Interface) +fromFile fp = withBinaryFile fp ReadMode go + where + go h = + let feed (Done _ _ iface) = pure $ Right iface + feed (Fail _ _ msg) = pure $ Left msg + feed (Partial k) = do + chunk <- hGetSome h defaultChunkSize + feed $ k $ if B.null chunk then Nothing else Just chunk + in feed $ runGetIncremental getInterface diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 5ca111da71..21ba75960c 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} -- | Dealing with Cabal. @@ -27,58 +27,62 @@ module Stack.Package ,applyForceCustomBuild ) where -import qualified Data.Binary.Get as Binary -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy.Internal as BL (defaultChunkSize) -import Data.List (isPrefixOf, unzip, find) -import Data.Maybe (maybe, fromMaybe) -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import qualified Data.Text as T +import qualified Data.ByteString.Char8 as B8 +import Data.List (find, isPrefixOf, + unzip) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe, maybe) +import qualified Data.Set as S +import qualified Data.Text as T import Distribution.Compiler -import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as Cabal -import qualified Distribution.Package as D -import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier) -import qualified Distribution.PackageDescription as D -import Distribution.PackageDescription hiding (FlagName) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as Cabal +import Distribution.Package hiding (Package, + PackageIdentifier, + PackageName, + packageName, + packageVersion) +import qualified Distribution.Package as D +import Distribution.PackageDescription hiding (FlagName) +import qualified Distribution.PackageDescription as D import Distribution.PackageDescription.Parsec -import Distribution.Simple.Glob (matchDirFileGlob) -import Distribution.System (OS (..), Arch, Platform (..)) -import qualified Distribution.Text as D -import qualified Distribution.Types.CondTree as Cabal -import qualified Distribution.Types.ExeDependency as Cabal +import Distribution.Simple.Glob (matchDirFileGlob) +import Distribution.System (Arch, OS (..), + Platform (..)) +import qualified Distribution.Text as D +import qualified Distribution.Types.CondTree as Cabal +import qualified Distribution.Types.ExeDependency as Cabal import Distribution.Types.ForeignLib import qualified Distribution.Types.LegacyExeDependency as Cabal import Distribution.Types.MungedPackageName import qualified Distribution.Types.UnqualComponentName as Cabal -import qualified Distribution.Verbosity as D -import Distribution.Version (mkVersion, orLaterVersion, anyVersion) -import Path as FL +import qualified Distribution.Verbosity as D +import Distribution.Version (anyVersion, mkVersion, + orLaterVersion) +import Path as FL import Path.Extra -import Path.IO hiding (findFiles) +import Path.IO hiding (findFiles) +import RIO.PrettyPrint +import qualified RIO.PrettyPrint as PP (Style (Module)) +import RIO.Process import Stack.Build.Installed import Stack.Constants import Stack.Constants.Config -import Stack.ModuleInterface -import Stack.Prelude hiding (Display (..)) +import qualified Stack.ModuleInterface as Iface +import Stack.Prelude hiding (Display (..)) import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.Version -import qualified System.Directory as D -import System.FilePath (replaceExtension) -import qualified System.FilePath as FilePath +import qualified System.Directory as D +import System.FilePath (replaceExtension) +import qualified System.FilePath as FilePath import System.IO.Error -import qualified RIO.ByteString as B -import RIO.Process -import RIO.PrettyPrint -import qualified RIO.PrettyPrint as PP (Style (Module)) -data Ctx = Ctx { ctxFile :: !(Path Abs File) - , ctxDistDir :: !(Path Abs Dir) +data Ctx = Ctx { ctxFile :: !(Path Abs File) + , ctxDistDir :: !(Path Abs Dir) , ctxBuildConfig :: !BuildConfig } @@ -149,7 +153,7 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg in case mlib of Nothing -> NoLibraries - Just _ -> HasLibraries foreignLibNames + Just _ -> HasLibraries foreignLibNames , packageInternalLibraries = subLibNames , packageTests = M.fromList [(T.pack (Cabal.unUnqualComponentName $ testName t), testInterface t) @@ -333,18 +337,18 @@ generatePkgDescOpts installMap installedMap omitPkgs addPkgs cabalfp pkg compone -- | Input to 'generateBuildInfoOpts' data BioInput = BioInput - { biInstallMap :: !InstallMap - , biInstalledMap :: !InstalledMap - , biCabalDir :: !(Path Abs Dir) - , biDistDir :: !(Path Abs Dir) - , biOmitPackages :: ![PackageName] - , biAddPackages :: ![PackageName] - , biBuildInfo :: !BuildInfo - , biDotCabalPaths :: ![DotCabalPath] - , biConfigLibDirs :: ![FilePath] + { biInstallMap :: !InstallMap + , biInstalledMap :: !InstalledMap + , biCabalDir :: !(Path Abs Dir) + , biDistDir :: !(Path Abs Dir) + , biOmitPackages :: ![PackageName] + , biAddPackages :: ![PackageName] + , biBuildInfo :: !BuildInfo + , biDotCabalPaths :: ![DotCabalPath] + , biConfigLibDirs :: ![FilePath] , biConfigIncludeDirs :: ![FilePath] - , biComponentName :: !NamedComponent - , biCabalVersion :: !Version + , biComponentName :: !NamedComponent + , biCabalVersion :: !Version } -- | Generate GHC options for the target. Since Cabal also figures out @@ -391,7 +395,7 @@ generateBuildInfoOpts BioInput {..} = ghcOpts = concatMap snd . filter (isGhc . fst) $ options biBuildInfo where isGhc GHC = True - isGhc _ = False + isGhc _ = False extOpts = map (("-X" ++) . D.display) (usedExtensions biBuildInfo) srcOpts = map (("-i" <>) . toFilePathNoTrailingSep) @@ -407,7 +411,7 @@ generateBuildInfoOpts BioInput {..} = ]) ++ [ "-stubdir=" ++ toFilePathNoTrailingSep (buildDir biDistDir) ] componentAutogen = componentAutogenDir biCabalVersion biComponentName biDistDir - toIncludeDir "." = Just biCabalDir + toIncludeDir "." = Just biCabalDir toIncludeDir relDir = concatAndColapseAbsDir biCabalDir relDir includeOpts = map ("-I" <>) (biConfigIncludeDirs <> pkgIncludeOpts) @@ -486,21 +490,21 @@ componentBuildDir cabalVer component distDir | cabalVer < mkVersion [2, 0] = buildDir distDir | otherwise = case component of - CLib -> buildDir distDir + CLib -> buildDir distDir CInternalLib name -> buildDir distDir componentNameToDir name - CExe name -> buildDir distDir componentNameToDir name - CTest name -> buildDir distDir componentNameToDir name - CBench name -> buildDir distDir componentNameToDir name + CExe name -> buildDir distDir componentNameToDir name + CTest name -> buildDir distDir componentNameToDir name + CBench name -> buildDir distDir componentNameToDir name -- | The directory where generated files are put like .o or .hs (from .x files). componentOutputDir :: NamedComponent -> Path Abs Dir -> Path Abs Dir componentOutputDir namedComponent distDir = case namedComponent of - CLib -> buildDir distDir + CLib -> buildDir distDir CInternalLib name -> makeTmp name - CExe name -> makeTmp name - CTest name -> makeTmp name - CBench name -> makeTmp name + CExe name -> makeTmp name + CTest name -> makeTmp name + CBench name -> makeTmp name where makeTmp name = buildDir distDir componentNameToDir (name <> "/" <> name <> "-tmp") @@ -738,7 +742,7 @@ benchmarkFiles component bench = do names = bnames <> exposed exposed = case benchmarkInterface bench of - BenchmarkExeV10 _ fp -> [DotCabalMain fp] + BenchmarkExeV10 _ fp -> [DotCabalMain fp] BenchmarkUnsupported _ -> [] bnames = map DotCabalModule (otherModules build) build = benchmarkBuildInfo bench @@ -754,8 +758,8 @@ testFiles component test = do names = bnames <> exposed exposed = case testInterface test of - TestSuiteExeV10 _ fp -> [DotCabalMain fp] - TestSuiteLibV09 _ mn -> [DotCabalModule mn] + TestSuiteExeV10 _ fp -> [DotCabalMain fp] + TestSuiteLibV09 _ mn -> [DotCabalModule mn] TestSuiteUnsupported _ -> [] bnames = map DotCabalModule (otherModules build) build = testBuildInfo test @@ -843,7 +847,7 @@ targetJsSources = jsSources -- moment. Odds are, you're reading this in the year 2024 and thinking -- "wtf?" data PackageDescriptionPair = PackageDescriptionPair - { pdpOrigBuildable :: PackageDescription + { pdpOrigBuildable :: PackageDescription , pdpModifiedBuildable :: PackageDescription } @@ -931,10 +935,10 @@ flagMap = M.fromList . map pair pair = flagName &&& flagDefault data ResolveConditions = ResolveConditions - { rcFlags :: Map FlagName Bool + { rcFlags :: Map FlagName Bool , rcCompilerVersion :: ActualCompiler - , rcOS :: OS - , rcArch :: Arch + , rcOS :: OS + , rcArch :: Arch } -- | Generic a @ResolveConditions@ using sensible defaults. @@ -1082,9 +1086,9 @@ getDependencies getDependencies component dirs dotCabalPath = case dotCabalPath of DotCabalModulePath resolvedFile -> readResolvedHi resolvedFile - DotCabalMainPath resolvedFile -> readResolvedHi resolvedFile - DotCabalFilePath{} -> return (S.empty, []) - DotCabalCFilePath{} -> return (S.empty, []) + DotCabalMainPath resolvedFile -> readResolvedHi resolvedFile + DotCabalFilePath{} -> return (S.empty, []) + DotCabalCFilePath{} -> return (S.empty, []) where readResolvedHi resolvedFile = do dumpHIDir <- componentOutputDir component <$> asks ctxDistDir @@ -1108,14 +1112,7 @@ parseHI :: FilePath -> RIO Ctx (Set ModuleName, [Path Abs File]) parseHI hiPath = do dir <- asks (parent . ctxFile) - result <- liftIO $ withBinaryFile hiPath ReadMode $ \h -> - let feed :: Binary.Decoder Interface -> IO (Either String Interface) - feed (Binary.Done _ _ x) = pure $ Right x - feed (Binary.Fail _ _ str) = pure $ Left str - feed (Binary.Partial k) = do - chunk <- B.hGetSome h BL.defaultChunkSize - feed $ k $ if B.null chunk then Nothing else Just chunk - in feed (Binary.runGetIncremental getInterface :: Binary.Decoder Interface) + result <- liftIO $ Iface.fromFile hiPath case result of Left msg -> do prettyWarnL @@ -1126,19 +1123,18 @@ parseHI hiPath = do ] pure (S.empty, []) Right iface -> do - let - moduleNames = fmap (fromString . B8.unpack . fst) . unList . dmods . deps - resolveFileDependency file = do - resolved <- liftIO (forgivingAbsence (resolveFile dir file)) >>= rejectMissingFile - when (isNothing resolved) $ - prettyWarnL - [ flow "Dependent file listed in:" - , style File $ fromString hiPath - , flow "does not exist:" - , style File $ fromString file - ] - pure resolved - resolveUsages = traverse (resolveFileDependency . unUsage) . unList . usage + let moduleNames = fmap (fromString . B8.unpack . fst) . Iface.unList . Iface.dmods . Iface.deps + resolveFileDependency file = do + resolved <- liftIO (forgivingAbsence (resolveFile dir file)) >>= rejectMissingFile + when (isNothing resolved) $ + prettyWarnL + [ flow "Dependent file listed in:" + , style File $ fromString hiPath + , flow "does not exist:" + , style File $ fromString file + ] + pure resolved + resolveUsages = traverse (resolveFileDependency . Iface.unUsage) . Iface.unList . Iface.usage resolvedUsages <- catMaybes <$> resolveUsages iface pure (S.fromList $ moduleNames iface, resolvedUsages) @@ -1168,7 +1164,7 @@ parsePackageNameFromFilePath fp = do base <- clean $ toFilePath $ filename fp case parsePackageName base of Nothing -> throwM $ CabalFileNameInvalidPackageName $ toFilePath fp - Just x -> return x + Just x -> return x where clean = liftM reverse . strip . reverse strip ('l':'a':'b':'a':'c':'.':xs) = return xs strip _ = throwM (CabalFileNameParseFail (toFilePath fp)) @@ -1197,9 +1193,9 @@ findCandidate dirs name = do cons = case name of DotCabalModule{} -> DotCabalModulePath - DotCabalMain{} -> DotCabalMainPath - DotCabalFile{} -> DotCabalFilePath - DotCabalCFile{} -> DotCabalCFilePath + DotCabalMain{} -> DotCabalMainPath + DotCabalFile{} -> DotCabalFilePath + DotCabalCFile{} -> DotCabalCFilePath paths_pkg pkg = "Paths_" ++ packageNameString pkg makeNameCandidates = liftM (nubOrd . concat) (mapM makeDirCandidates dirs) @@ -1225,7 +1221,7 @@ findCandidate dirs name = do ([_], [y]) -> [y] -- Otherwise, return everything - (xs, ys) -> xs ++ ys + (xs, ys) -> xs ++ ys resolveCandidate dir = fmap maybeToList . resolveDirFile dir -- | Resolve file as a child of a specified directory, symlinks @@ -1253,9 +1249,9 @@ warnMultiple name candidate rest = , dispOne candidate ] where showName (DotCabalModule name') = D.display name' - showName (DotCabalMain fp) = fp - showName (DotCabalFile fp) = fp - showName (DotCabalCFile fp) = fp + showName (DotCabalMain fp) = fp + showName (DotCabalFile fp) = fp + showName (DotCabalCFile fp) = fp dispOne = fromString . toFilePath -- TODO: figure out why dispOne can't be just `display` -- (remove the .hlint.yaml exception if it can be) From a0fac308b46c4131e0aade174e4d989ef753b13c Mon Sep 17 00:00:00 2001 From: Hussein Ait-Lahcen Date: Tue, 16 Apr 2019 17:08:39 +0200 Subject: [PATCH 15/65] export module to allow tests --- package.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/package.yaml b/package.yaml index ceb735cdfd..86ae6ca88a 100644 --- a/package.yaml +++ b/package.yaml @@ -184,6 +184,7 @@ library: - Stack.IDE - Stack.Init - Stack.Ls + - Stack.ModuleInterface - Stack.New - Stack.Nix - Stack.Options.BenchParser From e9ec927dc5bd214dcefd1880618c1322e708b7ec Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 14 Apr 2019 09:37:44 +0300 Subject: [PATCH 16/65] Recommend Stack upgrade when appropriate (fixes #1681) --- ChangeLog.md | 6 ++++++ doc/yaml_configuration.md | 8 ++++++++ src/Stack/Config.hs | 1 + src/Stack/Runners.hs | 39 ++++++++++++++++++++++++++++++++++++++- src/Stack/Storage.hs | 14 ++++++++++++++ src/Stack/Types/Config.hs | 8 ++++++++ 6 files changed, 75 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index fb54f56f50..8c0097b4b8 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -116,6 +116,12 @@ Behavior changes: means that Stack will no longer have to force reconfigures as often. See [#3554](https://github.com/commercialhaskell/stack/issues/3554). +* Stack will check occassionally if there is a new version available and prompt + the user to upgrade. This will not incur any additional network traffic, as + it will piggy-back on the existing Hackage index updates. You can set + `recommend-stack-upgrade: false` to bypass this. See + [#1681](https://github.com/commercialhaskell/stack/issues/1681). + Other enhancements: * Defer loading up of files for local packages. This allows us to get diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index 1743e4a0a0..cc93124453 100644 --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -1072,4 +1072,12 @@ Build output when disabled: ... ``` +### recommend-stack-upgrade + +When Stack notices that a new version of Stack is available, should it notify the user? + +```yaml +recommend-stack-upgrade: true +``` + Since 2.0 diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 1b69107aec..a3f1e93eb1 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -310,6 +310,7 @@ configFromConfigMonoid configSaveHackageCreds = fromFirst True configMonoidSaveHackageCreds configHackageBaseUrl = fromFirst "https://hackage.haskell.org/" configMonoidHackageBaseUrl configHideSourcePaths = fromFirstTrue configMonoidHideSourcePaths + configRecommendUpgrade = fromFirstTrue configMonoidRecommendUpgrade configAllowDifferentUser <- case getFirst configMonoidAllowDifferentUser of diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index bb16383948..d0f08c50cd 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -20,7 +20,10 @@ module Stack.Runners ) where import Stack.Prelude +import Distribution.Version (mkVersion') +import qualified Paths_stack import RIO.Process (mkDefaultProcessContext) +import RIO.Time (addUTCTime, getCurrentTime) import Stack.Build.Target(NeedTargets(..)) import Stack.Config import Stack.Constants @@ -28,6 +31,7 @@ import Stack.DefaultColorWhen (defaultColorWhen) import qualified Stack.Docker as Docker import qualified Stack.Nix as Nix import Stack.Setup +import Stack.Storage (upgradeChecksSince, logUpgradeCheck) import Stack.Types.Config import Stack.Types.Docker (dockerEnable) import Stack.Types.Nix (nixEnable) @@ -94,7 +98,11 @@ withConfig shouldReexec inner = -- happen ASAP but needs a configuration. view (globalOptsL.to globalDockerEntrypoint) >>= traverse_ (Docker.entrypoint config) - runRIO config $ + runRIO config $ do + -- Catching all exceptions here, since we don't want this + -- check to ever cause Stack to stop working + shouldUpgradeCheck `catchAny` \e -> + logError ("Error when running shouldUpgradeCheck: " <> displayShow e) case shouldReexec of YesReexec -> reexec inner NoReexec -> inner @@ -169,3 +177,32 @@ withRunnerGlobal go inner = do | w < minTerminalWidth = minTerminalWidth | w > maxTerminalWidth = maxTerminalWidth | otherwise = w + +-- | Check if we should recommend upgrading Stack and, if so, recommend it. +shouldUpgradeCheck :: RIO Config () +shouldUpgradeCheck = do + config <- ask + when (configRecommendUpgrade config) $ do + now <- getCurrentTime + let yesterday = addUTCTime (-24 * 60 * 60) now + checks <- upgradeChecksSince yesterday + when (checks == 0) $ do + mversion <- getLatestHackageVersion "stack" UsePreferredVersions -- FIXME ensure it doesn't force an update ever + case mversion of + Just (PackageIdentifierRevision _ version _) | version > mkVersion' Paths_stack.version -> do + logWarn "<<<<<<<<<<<<<<<<<<" + logWarn $ + "You are currently using Stack version " <> + fromString (versionString (mkVersion' Paths_stack.version)) <> + ", but version " <> + fromString (versionString version) <> + " is available" + logWarn "You can try to upgrade by running 'stack upgrade'" + logWarn $ + "Tired of seeing this? Add 'recommend-stack-upgrade: false' to " <> + fromString (toFilePath (configUserConfigPath config)) + logWarn ">>>>>>>>>>>>>>>>>>" + logWarn "" + logWarn "" + _ -> pure () + logUpgradeCheck now diff --git a/src/Stack/Storage.hs b/src/Stack/Storage.hs index ac1a1da35c..a23696b0d3 100644 --- a/src/Stack/Storage.hs +++ b/src/Stack/Storage.hs @@ -28,6 +28,8 @@ module Stack.Storage , saveDockerImageExeCache , loadCompilerPaths , saveCompilerPaths + , upgradeChecksSince + , logUpgradeCheck ) where import qualified Data.ByteString as S @@ -151,6 +153,10 @@ CompilerCache globalDump Text UniqueCompilerInfo ghcPath + +-- History of checks for whether we should upgrade Stack +UpgradeCheck + timestamp UTCTime |] -- | Initialize the database. @@ -544,3 +550,11 @@ saveCompilerPaths CompilerPaths {..} = withStorage $ do , compilerCacheGlobalDump = tshow cpGlobalDump , compilerCacheArch = T.pack $ Distribution.Text.display cpArch } + +-- | How many upgrade checks have occurred since the given timestamp? +upgradeChecksSince :: HasConfig env => UTCTime -> RIO env Int +upgradeChecksSince since = withStorage $ count [UpgradeCheckTimestamp >=. since] + +-- | Log in the database that an upgrade check occurred at the given time. +logUpgradeCheck :: HasConfig env => UTCTime -> RIO env () +logUpgradeCheck = withStorage . insert_ . UpgradeCheck diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 68df7e9bdc..f51ce74bd4 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -362,6 +362,8 @@ data Config = -- ^ Database connection pool for Stack database ,configHideSourcePaths :: !Bool -- ^ Enable GHC hiding source paths? + ,configRecommendUpgrade :: !Bool + -- ^ Recommend a Stack upgrade? } -- | The project root directory, if in a project. @@ -768,6 +770,8 @@ data ConfigMonoid = , configMonoidStyles :: !StylesUpdate , configMonoidHideSourcePaths :: !FirstTrue -- ^ See 'configHideSourcePaths' + , configMonoidRecommendUpgrade :: !FirstTrue + -- ^ See 'configRecommendUpgrade' } deriving (Show, Generic) @@ -884,6 +888,7 @@ parseConfigMonoidObject rootDir obj = do <|> configMonoidStylesGB configMonoidHideSourcePaths <- FirstTrue <$> obj ..:? configMonoidHideSourcePathsName + configMonoidRecommendUpgrade <- FirstTrue <$> obj ..:? configMonoidRecommendUpgradeName return ConfigMonoid {..} where @@ -1038,6 +1043,9 @@ configMonoidStylesGBName = "stack-colours" configMonoidHideSourcePathsName :: Text configMonoidHideSourcePathsName = "hide-source-paths" +configMonoidRecommendUpgradeName :: Text +configMonoidRecommendUpgradeName = "recommend-stack-upgrade" + data ConfigException = ParseConfigFileException (Path Abs File) ParseException | ParseCustomSnapshotException Text ParseException From 6e4a05a7280c979af7fb424035b28ccdd78d4fcc Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 14 Apr 2019 10:38:43 +0300 Subject: [PATCH 17/65] Opt-in on requiring the Hackage index be present --- src/Stack/Build/ConstructPlan.hs | 4 +-- src/Stack/Build/Target.hs | 6 ++-- src/Stack/Hoogle.hs | 2 +- src/Stack/Runners.hs | 2 +- src/Stack/Unpack.hs | 4 +-- src/Stack/Upgrade.hs | 4 +-- subs/curator/src/Curator/Snapshot.hs | 2 +- subs/pantry/src/Pantry.hs | 22 +++++++++------ subs/pantry/src/Pantry/Hackage.hs | 41 ++++++++++++++++++++-------- 9 files changed, 55 insertions(+), 32 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index d2d29970d3..9a99f45e95 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -426,7 +426,7 @@ addDep name = do -- names. This code does not feel right. let version = installedVersion installed askPkgLoc = liftRIO $ do - mrev <- getLatestHackageRevision name version + mrev <- getLatestHackageRevision YesRequireHackageIndex name version case mrev of Nothing -> do -- this could happen for GHC boot libraries missing from Hackage @@ -662,7 +662,7 @@ addPackageDeps package = do eres <- addDep depname let getLatestApplicableVersionAndRev :: M (Maybe (Version, BlobKey)) getLatestApplicableVersionAndRev = do - vsAndRevs <- runRIO ctx $ getHackagePackageVersions UsePreferredVersions depname + vsAndRevs <- runRIO ctx $ getHackagePackageVersions YesRequireHackageIndex UsePreferredVersions depname pure $ do lappVer <- latestApplicableVersion range $ Map.keysSet vsAndRevs revs <- Map.lookup lappVer vsAndRevs diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 6f5875ae28..11defe344a 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -343,7 +343,7 @@ resolveRawTarget sma allLocs (ri, rt) = ] -- Not present at all, add it from Hackage Nothing -> do - mrev <- getLatestHackageRevision name version + mrev <- getLatestHackageRevision YesRequireHackageIndex name version pure $ case mrev of Nothing -> deferToConstructPlan name Just (_rev, cfKey, treeKey) -> Right ResolveResult @@ -355,7 +355,7 @@ resolveRawTarget sma allLocs (ri, rt) = } hackageLatest name = do - mloc <- getLatestHackageLocation name UsePreferredVersions + mloc <- getLatestHackageLocation YesRequireHackageIndex name UsePreferredVersions pure $ case mloc of Nothing -> deferToConstructPlan name Just loc -> do @@ -368,7 +368,7 @@ resolveRawTarget sma allLocs (ri, rt) = } hackageLatestRevision name version = do - mrev <- getLatestHackageRevision name version + mrev <- getLatestHackageRevision YesRequireHackageIndex name version pure $ case mrev of Nothing -> deferToConstructPlan name Just (_rev, cfKey, treeKey) -> Right ResolveResult diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 712baf58aa..7a5215cad6 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -78,7 +78,7 @@ hoogleCmd (args,setup,rebuild,startServer) = installHoogle :: RIO EnvConfig () installHoogle = do hooglePackageIdentifier <- do - mversion <- getLatestHackageVersion hooglePackageName UsePreferredVersions + mversion <- getLatestHackageVersion YesRequireHackageIndex hooglePackageName UsePreferredVersions -- FIXME For a while, we've been following the logic of -- taking the latest Hoogle version available. However, we diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index d0f08c50cd..662176c95d 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -187,7 +187,7 @@ shouldUpgradeCheck = do let yesterday = addUTCTime (-24 * 60 * 60) now checks <- upgradeChecksSince yesterday when (checks == 0) $ do - mversion <- getLatestHackageVersion "stack" UsePreferredVersions -- FIXME ensure it doesn't force an update ever + mversion <- getLatestHackageVersion NoRequireHackageIndex "stack" UsePreferredVersions case mversion of Just (PackageIdentifierRevision _ version _) | version > mkVersion' Paths_stack.version -> do logWarn "<<<<<<<<<<<<<<<<<<" diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index 0780ec1d9b..5c5b5f9ad6 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -69,14 +69,14 @@ unpackPackages mSnapshot dest input = do toLocNoSnapshot :: PackageName -> RIO env (Either String (PackageLocationImmutable, PackageIdentifier)) toLocNoSnapshot name = do - mloc1 <- getLatestHackageLocation name UsePreferredVersions + mloc1 <- getLatestHackageLocation YesRequireHackageIndex name UsePreferredVersions mloc <- case mloc1 of Just _ -> pure mloc1 Nothing -> do updated <- updateHackageIndex $ Just $ "Could not find package " <> fromString (packageNameString name) <> ", updating" case updated of - UpdateOccurred -> getLatestHackageLocation name UsePreferredVersions + UpdateOccurred -> getLatestHackageLocation YesRequireHackageIndex name UsePreferredVersions NoUpdateOccurred -> pure Nothing case mloc of Nothing -> do diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 8ff7d58a5d..42df0facf2 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -210,7 +210,7 @@ sourceUpgrade builtHash (SourceOpts gitRepo) = Nothing -> withConfig NoReexec $ do void $ updateHackageIndex $ Just "Updating index to make sure we find the latest Stack version" - mversion <- getLatestHackageVersion "stack" UsePreferredVersions + mversion <- getLatestHackageVersion YesRequireHackageIndex "stack" UsePreferredVersions (PackageIdentifierRevision _ version _) <- case mversion of Nothing -> throwString "No stack found in package indices" @@ -223,7 +223,7 @@ sourceUpgrade builtHash (SourceOpts gitRepo) = else do suffix <- parseRelDir $ "stack-" ++ versionString version let dir = tmp suffix - mrev <- getLatestHackageRevision "stack" version + mrev <- getLatestHackageRevision YesRequireHackageIndex "stack" version case mrev of Nothing -> throwString "Latest version with no revision" Just (_rev, cfKey, treeKey) -> do diff --git a/subs/curator/src/Curator/Snapshot.hs b/subs/curator/src/Curator/Snapshot.hs index b83d536a64..69c2aead22 100644 --- a/subs/curator/src/Curator/Snapshot.hs +++ b/subs/curator/src/Curator/Snapshot.hs @@ -75,7 +75,7 @@ toLoc toLoc name pc = case pcSource pc of PSHackage (HackageSource mrange mrequiredLatest revisions) -> do - versions <- getHackagePackageVersions IgnorePreferredVersions name -- don't follow the preferred versions on Hackage, give curators more control + versions <- getHackagePackageVersions YesRequireHackageIndex IgnorePreferredVersions name -- don't follow the preferred versions on Hackage, give curators more control when (Map.null versions) $ error $ "Package not found on Hackage: " ++ packageNameString name for_ mrequiredLatest $ \required -> case Map.maxViewWithKey versions of diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 167ba1ced5..27690d2a69 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -154,6 +154,7 @@ module Pantry -- * Hackage index , updateHackageIndex , DidUpdateOccur (..) + , RequireHackageIndex (..) , hackageIndexTarballL , getHackagePackageVersions , getLatestHackageVersion @@ -267,11 +268,12 @@ defaultHackageSecurityConfig = HackageSecurityConfig -- @since 0.1.0.0 getLatestHackageVersion :: (HasPantryConfig env, HasLogFunc env) - => PackageName -- ^ package name + => RequireHackageIndex + -> PackageName -- ^ package name -> UsePreferredVersions -> RIO env (Maybe PackageIdentifierRevision) -getLatestHackageVersion name preferred = - ((fmap fst . Map.maxViewWithKey) >=> go) <$> getHackagePackageVersions preferred name +getLatestHackageVersion req name preferred = + ((fmap fst . Map.maxViewWithKey) >=> go) <$> getHackagePackageVersions req preferred name where go (version, m) = do (_rev, BlobKey sha size) <- fst <$> Map.maxViewWithKey m @@ -283,12 +285,13 @@ getLatestHackageVersion name preferred = -- @since 0.1.0.0 getLatestHackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => PackageName -- ^ package name + => RequireHackageIndex + -> PackageName -- ^ package name -> UsePreferredVersions -> RIO env (Maybe PackageLocationImmutable) -getLatestHackageLocation name preferred = do +getLatestHackageLocation req name preferred = do mversion <- - fmap fst . Map.maxViewWithKey <$> getHackagePackageVersions preferred name + fmap fst . Map.maxViewWithKey <$> getHackagePackageVersions req preferred name let mVerCfKey = do (version, revisions) <- mversion (_rev, cfKey) <- fst <$> Map.maxViewWithKey revisions @@ -305,11 +308,12 @@ getLatestHackageLocation name preferred = do -- @since 0.1.0.0 getLatestHackageRevision :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => PackageName -- ^ package name + => RequireHackageIndex + -> PackageName -- ^ package name -> Version -> RIO env (Maybe (Revision, BlobKey, TreeKey)) -getLatestHackageRevision name version = do - revisions <- getHackagePackageVersionRevisions name version +getLatestHackageRevision req name version = do + revisions <- getHackagePackageVersionRevisions req name version case fmap fst $ Map.maxViewWithKey revisions of Nothing -> pure Nothing Just (revision, cfKey@(BlobKey sha size)) -> do diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index eecf247237..7a9b925d1d 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -5,6 +5,7 @@ module Pantry.Hackage ( updateHackageIndex , DidUpdateOccur (..) + , RequireHackageIndex (..) , hackageIndexTarballL , getHackageTarball , getHackageTarballKey @@ -335,7 +336,7 @@ fuzzyLookupCandidates -> Version -> RIO env FuzzyResults fuzzyLookupCandidates name ver0 = do - m <- getHackagePackageVersions UsePreferredVersions name + m <- getHackagePackageVersions YesRequireHackageIndex UsePreferredVersions name if Map.null m then FRNameNotFound <$> getHackageTypoCorrections name else @@ -390,18 +391,37 @@ getHackageTypoCorrections name1 = data UsePreferredVersions = UsePreferredVersions | IgnorePreferredVersions deriving Show +-- | Require that the Hackage index is populated. +-- +-- @since 0.1.0.0 +data RequireHackageIndex + = YesRequireHackageIndex + -- ^ If there is nothing in the Hackage index, then perform an update + | NoRequireHackageIndex + -- ^ Do not perform an update + deriving Show + +initializeIndex + :: (HasPantryConfig env, HasLogFunc env) + => RequireHackageIndex + -> RIO env () +initializeIndex NoRequireHackageIndex = pure () +initializeIndex YesRequireHackageIndex = do + cabalCount <- withStorage countHackageCabals + when (cabalCount == 0) $ void $ + updateHackageIndex $ Just $ "No information from Hackage index, updating" + -- | Returns the versions of the package available on Hackage. -- -- @since 0.1.0.0 getHackagePackageVersions :: (HasPantryConfig env, HasLogFunc env) - => UsePreferredVersions + => RequireHackageIndex + -> UsePreferredVersions -> PackageName -- ^ package name -> RIO env (Map Version (Map Revision BlobKey)) -getHackagePackageVersions usePreferred name = do - cabalCount <- withStorage countHackageCabals - when (cabalCount == 0) $ void $ - updateHackageIndex $ Just $ "No information from Hackage index, updating" +getHackagePackageVersions req usePreferred name = do + initializeIndex req withStorage $ do mpreferred <- case usePreferred of @@ -420,13 +440,12 @@ getHackagePackageVersions usePreferred name = do -- @since 0.1.0.0 getHackagePackageVersionRevisions :: (HasPantryConfig env, HasLogFunc env) - => PackageName -- ^ package name + => RequireHackageIndex + -> PackageName -- ^ package name -> Version -- ^ package version -> RIO env (Map Revision BlobKey) -getHackagePackageVersionRevisions name version = do - cabalCount <- withStorage countHackageCabals - when (cabalCount == 0) $ void $ - updateHackageIndex $ Just $ "No information from Hackage index, updating" +getHackagePackageVersionRevisions req name version = do + initializeIndex req withStorage $ Map.map snd <$> loadHackagePackageVersion name version From e5d92456cf866586a79cecd2e93acddbd4328624 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 16 Apr 2019 21:35:05 +0300 Subject: [PATCH 18/65] Compare minor versions only Explained by @borsboom at https://github.com/commercialhaskell/stack/pull/4729#pullrequestreview-227176315 --- src/Stack/Runners.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index 662176c95d..9f2a0be259 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -20,8 +20,6 @@ module Stack.Runners ) where import Stack.Prelude -import Distribution.Version (mkVersion') -import qualified Paths_stack import RIO.Process (mkDefaultProcessContext) import RIO.Time (addUTCTime, getCurrentTime) import Stack.Build.Target(NeedTargets(..)) @@ -35,6 +33,7 @@ import Stack.Storage (upgradeChecksSince, logUpgradeCheck) import Stack.Types.Config import Stack.Types.Docker (dockerEnable) import Stack.Types.Nix (nixEnable) +import Stack.Types.Version (stackMinorVersion, stackVersion, minorVersion) import System.Console.ANSI (hSupportsANSIWithoutEmulation) import System.Terminal (getTerminalWidth) @@ -189,11 +188,13 @@ shouldUpgradeCheck = do when (checks == 0) $ do mversion <- getLatestHackageVersion NoRequireHackageIndex "stack" UsePreferredVersions case mversion of - Just (PackageIdentifierRevision _ version _) | version > mkVersion' Paths_stack.version -> do + -- Compare the minor version so we avoid patch-level, Hackage-only releases. + -- See: https://github.com/commercialhaskell/stack/pull/4729#pullrequestreview-227176315 + Just (PackageIdentifierRevision _ version _) | minorVersion version > stackMinorVersion -> do logWarn "<<<<<<<<<<<<<<<<<<" logWarn $ "You are currently using Stack version " <> - fromString (versionString (mkVersion' Paths_stack.version)) <> + fromString (versionString stackVersion) <> ", but version " <> fromString (versionString version) <> " is available" From b85d07292251131c8a45195133cfdff9609139f7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 17 Apr 2019 07:14:07 +0300 Subject: [PATCH 19/65] Delete old UpgradeCheck records --- src/Stack/Storage.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Stack/Storage.hs b/src/Stack/Storage.hs index a23696b0d3..6ff90e3442 100644 --- a/src/Stack/Storage.hs +++ b/src/Stack/Storage.hs @@ -557,4 +557,6 @@ upgradeChecksSince since = withStorage $ count [UpgradeCheckTimestamp >=. since] -- | Log in the database that an upgrade check occurred at the given time. logUpgradeCheck :: HasConfig env => UTCTime -> RIO env () -logUpgradeCheck = withStorage . insert_ . UpgradeCheck +logUpgradeCheck time = withStorage $ do + deleteWhere ([] :: [Filter UpgradeCheck]) + insert_ $ UpgradeCheck time From 1e11aa063dc554b7424f8e916a97853527f5b4ab Mon Sep 17 00:00:00 2001 From: Hussein Ait-Lahcen Date: Tue, 16 Apr 2019 17:09:23 +0200 Subject: [PATCH 20/65] introduce binary interface tests --- src/test/Stack/ModuleInterfaceSpec.hs | 46 ++++++++++++++++++++++++++ test/files/iface/README.md | 3 ++ test/files/iface/Test.h | 2 ++ test/files/iface/Test.hs | 27 +++++++++++++++ test/files/iface/X.hs | 4 +++ test/files/iface/shell.nix | 29 ++++++++++++++++ test/files/iface/x64/ghc822/Main.hi | Bin 0 -> 3158 bytes test/files/iface/x64/ghc822/X.hi | Bin 0 -> 866 bytes test/files/iface/x64/ghc844/Main.hi | Bin 0 -> 3095 bytes test/files/iface/x64/ghc844/X.hi | Bin 0 -> 817 bytes test/files/iface/x64/ghc864/Main.hi | Bin 0 -> 3122 bytes test/files/iface/x64/ghc864/X.hi | Bin 0 -> 844 bytes 12 files changed, 111 insertions(+) create mode 100644 src/test/Stack/ModuleInterfaceSpec.hs create mode 100644 test/files/iface/README.md create mode 100644 test/files/iface/Test.h create mode 100644 test/files/iface/Test.hs create mode 100644 test/files/iface/X.hs create mode 100644 test/files/iface/shell.nix create mode 100644 test/files/iface/x64/ghc822/Main.hi create mode 100644 test/files/iface/x64/ghc822/X.hi create mode 100644 test/files/iface/x64/ghc844/Main.hi create mode 100644 test/files/iface/x64/ghc844/X.hi create mode 100644 test/files/iface/x64/ghc864/Main.hi create mode 100644 test/files/iface/x64/ghc864/X.hi diff --git a/src/test/Stack/ModuleInterfaceSpec.hs b/src/test/Stack/ModuleInterfaceSpec.hs new file mode 100644 index 0000000000..66dac79a6b --- /dev/null +++ b/src/test/Stack/ModuleInterfaceSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Stack.ModuleInterfaceSpec where + +import Data.Foldable (traverse_) +import Data.Semigroup ((<>)) +import Distribution.System (Arch (..), buildArch) +import qualified Stack.ModuleInterface as Iface +import Stack.Prelude hiding (Version) +import System.Directory (doesFileExist) +import Test.Hspec (Spec, describe, it, shouldBe) + +type Version = String + +versions :: [Version] +versions = ["822", "844", "864"] + +spec :: Spec +spec = describe "should succesfully deserialize interface from" $ traverse_ deserialize versions + +deserialize :: Version -> Spec +deserialize v = + it ("GHC" <> v) $ do + let arch = + case buildArch of + I386 -> "x32" + _ -> "x64" + ifacePath = "test/files/iface/" <> arch <> "/ghc" <> v <> "/Main.hi" + exists <- doesFileExist ifacePath + when exists $ do + result <- Iface.fromFile ifacePath + case result of + (Left msg) -> fail msg + (Right iface) -> do + hasExpectedUsage iface `shouldBe` True + hasExpectedModule iface `shouldBe` True + +-- | `Usage` is the name given by GHC to TH dependency +hasExpectedUsage :: Iface.Interface -> Bool +hasExpectedUsage = + elem "Test.h" . fmap Iface.unUsage . Iface.unList . Iface.usage + +hasExpectedModule :: Iface.Interface -> Bool +hasExpectedModule = + elem "X" . fmap fst . Iface.unList . Iface.dmods . Iface.deps diff --git a/test/files/iface/README.md b/test/files/iface/README.md new file mode 100644 index 0000000000..d245656d61 --- /dev/null +++ b/test/files/iface/README.md @@ -0,0 +1,3 @@ +# Generating the dummy iface + +Update the `supportedVersions` in the `shell.nix` and then run the following command `nix-shell --pure --run "generate"` diff --git a/test/files/iface/Test.h b/test/files/iface/Test.h new file mode 100644 index 0000000000..bb31ec3f0f --- /dev/null +++ b/test/files/iface/Test.h @@ -0,0 +1,2 @@ +#define TRUE 1 +#define FALSE 0 diff --git a/test/files/iface/Test.hs b/test/files/iface/Test.hs new file mode 100644 index 0000000000..200e08f033 --- /dev/null +++ b/test/files/iface/Test.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} + +module Main where + +import X +import GHC.Types +import Control.Monad +import Language.Haskell.TH + +#include "Test.h" + +main :: IO () +main = putStrLn "Hello, World!" + +curryN :: Int -> Q Exp +curryN n = do + f <- newName "f" + xs <- replicateM n (newName "x") + let args = map VarP (f:xs) + ntup = TupE (map VarE xs) + return $ LamE args (AppE (VarE f) ntup) + +data List a = Nil | Cons a (List a) + +x = Cons 4 (Cons 2 Nil) + +y = TRUE diff --git a/test/files/iface/X.hs b/test/files/iface/X.hs new file mode 100644 index 0000000000..a1d5b7bc22 --- /dev/null +++ b/test/files/iface/X.hs @@ -0,0 +1,4 @@ +module X where + +x :: Integer +x = 1 diff --git a/test/files/iface/shell.nix b/test/files/iface/shell.nix new file mode 100644 index 0000000000..10da5f97dd --- /dev/null +++ b/test/files/iface/shell.nix @@ -0,0 +1,29 @@ +with (import (builtins.fetchTarball { + name = "nixpkgs-19.03"; + url = "https://github.com/nixos/nixpkgs/archive/release-19.03.tar.gz"; + sha256 = "sha256:1p0xkcz183gwga9f9b24ihq3b7syjimkhr31y6h044yfmrkcnb6d"; +}) {}); +let + supportedVersions = [ + "822" + "844" + "864" + ]; + generate = version: + let ghc = haskell.compiler."ghc${version}"; + main = "Test"; + in '' + mkdir -p x64/ghc${version}/ + ${ghc}/bin/ghc -fforce-recomp -hidir x64/ghc${version} ${main}.hs && \ + rm *.o && \ + rm ${main} + ''; +in + mkShell { + shellHook = + '' + generate() { + ${lib.concatMapStrings generate supportedVersions} + } + ''; + } diff --git a/test/files/iface/x64/ghc822/Main.hi b/test/files/iface/x64/ghc822/Main.hi new file mode 100644 index 0000000000000000000000000000000000000000..86162d7912828e6544036d02ec894862399279b9 GIT binary patch literal 3158 zcma)7YfKbZ6rNpR7i7T|L==Q-0nyqWL3~hBt0)K>!Br@sHJT2))7^n(W|^Hu)@ps! zq}HgRYHh@}e;~1~Nl{}%8qHab{1u6}WKV_8$ux#8WpTGPwzS598N``c5O zzFV8#=ijfscjKM)!o9?y!RueED^mwfI?f!1on;3Za#k*$zA<1R5*LS$4Ieu`5ON9l zj3ZS7C?zt&F_}?Gj7Vn0ct$uGF@X^&j7Vj~L`I}BViF_L88H%T3gcujB9jqQ8Ii?^ zY(`MajKZcdVmb)a_9!EAK#U{IrA9ofm#G(=cl{@RpH_CT+L5(mv(mk!3wlN`9Bp$3 zj%-+PQ`$Wvy<Q>o_^KV$TxBk=r^X9fY zYZhHw;OtB>o$J}p>c4bl{q$R3b-H?|M!L@D>t&gRz0&2s(Vm|*hrfJy=%vY@MK~)C zyOvNS3=wLCJfXk)+?)G0yzO|V@AI-X3wK-ZTI-2BhfpSz2;0m(vr=fU62cSo77$`= z3kl~D1_+x88%?^E){TTMCa>6}=hGS?Y$Du52p@hE8)$_e*uocbSV#zc4>#6>pHc$kjEE4-uIs1ThjB7}XA5Ikgru7XCj;G;tVA?zTB zJ~{;&r-RDSZRCIxV7VEf89iVnrX-UB7c<- zon`)>CmON*-uT9{)@$_zE%~AHQ#t*mal|wLx5{|ZVnD{m;6n%v8`t~$;?<7EyZz}I z`}=SBtdiZ4GeT3!U~`nDn8`-a#Kf1V~Z;#v%V4|1F&6*K}>ps zt+ZMW5esWO>^Ls_LcXKt*pJhmTRh|X@$I*9lM%q43>%y%H4J(ox!0A|(OWdjdEw%6 z>D5WlBeuN+8R|zy`i~pB%5eJ8?+4`WYsE)PxuOhG)BoJ;>){hRV34hslb-7Mt7_4` zv)SHcZr#uZOv@NBUVmbtW^Oi<={vSDWaQQWU52sN!GehzachAPBd&wKD;U{03=GXCi+Cxus72wpw=3qe3M3-L(HHiVd6M%$@%4PiWfFj^>1LDD08qF|unIdbd65vaN!GPou zG^v#(?21mbs`n{muuy!ZF?D=xC0`Sf zHG$1b5*sgSzreb0r|5yOmnEH06A97yQd`Wp`p}{(*0t3Ch-2zn1e36N!m1jnW^9&# sh0RnfM#GfGQdZ1&Otr)=OMI^8$sZ-MV;>b`JIYByuBKMeWCp~40lMiMUjP6A literal 0 HcmV?d00001 diff --git a/test/files/iface/x64/ghc822/X.hi b/test/files/iface/x64/ghc822/X.hi new file mode 100644 index 0000000000000000000000000000000000000000..e934d1f3e5041e4e96430d8db7e0b5d559eec338 GIT binary patch literal 866 zcmZSlbuNVg3Rr-&1rQqmu@MwAo?~EOTm|HS0V4y0V_96$m-5GtlUQ?3t?%Xs6keeA88q5A&e^*oSE710pnZRNp1&|n{ z9f)vdU@~gkTH4*SBe?j6LBZ91ydZNx+8EPWdm9+)z}{3Vu;N^KoPFl)spq;EGJOyR zDFFh;F4mp{3_6gI0P!a>WZKR8;cNTnxLgV!L-d_EJ+L}RsDYUfZ-CT-xG;ktJQ1)8 z1_n_m&61m#nFnPvM!*D<5{pxzY>xDdWZim+J2S5&H9fURH$AriD#YpT;jHJD zlb=`u(*qK4LYN`!oS#=xl%J#LSWu9YnVeXXSq3wn+a<9iQO`BABqOy5s#^#w^&GglNv#xo@~uOzdi66P?lq;Gy+ekLrrLQD#&EJ)RJEi6sUK`7<{xzIf| zFSRH$xfp7I07%T!U(dB7Ikli9GanW#V6`Aad@@U5YT;sjiEuIYfTGl#(iE7_AjUxg YOAn+SY7Jurl)ltm0iHdF2)YKbmYdq3MG))sNl}O(=v;QurO?}yK=H35$@Bimt z(?922T#zjE9zhsP7#4(mJjdC#lAx1`FeXx99pvbY0UQJ zXCDn)J@w+Y`N(SuP-4!^+36Vp1uEgJctql1!vjVx3XgW=N(86&jEPQQTnuAk8PkC= z9T^kHn0Us7!aFfdXU244Od?~tGNv12x`RQjJs6V&2Icl-OfN9)2(M6Yxq9V#53inV zntSTq>VE6rSw$X{EYUZ=cdKw$G+D;e#3$)H7Vd49X9p0<)4_bedCa}1dnOmyFJ)Ytk@1+*C;$Gy zHP?!pFEoxm_1oaiH`n=0?e1BXvhxS0T)x%t==Xc3yG91R`hJHKU8M<2wP~A|etz5E zn4!-**jV=V+?p%Zm+p^_@6zX^g4A-(jG0U)hy*`DBk%;z-uh2!i$05r*ViI*+aJH8uJX3i%qs)5JLOdMH}9o-Ef z3@2b05bq;Ehl(&+@aPtLOh_Og4tDrsQsCKSF;Ucj-N0^Qhv1(=z&Ze%c9?76CCndkQFR|bFvrErKlnKB>vKm_ z1E)!i3(&gXx@r+V3i4jNN0JiaZ4C>Zf8CjzP;?V6bUj+Hgk7xdJI6HUZC#f0(>S5- z*tq?0i6WOLVV9(xG4-RiEZf?0z1&j#<0ecOA9!RhxK!y2WtZ%;9=MZ{krgv%acbn< zCRA!cL$6s^9_PLy2EMHQcDB$#<_m$+Ppz zhSn8sLj)~g8-y6_KaCfD5BVLx9{l0LmWT1&tmU<}E8s_J+iVoBZ!r14Y53j%rg=^WUqkP|*oki3MG#%}sMcTDr?UanYfc0&=)RvR+@D@cW&x!0LZ zmzZGKl9{O6`iCT(zX2f$#y8qX149xRD$XE1i+(U5>r$vVUBYJt!siOIlnIh-u$(0~ z%$o{>${0aag-XX@emFmb4@DIVelh6K!6k}5zc}BK!VlwzhFs#@9;c&NQ8b65C8Gc;VRPZc$-k}{@HM%*r-j+$8J^9q{i@Cg1=(d#wT zT-2nj41S_l5pWfN>`W^WItQ9a~n&xOO!Q9t9)U~d{uD;oGh?oo4|rVXfC=wSCJJ7_ZTQv zR~3k5l3P^*Y+8wJwR|?sQlr@3vXAIkZnx()- zX`|J>0T(Mes-V(O$BWtxuB#s^bj7BT@Pc)Mz9u2aL^=biTA9bxtN;@`29_KtbY3h} i70VrwC$ZhK_tTuotxPt^VKc;5Nuv5`YAzinulO%)c_|$L literal 0 HcmV?d00001 diff --git a/test/files/iface/x64/ghc844/X.hi b/test/files/iface/x64/ghc844/X.hi new file mode 100644 index 0000000000000000000000000000000000000000..84c8be089cd98210b4c66c52d5013e0c01fafe89 GIT binary patch literal 817 zcmZSlbuNVg3Rr-&1rQqmu?ZA2US?omTo2@c0V4y0upPGoTb3P9>#Szwh0`8&v}jMh zmGtM*TkB&F4MguxD|o(X3MU`S#})qEe`fa_nXKe`^-~A=up449q~931~c+!N9`61QG`ktS|-}JB$TqaKJ=3VGJ%9gB!-+ zfiZZ29#I1u3pSUJJ>XDi>!a<{&sJ#4I@wy@1*u~I+RVVf|M{xe99s*6R&U8~VbN+K z%nTrhF)(mFXU)$&zuo)#qdVVTK4*Le5@U1*5grUo?~WX37hV^dH)H?qU7Ei%1i+F& zsT|hc28KGYU)C-?F?+pQ(3LMi@t155eAWjk0RqN;)}8|lIuP%I_|q6N?PmS(wf%Ek zE`^UF`c9l4SREv2z)XlYKx#o;uw5Vqm?sEg0f7*NVqnQl%*=zb86#kVNr}a&P&P+; zMzU@}QD!cb&z+f9lA4}cq??{w02ShN_i)y8%gIkHf$0GWI3dgscFxZ$Day~$b1W#x z$xKcx$t;5zFXWO~lBnlanwMOXU!(_AR}3>m6h+1}B{i=kv!oK{3b3SaeqMeiEP;xH zg@RLaGt-OmOAGWof$l8IOU!}l-~qYGJvA@2C^NYjDkcCD^Yqtqtw>HSD9Ox+1q6FQ kQEEOw;Q!6++m^$~-~KcI{r~TKZ{C{z zKIvg$ve0`FaVl{paXN9#B*tueNYKf|SeN$`oqa!BysCDFB~Y?%cgp;G3FpUdUw^d9 zb#qk%^ilfJGcEx?#T4jCEF8v*wDwckQy;Fi=k%}448~r@rcGl4}z1~@n}V% zL_~qD>oLh#H9lapT4qLllJ%B*mK3Ll(CDi1Dewh8*;A5~DZ#=mQ-w zSRL~4#ypr6Ghj`a3;OfsAqRNyb%aR9+#G|Jb*jR4%#Sr87nmU*vy?TStiL&T+?4!4 z(+OXSqbjO%lz}1;K|at1YM2P&E{$!HM1D&v}pf@q1tgBTIfO!_oAKSMjPKF2+(p<$})EE$<~ zH6H7keaF&U=C+Q?Fa9jpesW({=rEi%avicRnum{qF27}4WI3Uo?NY7#x2sbVO20!0 z-H+Dm%^}v<_Ku$m*3{*leofr5|Fzu+u~YB3=8&!%97hJPs$28uVwGju@fAP}A9(Zt zgv`+!<(BWXettDO+vS+@PFD1_d(@j*u%MT$?;T*)pPi(` zL=h1JKK~hNHarvpD0Kzpbt1tGV(f?#mE2A2cWhI~4&~n-|Fu3GVCxix3F#I#)7!M1 z%y>5-kFk0-cwx%5i}wp+gt~z{O7t6(8rX&-2m4R(BCc-Jyx4M2V`7Jx{s%7{FL$6g znQcA{u5U2K_cvnar}aI0&EBx4vFL7TQd1I6Fn-=_OHdOrFp$2S$*->XD}UHOhr4^? z*`!OQI9qUR#bXy9kzZuvSA$GgJ?o7JNY@OJYbjjSeSIPtPGaAP24}y=w3j0q1RB#I zy^4NBpzB(A%&>+J41^CCWT_Bk#Sob#zgaewgpCeSRmB=-s*oWJ6e3yE#Gn)oXzh`t zKv1f5rU~iv$3xnB%iPXse!u3_%AA9QOaa#fCqR;NVWHaeuZHNUF+{E@}Bd%~v#dDHffd2&6HqRCp# zGfNh!eox5F6WctNSR9JrqTBQRieJW!28!2B#ZrarRsA83R>#M!LN4K{Dk6u+SmFdp z4a$DL({?>&LUZLfKsH8FBvp3feg(CGEw@k@Rqd7nT61zo9dExX$zG*cb?1qSR~TOt z;E;BK8^)06l}1%-l7hy;mLbXGrD{zm(l@zCrTrI1D2iXBt@Q}5khe?<7L7G#V4a@| zeIg)63=7fjkgC=ca5Epk#E*d`PmY`y3r)pqM-|9?w_=!Fd+-hFRC$gMLn5QJC!2w04fi zlDL4K_x@YQe2Bc(&u;QrM0SD7yS%*XB{R2kKIOZxysz5Cf9i3E?8h;)OCL^~yrXsP zKi&nMXTOkKPhMDkE_OGwg-QUmO6#^1t1d)u93{3Bi z9B3C_7n(O?|L$Fyzcd8El0d0i*4_q&Im z6h+1}B{i=kv!oK{3b3SaeqMeiEbWSeg@RLaGt-OmOAGWof$l8IOU!}l-~qYGJvA@2 zC^NYjDkcCD^Yqtqtw>HSD9Ox+1q6FQQEE Date: Wed, 17 Apr 2019 10:35:00 +0200 Subject: [PATCH 21/65] fix architecture detection --- src/Stack/ModuleInterface.hs | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/src/Stack/ModuleInterface.hs b/src/Stack/ModuleInterface.hs index 572cc88824..5f9b230451 100644 --- a/src/Stack/ModuleInterface.hs +++ b/src/Stack/ModuleInterface.hs @@ -29,7 +29,7 @@ import Data.List (find) import Data.Maybe (catMaybes) import Data.Semigroup ((<>)) import qualified Data.Vector as V -import Foreign (sizeOf) +import Distribution.System (Arch (..), buildArch) import GHC.IO.IOMode (IOMode (..)) import Numeric (showHex) import RIO.ByteString as B (ByteString, hGetSome, null) @@ -393,18 +393,17 @@ getInterface861 d = do getInterface :: Get Interface getInterface = do + let (expectedMagic, bypassDummyPtr) = + case buildArch of + I386 -> (0x1face, void getWord32be) + _ -> (0x1face64, void getWord64be) magic <- getWord32be - when (magic /= 0x1face64) (fail $ "Invalid magic: " <> showHex magic "") - {- - dummy value depending on the wORD_SIZE - wORD_SIZE :: Int - wORD_SIZE = (#const SIZEOF_HSINT) - - This was used to serialize pointers - -} - if sizeOf (undefined :: Int) == 4 - then void getWord32be - else void getWord64be + when + (magic /= expectedMagic) + (fail $ + "Invalid magic: got: " <> showHex magic "" <> ", expected: " <> + showHex expectedMagic "") + bypassDummyPtr -- ghc version version <- getString -- way From 4ea786c140e0cfd1afa49378ff5e661031ff0053 Mon Sep 17 00:00:00 2001 From: Hussein Ait-Lahcen Date: Wed, 17 Apr 2019 15:30:17 +0200 Subject: [PATCH 22/65] fix: architecture independent deserialization --- src/Stack/ModuleInterface.hs | 19 +++++------- src/test/Stack/ModuleInterfaceSpec.hs | 42 +++++++++++++-------------- 2 files changed, 28 insertions(+), 33 deletions(-) diff --git a/src/Stack/ModuleInterface.hs b/src/Stack/ModuleInterface.hs index 5f9b230451..947c641330 100644 --- a/src/Stack/ModuleInterface.hs +++ b/src/Stack/ModuleInterface.hs @@ -14,7 +14,7 @@ module Stack.ModuleInterface {- HLINT ignore "Reduce duplication" -} -import Control.Monad (replicateM, replicateM_, when) +import Control.Monad (replicateM, replicateM_) import Data.Binary (Get, Word32) import Data.Binary.Get (Decoder (..), bytesRead, getByteString, getInt64be, @@ -29,7 +29,6 @@ import Data.List (find) import Data.Maybe (catMaybes) import Data.Semigroup ((<>)) import qualified Data.Vector as V -import Distribution.System (Arch (..), buildArch) import GHC.IO.IOMode (IOMode (..)) import Numeric (showHex) import RIO.ByteString as B (ByteString, hGetSome, null) @@ -393,17 +392,13 @@ getInterface861 d = do getInterface :: Get Interface getInterface = do - let (expectedMagic, bypassDummyPtr) = - case buildArch of - I386 -> (0x1face, void getWord32be) - _ -> (0x1face64, void getWord64be) magic <- getWord32be - when - (magic /= expectedMagic) - (fail $ - "Invalid magic: got: " <> showHex magic "" <> ", expected: " <> - showHex expectedMagic "") - bypassDummyPtr + case magic of + -- x32 + 0x1face -> void getWord32be + -- x64 + 0x1face64 -> void getWord64be + invalidMagic -> fail $ "Invalid magic: " <> showHex invalidMagic "" -- ghc version version <- getString -- way diff --git a/src/test/Stack/ModuleInterfaceSpec.hs b/src/test/Stack/ModuleInterfaceSpec.hs index 66dac79a6b..e425cdec59 100644 --- a/src/test/Stack/ModuleInterfaceSpec.hs +++ b/src/test/Stack/ModuleInterfaceSpec.hs @@ -5,36 +5,36 @@ module Stack.ModuleInterfaceSpec where import Data.Foldable (traverse_) import Data.Semigroup ((<>)) -import Distribution.System (Arch (..), buildArch) import qualified Stack.ModuleInterface as Iface import Stack.Prelude hiding (Version) -import System.Directory (doesFileExist) import Test.Hspec (Spec, describe, it, shouldBe) type Version = String +type Architecture = String +type Directory = FilePath versions :: [Version] -versions = ["822", "844", "864"] +versions = ["ghc822", "ghc844", "ghc864"] + +-- TODO: add x32 when generated +archs :: [Architecture] +archs = ["x64"] + +directories :: [FilePath] +directories = (<>) <$> ((<> "/") <$> archs) <*> versions spec :: Spec -spec = describe "should succesfully deserialize interface from" $ traverse_ deserialize versions - -deserialize :: Version -> Spec -deserialize v = - it ("GHC" <> v) $ do - let arch = - case buildArch of - I386 -> "x32" - _ -> "x64" - ifacePath = "test/files/iface/" <> arch <> "/ghc" <> v <> "/Main.hi" - exists <- doesFileExist ifacePath - when exists $ do - result <- Iface.fromFile ifacePath - case result of - (Left msg) -> fail msg - (Right iface) -> do - hasExpectedUsage iface `shouldBe` True - hasExpectedModule iface `shouldBe` True +spec = describe "should succesfully deserialize interface from" $ traverse_ deserialize directories + +deserialize :: Directory -> Spec +deserialize d = do + it d $ do + result <- Iface.fromFile $ "test/files/iface/" <> d <> "/Main.hi" + case result of + (Left msg) -> fail msg + (Right iface) -> do + hasExpectedUsage iface `shouldBe` True + hasExpectedModule iface `shouldBe` True -- | `Usage` is the name given by GHC to TH dependency hasExpectedUsage :: Iface.Interface -> Bool From bea689e9b990b2341156c64c406adc7788688738 Mon Sep 17 00:00:00 2001 From: Hussein Ait-Lahcen Date: Wed, 17 Apr 2019 15:49:32 +0200 Subject: [PATCH 23/65] fix: better tests --- src/test/Stack/ModuleInterfaceSpec.hs | 19 ++++++++++-------- test/files/iface/Test.hs | 27 +++++++++----------------- test/files/iface/x64/ghc822/Main.hi | Bin 3158 -> 2178 bytes test/files/iface/x64/ghc844/Main.hi | Bin 3095 -> 2196 bytes test/files/iface/x64/ghc864/Main.hi | Bin 3122 -> 2223 bytes 5 files changed, 20 insertions(+), 26 deletions(-) diff --git a/src/test/Stack/ModuleInterfaceSpec.hs b/src/test/Stack/ModuleInterfaceSpec.hs index e425cdec59..f6d9aad9d5 100644 --- a/src/test/Stack/ModuleInterfaceSpec.hs +++ b/src/test/Stack/ModuleInterfaceSpec.hs @@ -12,6 +12,8 @@ import Test.Hspec (Spec, describe, it, shouldBe) type Version = String type Architecture = String type Directory = FilePath +type Usage = String +type Module = ByteString versions :: [Version] versions = ["ghc822", "ghc844", "ghc864"] @@ -33,14 +35,15 @@ deserialize d = do case result of (Left msg) -> fail msg (Right iface) -> do - hasExpectedUsage iface `shouldBe` True - hasExpectedModule iface `shouldBe` True + hasExpectedUsage "Test.h" iface `shouldBe` True + hasExpectedUsage "README.md" iface `shouldBe` True + hasExpectedModule "X" iface `shouldBe` True -- | `Usage` is the name given by GHC to TH dependency -hasExpectedUsage :: Iface.Interface -> Bool -hasExpectedUsage = - elem "Test.h" . fmap Iface.unUsage . Iface.unList . Iface.usage +hasExpectedUsage :: Usage -> Iface.Interface -> Bool +hasExpectedUsage u = + elem u . fmap Iface.unUsage . Iface.unList . Iface.usage -hasExpectedModule :: Iface.Interface -> Bool -hasExpectedModule = - elem "X" . fmap fst . Iface.unList . Iface.dmods . Iface.deps +hasExpectedModule :: Module -> Iface.Interface -> Bool +hasExpectedModule m = + elem m . fmap fst . Iface.unList . Iface.dmods . Iface.deps diff --git a/test/files/iface/Test.hs b/test/files/iface/Test.hs index 200e08f033..524ae0d0e4 100644 --- a/test/files/iface/Test.hs +++ b/test/files/iface/Test.hs @@ -1,27 +1,18 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} module Main where -import X -import GHC.Types -import Control.Monad -import Language.Haskell.TH +import GHC.Types +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax +import X #include "Test.h" main :: IO () main = putStrLn "Hello, World!" -curryN :: Int -> Q Exp -curryN n = do - f <- newName "f" - xs <- replicateM n (newName "x") - let args = map VarP (f:xs) - ntup = TupE (map VarE xs) - return $ LamE args (AppE (VarE f) ntup) - -data List a = Nil | Cons a (List a) - -x = Cons 4 (Cons 2 Nil) - -y = TRUE +f :: String +f = $(let readme = "README.md" + in qAddDependentFile readme *> (stringE =<< qRunIO (readFile readme))) diff --git a/test/files/iface/x64/ghc822/Main.hi b/test/files/iface/x64/ghc822/Main.hi index 86162d7912828e6544036d02ec894862399279b9..32ebe107a8807d0a628f8e26152483263c4f170b 100644 GIT binary patch delta 741 zcmca6(IhxQ!H2h;yc^53HU)Nxoa{?AN%0xINAf z&-0r)GD@`6ZMgeU;aF_t-%vfOSdcMQ?2|=j|=L6VdTq`P`B% z5Ght5B{lgkqn!fCCh5Hkr@k?LsUz99a=J^Xs7C=r5!ex%qnZ9Q)iZGdg@Sy z*ae7vp?p0coeRV%ntwLWi+{vF>CmGX=Z@mQL*Re}N&v&R^x5OhjP>hI{1Ft{{^MKB zPEc^Of;6%kGcd2-p!!Q7bmrwdff;)XY}kT9IzX`+&f43+PzPiKMP^5+EnSlvxoT5p zyWYvwPpv^}fPl3M7|fbq!$ zbrb8#$;s@Bj-c=c1CV!Br@sHJT2))7^n(W|^Hu)@ps! zq}HgRYHh@}e;~1~Nl{}%8qHab{1u6}WKV_8$ux#8WpTGPwzS598N``c5O zzFV8#=ijfscjKM)!o9?y!RueED^mwfI?f!1on;3Za#k*$zA<1R5*LS$4Ieu`5ON9l zj3ZS7C?zt&F_}?Gj7Vn0ct$uGF@X^&j7Vj~L`I}BViF_L88H%T3gcujB9jqQ8Ii?^ zY(`MajKZcdVmb)a_9!EAK#U{IrA9ofm#G(=cl{@RpH_CT+L5(mv(mk!3wlN`9Bp$3 zj%-+PQ`$Wvy<Q>o_^KV$TxBk=r^X9fY zYZhHw;OtB>o$J}p>c4bl{q$R3b-H?|M!L@D>t&gRz0&2s(Vm|*hrfJy=%vY@MK~)C zyOvNS3=wLCJfXk)+?)G0yzO|V@AI-X3wK-ZTI-2BhfpSz2;0m(vr=fU62cSo77$`= z3kl~D1_+x88%?^E){TTMCa>6}=hGS?Y$Du52p@hE8)$_e*uocbSV#zc4>#6>pHc$kjEE4-uIs1ThjB7}XA5Ikgru7XCj;G;tVA?zTB zJ~{;&r-RDSZRCIxV7VEf89iVnrX-UB7c<- zon`)>CmON*-uT9{)@$_zE%~AHQ#t*mal|wLx5{|ZVnD{m;6n%v8`t~$;?<7EyZz}I z`}=SBtdiZ4GeT3!U~`nDn8`-a#Kf1V~Z;#v%V4|1F&6*K}>ps zt+ZMW5esWO>^Ls_LcXKt*pJhmTRh|X@$I*9lM%q43>%y%H4J(ox!0A|(OWdjdEw%6 z>D5WlBeuN+8R|zy`i~pB%5eJ8?+4`WYsE)PxuOhG)BoJ;>){hRV34hslb-7Mt7_4` zv)SHcZr#uZOv@NBUVmbtW^Oi<={vSDWaQQWU52sN!GehzachAPBd&wKD;U{03=GXCi+Cxus72wpw=3qe3M3-L(HHiVd6M%$@%4PiWfFj^>1LDD08qF|unIdbd65vaN!GPou zG^v#(?21mbs`n{muuy!ZF?D=xC0`Sf zHG$1b5*sgSzreb0r|5yOmnEH06A97yQd`Wp`p}{(*0t3Ch-2zn1e36N!m1jnW^9&# sh0RnfM#GfGQdZ1&Otr)=OMI^8$sZ-MV;>b`JIYByuBKMeWCp~40lMiMUjP6A diff --git a/test/files/iface/x64/ghc844/Main.hi b/test/files/iface/x64/ghc844/Main.hi index ceb1b6ba1f5d81361adcc3558eda99c4e54a1a0a..19f78d0e50f2d438cc6805557c33dc8340e70959 100644 GIT binary patch delta 764 zcmbO(F-35Kf+L#}0|V!(RspLxxyKgmd8>Tgr^iHWKlazK3yObo0O`y}g`Kt?eGF$avn$qi$1!5DB6 z9+(I(jKK$E@WU7aFoqzA!2-lWForOQ!4AYCKws#93>=t4k(~m{Xj%81GCH$-V;`H+UNbhUB;4hW|l5U2T(6-IcskNLmiME%)l@^LT%}q z+{jg%GTZe|u6}9_QUe66vp~KC1_Drh7lT!s`m@`={W$d6jW{NA0SrLyVUU8b!Mb2fAPtt21_^*;1VqSyct9XK*@Hual_e>$ zICb(u4(G|gI6@}ZahmgRyCjw*>iOp9uZq~p(-B(23iN``h@8wV;hK_uGTMecVFrnA6d}7kZJe}3iqr3fH{TD)hO60e$^aJ30%MT@GF=98 z7{FXg*LN};2 zs@0ZUoooK$wFB<{(2gUi(ON(C0}8d1WH#4l2b`~$=bU&oAr{J^Cl*4bOyJ74Lw}C+ zf7ek_wDGCOCl^A?H(dPWufyBE8XRt#8>*W-U#5i^_^nV9RBZ`X;l7v~YIAi-TTXR- za3enBRXd~?c=k4xG9_s(4QA}Q)?PD0iy0>vsIU@WYTPsM(Q4nVp9^lb7D?(g&_^-c zN9@DLZ<(?kdq-|Je)j$4_41cM6DWi}NB8U}9qOuYe;f|Ga+vG;f`3mnyLSDK61dkS z{mX)eUbNIP(>U1e|FMo69<4iv8t5*4XF*ap|0uToiMEw6HLqR4f6 zD%nTbN7za|WZA>Tc^zkkcs>^A_j;<>b?jQUQrThkW;tUbFG-!iRRQ;yqF8s9XFknI z9P1U@V-X%6w`xmNZnGQ>N`k1ygt#(ot@ES@0-_L-gOZ-KI4!A3ZdZz#f-I-XHu3G@ z7EzF6N)=O+VOP2BLO7&^7K)xVXBiZKNoG0xfY)Faq%`j5@EOc^u;Jn2iBl0ik*!H yZFGU^)ESFE95+sBfi2=XZ*B}nbZB!+!LoZo4Ehi*(c|dfvx?m&kuG(Wlk diff --git a/test/files/iface/x64/ghc864/Main.hi b/test/files/iface/x64/ghc864/Main.hi index 9ebebec5cb7447661390cb6e409fd26e6296f53e..83fc501533dd9fd18b9091aa8e81e503109c23cb 100644 GIT binary patch delta 803 zcmdlav0iY3f+L$P0|V<{1}I=;V0iiAYjf?6%d*G1inL{>O4^jLd*yK*SLCt%cj4=b zANRQ3_j7u-UfuDhd;OeqWmN`Q6BA82^nv;qm>5_m&XcTX0vW{hdNCpV161!KTP zcwi#DFa{rt!4G2yz!-uc1`7}i!5G3I20IXo05PjA&@_;(Alo@7Z(tO&2C+nK%IE$~ z@z{Igk;!4R1|6-_KrtWyNr~O{xA|AR)4OJ!+mcf=7JrxzmSJE8QsR>tne41VMoaiz zGT3{`IDdJFCS$THj{ryv2tbr%=hLryPt9&rdmdhx?KgYZbg&G>L7U^5{xj7xaRP;c zfY=p?9f8;dh<%}aJs_P6#3`D8HqVQH#6RiKqZsFo;=n`TFa%04Ffh*eQp)v1Ich4i z(v4d`PTHIRg*0nCh)7{zmRZ7k!fHSgUt_)014O`+6AL&pL9!rcGe}K7 z&n_)44Pt_$2t>$$ct9XKIhjL)l_e>$ICb(K4(G|DoFS8Ea+*(O;S!##%Vj*dkSlMp zHn-B`ByPhDai7Gz^wPxiR6UQx;_TF%9K8?^J)g`Zh)E0zIHdJF^GZ^S@)C2P>KN0Y Y3{I7jBH#R!(wtPN09$ZLQD$B`0E#rNCjbBd literal 3122 zcma)732YQq7=F9m?RIIm94%Kl1d9}q9a`x@I234sE%uTkmOu)_?zo+@o!!pPmbRS1 zKw~3NBM`$`5TY2lL4`mOw;Q!6++m^$~-~KcI{r~TKZ{C{z zKIvg$ve0`FaVl{paXN9#B*tueNYKf|SeN$`oqa!BysCDFB~Y?%cgp;G3FpUdUw^d9 zb#qk%^ilfJGcEx?#T4jCEF8v*wDwckQy;Fi=k%}448~r@rcGl4}z1~@n}V% zL_~qD>oLh#H9lapT4qLllJ%B*mK3Ll(CDi1Dewh8*;A5~DZ#=mQ-w zSRL~4#ypr6Ghj`a3;OfsAqRNyb%aR9+#G|Jb*jR4%#Sr87nmU*vy?TStiL&T+?4!4 z(+OXSqbjO%lz}1;K|at1YM2P&E{$!HM1D&v}pf@q1tgBTIfO!_oAKSMjPKF2+(p<$})EE$<~ zH6H7keaF&U=C+Q?Fa9jpesW({=rEi%avicRnum{qF27}4WI3Uo?NY7#x2sbVO20!0 z-H+Dm%^}v<_Ku$m*3{*leofr5|Fzu+u~YB3=8&!%97hJPs$28uVwGju@fAP}A9(Zt zgv`+!<(BWXettDO+vS+@PFD1_d(@j*u%MT$?;T*)pPi(` zL=h1JKK~hNHarvpD0Kzpbt1tGV(f?#mE2A2cWhI~4&~n-|Fu3GVCxix3F#I#)7!M1 z%y>5-kFk0-cwx%5i}wp+gt~z{O7t6(8rX&-2m4R(BCc-Jyx4M2V`7Jx{s%7{FL$6g znQcA{u5U2K_cvnar}aI0&EBx4vFL7TQd1I6Fn-=_OHdOrFp$2S$*->XD}UHOhr4^? z*`!OQI9qUR#bXy9kzZuvSA$GgJ?o7JNY@OJYbjjSeSIPtPGaAP24}y=w3j0q1RB#I zy^4NBpzB(A%&>+J41^CCWT_Bk#Sob#zgaewgpCeSRmB=-s*oWJ6e3yE#Gn)oXzh`t zKv1f5rU~iv$3xnB%iPXse!u3_%AA9QOaa#fCqR;NVWHaeuZHNUF+{E@}Bd%~v#dDHffd2&6HqRCp# zGfNh!eox5F6WctNSR9JrqTBQRieJW!28!2B#ZrarRsA83R>#M!LN4K{Dk6u+SmFdp z4a$DL({?>&LUZLfKsH8FBvp3feg(CGEw@k@Rqd7nT61zo9dExX$zG*cb?1qSR~TOt z;E;BK8^)06l}1%-l7hy;mLbXGrD{zm(l@zCrTrI1D2iXBt@Q}5khe?<7L7G#V4a@| zeIg)63=7fjkgC=ca5Epk#E*d`PmY`y3r)pqM-|9?w_ Date: Wed, 17 Apr 2019 18:12:01 +0200 Subject: [PATCH 24/65] include x32 tests --- src/test/Stack/ModuleInterfaceSpec.hs | 47 +++++++++++++--------- test/files/iface/x32/Main.hs | 7 ++++ test/files/iface/x32/ghc7103/Main.hi | Bin 0 -> 827 bytes test/files/iface/x32/ghc802/Main.hi | Bin 0 -> 1067 bytes test/files/iface/x32/ghc822/Main.hi | Bin 0 -> 1217 bytes test/files/iface/x32/ghc844/Main.hi | Bin 0 -> 1168 bytes test/files/iface/x32/run.sh | 16 ++++++++ test/files/iface/{Test.hs => x64/Main.hs} | 0 test/files/iface/{ => x64}/README.md | 0 test/files/iface/{ => x64}/Test.h | 0 test/files/iface/{ => x64}/X.hs | 0 test/files/iface/{ => x64}/shell.nix | 6 +-- 12 files changed, 54 insertions(+), 22 deletions(-) create mode 100644 test/files/iface/x32/Main.hs create mode 100644 test/files/iface/x32/ghc7103/Main.hi create mode 100644 test/files/iface/x32/ghc802/Main.hi create mode 100644 test/files/iface/x32/ghc822/Main.hi create mode 100644 test/files/iface/x32/ghc844/Main.hi create mode 100755 test/files/iface/x32/run.sh rename test/files/iface/{Test.hs => x64/Main.hs} (100%) rename test/files/iface/{ => x64}/README.md (100%) rename test/files/iface/{ => x64}/Test.h (100%) rename test/files/iface/{ => x64}/X.hs (100%) rename test/files/iface/{ => x64}/shell.nix (80%) diff --git a/src/test/Stack/ModuleInterfaceSpec.hs b/src/test/Stack/ModuleInterfaceSpec.hs index f6d9aad9d5..96c8c309fb 100644 --- a/src/test/Stack/ModuleInterfaceSpec.hs +++ b/src/test/Stack/ModuleInterfaceSpec.hs @@ -7,6 +7,7 @@ import Data.Foldable (traverse_) import Data.Semigroup ((<>)) import qualified Stack.ModuleInterface as Iface import Stack.Prelude hiding (Version) +import System.Directory (doesFileExist) import Test.Hspec (Spec, describe, it, shouldBe) type Version = String @@ -15,29 +16,37 @@ type Directory = FilePath type Usage = String type Module = ByteString -versions :: [Version] -versions = ["ghc822", "ghc844", "ghc864"] +versions32 :: [Version] +versions32 = ["ghc7103", "ghc802", "ghc822", "ghc844"] --- TODO: add x32 when generated -archs :: [Architecture] -archs = ["x64"] - -directories :: [FilePath] -directories = (<>) <$> ((<> "/") <$> archs) <*> versions +versions64 :: [Version] +versions64 = ["ghc822", "ghc844", "ghc864"] spec :: Spec -spec = describe "should succesfully deserialize interface from" $ traverse_ deserialize directories - -deserialize :: Directory -> Spec -deserialize d = do +spec = describe "should succesfully deserialize x32 interface for" $ do + traverse_ (deserialize check32) (("x32/" <>) <$> versions32) + traverse_ (deserialize check64) (("x64/" <>) <$> versions64) + +check32 :: Iface.Interface -> IO () +check32 iface = do + hasExpectedUsage "some-dependency.txt" iface `shouldBe` True + +check64 :: Iface.Interface -> IO () +check64 iface = do + hasExpectedUsage "Test.h" iface `shouldBe` True + hasExpectedUsage "README.md" iface `shouldBe` True + hasExpectedModule "X" iface `shouldBe` True + +deserialize :: (Iface.Interface -> IO ()) -> Directory -> Spec +deserialize check d = do it d $ do - result <- Iface.fromFile $ "test/files/iface/" <> d <> "/Main.hi" - case result of - (Left msg) -> fail msg - (Right iface) -> do - hasExpectedUsage "Test.h" iface `shouldBe` True - hasExpectedUsage "README.md" iface `shouldBe` True - hasExpectedModule "X" iface `shouldBe` True + let ifacePath = "test/files/iface/" <> d <> "/Main.hi" + exists <- doesFileExist ifacePath + when exists $ do + result <- Iface.fromFile ifacePath + case result of + (Left msg) -> fail msg + (Right iface) -> check iface -- | `Usage` is the name given by GHC to TH dependency hasExpectedUsage :: Usage -> Iface.Interface -> Bool diff --git a/test/files/iface/x32/Main.hs b/test/files/iface/x32/Main.hs new file mode 100644 index 0000000000..6fd36ba675 --- /dev/null +++ b/test/files/iface/x32/Main.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +import Language.Haskell.TH.Syntax + +main :: IO () +main = $(do + qAddDependentFile "some-dependency.txt" + [|pure ()|]) diff --git a/test/files/iface/x32/ghc7103/Main.hi b/test/files/iface/x32/ghc7103/Main.hi new file mode 100644 index 0000000000000000000000000000000000000000..58f3c54d70dbe375569fefd2d480d60374097f56 GIT binary patch literal 827 zcmZQz{B@222v~sF9Ec5p*Z_!)ftZPjfr0TYkO2aW4Bub!{f$z}6`Pl-TeADW7f#26 zp1Uh%X4;+Rxb)>fhtXB3=YriKVl`Jv?eo4^N4_WkYugDn8E6m#12c#K*~7rf01^OU zHYm*wV{kwPIH5Ebl;(!gJV2Tih1T=fGBk6Ly-|E$iOgX#qr0#^49%ed|KpO?sq8yB+9rDL@Z-qytznOg4uK4 z)7SPJ8_mp*Oa^HHhJ()mh7~}{7svrc76>q2VaT+b^~2Zp&vCgFK8EN!aUi=<0K`6^ zQe;s9D2F9CF%#r+5Mc2|VkadQgM0`A9O)U!x&=jSiPsXQ$@mKvXhtxO+J3IU$VV1o7Q+@)JR!0|LU%`FSNp`8j%y1qC^o z$%!SIWiV^GT@p(Y^;|PcGE$2miWwk6zWI6inV_fu0U@xekjjEoJ=en0#GK3$Py~Pg z56CX})V$Q9%w$kxf`F7yVqSV_VtT5c2gIFvAs%|cm3bwJpr`@?_JE?)oYEASBft&@ HnO+P4UB#`N literal 0 HcmV?d00001 diff --git a/test/files/iface/x32/ghc802/Main.hi b/test/files/iface/x32/ghc802/Main.hi new file mode 100644 index 0000000000000000000000000000000000000000..bbfae7e38744fa555d2989edd1bb74d0f9b9ab8f GIT binary patch literal 1067 zcmZ8fO-NKx6u$Fxbf)=n{K+C|q8c!vc}Q5biOBW5rzFpc8m9nC}vG%I=vfv7fzv9KGu%23npH1;k--G&w! z>M^t!6swg03xK82epc&8E4O!uWwN>WTah0tAL(~>LxkQy*_@lZe&+D``};4td!+UeA#!AjrG=JDQZ*|QrhV1(c4dU~UZ%QPHx`;X1N zviW>ywmibmGs2C2tJ+@Xsq~Kie!1_S(7%8u%B`Uja?mquLRQKzyH{vD-ULV4~{(;^L)Ldy@V{G!{f{1^G$PcYp z4+u$|2%`U&~kX`0NlibR<*}$A@r;GNVzd`lE529>T+DJRu2;`eQXL>8kk3=Jik zsU;A1gF}j}hGpnPB`B}gK}`$RakG`&WE)al6RO*b0no7vyM4h|<6?qcSE>@))LPBkN2zAJm7$_XPRw gw9Ev2T!_Lhl}f3Ic|e;MCNPWGeM}80k(5OL0Lx_7H2?qr literal 0 HcmV?d00001 diff --git a/test/files/iface/x32/ghc822/Main.hi b/test/files/iface/x32/ghc822/Main.hi new file mode 100644 index 0000000000000000000000000000000000000000..c3c1ae8ad12fb25d206e3549724a7e8211d0b23b GIT binary patch literal 1217 zcmZ8fT}TvB6uvvDyPK=7e`ywCq)EgMvIs3yR_gkPtL1JI3E{YV-5s5s8E5b2`Vs~e zB=*olP!VL16^Wq*+KX%uC0RsK34zd)P)S4~RHD#5GkbOIgKy@W@0@$?nR72Pt-L`L zDU>eC3QA{!+!chlF#XVBLTItXQaxSqF56pdk-wNntm92{RRyZ~S^VCMss3SC<;|X| zP9^VmQRb=hS@*l!^ui`PN~P;LsIdheu#;|~G{c3E8B7qCOs1?%Y-J*y2^$j`OsucU zVve1OY$kG;$OQqt*NtVqBmL)f9qSm zI6CK?y)^pp)9~{jMhO0{@aJ01-L}O-*T;PwySb6IY9plAAK%$>`#|9PlXk6p#78slsqM&jKO=R@Nsmsx4d+J?NIxp$!ojlp;6qL zx_a{0hb3n$I<(yPdj1Z$rd9gjOo$tsC|j|gxc+|OcxXmFnC68AG=VEiy*!A{>T@W5 zRc@Oe`&!a@c+b+rxxcUzfb*mdKSdf<7W$!|Fn#-wSasu%=g{hGaUc_QES!c0HzAR! zZ<7?zd)=NeiW2XXupq+U0#ZClx=V<_qyX8$kl)dzD8xZR4j1p_;Q|9J5KuLd-Qjdm zCOC*SM=%Ui1=tA=tCB#lBP2w6u_PHbveq}$@O6?Rz-R#$Fse5;&8<;nqA3!8R8=L> zFA(tz>nFWdAOi0eNeIJm06Dr<7nS`)(RjKv!s_O4iZlkWOhf|b3NR{p6j>4BIslAH zz5x~U?!KrXZ6w?DO6^#Shzc8-4Z5z!GS);tTrz+iyvA1E9rI(A{Fe)bn?=HM_4VMj z2CVo>&K{$@cA@{nRwM>`-4W>g4bcZ^^e`iUf`6tOVhU<{r2HSpd6nF#D^ anU85$iUwFs{WM??)|a)EXdWdHmGD1*o$bv4 literal 0 HcmV?d00001 diff --git a/test/files/iface/x32/ghc844/Main.hi b/test/files/iface/x32/ghc844/Main.hi new file mode 100644 index 0000000000000000000000000000000000000000..19b0f70fcc1b07b04bda742a5ac0128a546e593a GIT binary patch literal 1168 zcmY*XYe*DP6uvv{uDh+4tLa8%P#BW6(?dfu3{%%vZbphJRy4bNogLhrnPz8A|5Orc zNrfTVCgK`BRHPt76ru884=hNKe%KF@Fz{ETy+gZab|=>lzB%8V?{d$%=U$}w{SFam z2{Q@z5~hbqbs|Jb2Z@wdBfs;d3R!6w~@epBlBozJspzn1Q}xU{S1@_bH- z{^a)BJ+`soQ&$$>^aX5Fv$d}W{fV8w*nNGux6K`+&5xF1dau6yp59(I6+8#~Y7&r+ z1Pb&T_&_I03h6^xu%aLd!eCOBQ59=d@!yJ8Gcl@Ir;7Eehy?)!&8mn4p(l(dU44S4 z!X@dP$;AUB)2@NhjIqI+!}k1KmrCb*kF|2(mI+;J$-aib(;!4VSTb|x)rs%Fx@ z48Ko4orf|)ma_ju%?rJ;x_W<0lXoD=**}FSQWE(H1wt<&CbSZ|!deVRJ|YL&N!Un8 z6Uu}Q5T9*)>VHs|lAMv>Ryp(}u#MatLGOa);VohA=s@@ULLj?z60(%?A#>hxKju|d zcWck`biLLw(FLUu@u*bY^-Ji2GKV&l)siwd{pXm0ZcQ7i3c?Zs>V)pvID%JVAV11A zl30zn!(Bh^*?(Vdb*)1+AJ0I8s}NqPl!-8uUK7I!OE_x13Cm(jKcCl=+EwHD=&f`mDiFPEI94A0UPjiP#v&0s^)&#>6mAY&ft_#&5VQf;~@ nG(Nhbh%RsBWd@!jAnLe;J${$Er!rTlq4s7>mL Date: Thu, 18 Apr 2019 11:46:20 +0300 Subject: [PATCH 25/65] Ensure cache occurs even with interrupts --- subs/pantry/src/Pantry/Hackage.hs | 31 ++++++++++++++++++++++++++----- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index eecf247237..ed4cd5bfc9 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -117,12 +117,36 @@ updateHackageIndex mreason = do HS.checkForUpdates repo maybeNow case didUpdate of - HS.NoUpdates -> logInfo "No package index update available" + HS.NoUpdates -> do + x <- needsCacheUpdate tarball + if x + then do + logInfo "No package index update available, but didn't update cache last time, running now" + updateCache tarball + else logInfo "No package index update available and cache up to date" HS.HasUpdates -> do logInfo "Updated package index downloaded" updateCache tarball logStickyDone "Package index cache populated" where + -- The size of the new index tarball, ignoring the required + -- (by the tar spec) 1024 null bytes at the end, which will be + -- mutated in the future by other updates. + getTarballSize :: MonadIO m => Handle -> m Word + getTarballSize h = (fromIntegral . max 0 . subtract 1024) <$> hFileSize h + + -- Check if the size of the tarball on the disk matches the value + -- in CacheUpdate. If not, we need to perform a cache update, even + -- if we didn't download any new information. This can be caused + -- by canceling an updateCache call. + needsCacheUpdate tarball = do + mres <- withStorage loadLatestCacheUpdate + case mres of + Nothing -> pure True + Just (FileSize cachedSize, _sha256) -> do + actualSize <- withBinaryFile (toFilePath tarball) ReadMode getTarballSize + pure $ cachedSize /= actualSize + -- This is the one action in the Pantry codebase known to hold a -- write lock on the database for an extended period of time. To -- avoid failures due to SQLite locks failing, we take our own @@ -152,10 +176,7 @@ updateHackageIndex mreason = do (offset, newHash, newSize) <- lift $ withBinaryFile (toFilePath tarball) ReadMode $ \h -> do logInfo "Calculating hashes to check for hackage-security rebases or filesystem changes" - -- The size of the new index tarball, ignoring the required - -- (by the tar spec) 1024 null bytes at the end, which will be - -- mutated in the future by other updates. - newSize :: Word <- (fromIntegral . max 0 . subtract 1024) <$> hFileSize h + newSize <- getTarballSize h let sinkSHA256 len = takeCE (fromIntegral len) .| SHA256.sinkHash case minfo of From 913ec1968ff99b53c841ae90be57d718d458f446 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 18 Apr 2019 14:01:56 +0300 Subject: [PATCH 26/65] Take a lock on the Pantry database for all actions (fixes #4471) --- subs/pantry/src/Pantry/SQLite.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry/SQLite.hs b/subs/pantry/src/Pantry/SQLite.hs index d2413c7e27..d273a34cdd 100644 --- a/subs/pantry/src/Pantry/SQLite.hs +++ b/subs/pantry/src/Pantry/SQLite.hs @@ -29,8 +29,15 @@ initStorage description migration fp inner = do forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig withSqlitePoolInfo (sqinfo False) 1 $ \pool -> inner $ Storage - { withStorage_ = flip runSqlPool pool - , withWriteLock_ = withWriteLock fp + -- NOTE: Currently, we take a write lock on every action. This is + -- a bit heavyweight, but it avoids the SQLITE_BUSY errors + -- reported in + -- + -- completely. We can investigate more elegant solutions in the + -- future, such as separate read and write actions or introducing + -- smarter retry logic. + { withStorage_ = withWriteLock fp . flip runSqlPool pool + , withWriteLock_ = id } where wrapMigrationFailure = handleAny (throwIO . MigrationFailure description fp) From 4b061a3693e058b327d807f6123145aef0c58e55 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 22 Apr 2019 08:49:30 +0300 Subject: [PATCH 27/65] Switch to a LastPerformed table This leverages a single table and upsert, so that we update records in place, and can reuse this table for additional tracking of last-performed actions in the future. --- src/Stack/Storage.hs | 17 +++++++++++------ src/Stack/Types/Cache.hs | 11 +++++++++++ 2 files changed, 22 insertions(+), 6 deletions(-) diff --git a/src/Stack/Storage.hs b/src/Stack/Storage.hs index 6ff90e3442..eceb353e29 100644 --- a/src/Stack/Storage.hs +++ b/src/Stack/Storage.hs @@ -154,9 +154,11 @@ CompilerCache UniqueCompilerInfo ghcPath --- History of checks for whether we should upgrade Stack -UpgradeCheck +-- Last time certain actions were performed +LastPerformed + action Action timestamp UTCTime + UniqueAction action |] -- | Initialize the database. @@ -553,10 +555,13 @@ saveCompilerPaths CompilerPaths {..} = withStorage $ do -- | How many upgrade checks have occurred since the given timestamp? upgradeChecksSince :: HasConfig env => UTCTime -> RIO env Int -upgradeChecksSince since = withStorage $ count [UpgradeCheckTimestamp >=. since] +upgradeChecksSince since = withStorage $ count + [ LastPerformedAction ==. UpgradeCheck + , LastPerformedTimestamp >=. since + ] -- | Log in the database that an upgrade check occurred at the given time. logUpgradeCheck :: HasConfig env => UTCTime -> RIO env () -logUpgradeCheck time = withStorage $ do - deleteWhere ([] :: [Filter UpgradeCheck]) - insert_ $ UpgradeCheck time +logUpgradeCheck time = withStorage $ void $ upsert + (LastPerformed UpgradeCheck time) + [LastPerformedTimestamp =. time] diff --git a/src/Stack/Types/Cache.hs b/src/Stack/Types/Cache.hs index 752d4c84ab..70087213da 100644 --- a/src/Stack/Types/Cache.hs +++ b/src/Stack/Types/Cache.hs @@ -3,6 +3,7 @@ module Stack.Types.Cache ( ConfigCacheType(..) + , Action(..) ) where import qualified Data.Text as T @@ -43,3 +44,13 @@ instance PersistField ConfigCacheType where instance PersistFieldSql ConfigCacheType where sqlType _ = SqlString + +data Action + = UpgradeCheck + deriving (Show, Eq, Ord) +instance PersistField Action where + toPersistValue UpgradeCheck = PersistInt64 1 + fromPersistValue (PersistInt64 1) = Right UpgradeCheck + fromPersistValue x = Left $ T.pack $ "Invalid Action: " ++ show x +instance PersistFieldSql Action where + sqlType _ = SqlInt64 From 182daadfa71b29a990fac007b0eeedc4fc25651c Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Mon, 22 Apr 2019 15:44:14 +0300 Subject: [PATCH 28/65] Read snapshot locations without content, optimize exact locs --- src/Stack/Lock.hs | 86 +++++++++++++++++++++++++-------------- subs/pantry/src/Pantry.hs | 64 ++++++++++++++++++++++++++--- 2 files changed, 114 insertions(+), 36 deletions(-) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index e37f527357..4e4556a197 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -75,23 +75,31 @@ instance FromJSON (WithJSONWarnings (Unresolved CompletedSnapshotLocation)) wher c <- o ..: "compiler" pure $ Unresolved $ \_ -> pure $ CSLCompiler c -data LockedLocation a b = LockedLocation - { llOriginal :: a - , llCompleted :: b - } deriving (Show, Eq) +data LockedLocation a b + = LockedExact b + | LockedCompleted a + b + deriving (Show, Eq) instance (ToJSON a, ToJSON b) => ToJSON (LockedLocation a b) where - toJSON LockedLocation{..} = - object [ "original" .= llOriginal, "completed" .= llCompleted ] + toJSON (LockedExact o) = + object ["exact" .= o] + toJSON (LockedCompleted o c) = + object [ "original" .= o, "completed" .= c ] instance ( FromJSON (WithJSONWarnings (Unresolved a)) - , FromJSON (WithJSONWarnings (Unresolved b))) => + , FromJSON (WithJSONWarnings (Unresolved b)) + ) => FromJSON (WithJSONWarnings (Unresolved (LockedLocation a b))) where - parseJSON = - withObjectWarnings "LockedLocation" $ \o -> do - llOriginal <- jsonSubWarnings $ o ..: "original" - llCompleted <- jsonSubWarnings $ o ..: "completed" - pure $ LockedLocation <$> llOriginal <*> llCompleted + parseJSON v = withObjectWarnings "LockedLocation" (\o -> lockedExact o <|> lockedCompleted o) v + where + lockedExact o = do + exact <- jsonSubWarnings $ o ..: "exact" + pure $ LockedExact <$> exact + lockedCompleted o = do + original <- jsonSubWarnings $ o ..: "original" + completed <- jsonSubWarnings $ o ..: "completed" + pure $ LockedCompleted <$> original <*> completed data LockedPackage = LockedPackage { lpLocation :: !(LockedLocation RawPackageLocationImmutable PackageLocationImmutable) @@ -129,7 +137,8 @@ instance FromJSON (WithJSONWarnings (Unresolved SingleRPLI)) where instance FromJSON (WithJSONWarnings (Unresolved LockedPackage)) where parseJSON = withObjectWarnings "LockedPackage" $ \o -> do - let unwrap (LockedLocation single c) = LockedLocation (unSingleRPLI single) c + let unwrap (LockedExact c) = LockedExact c + unwrap (LockedCompleted single c) = LockedCompleted (unSingleRPLI single) c location <- jsonSubWarnings $ o ..: "location" lpFlags <- fmap unCabalStringMap $ o ..:? "flags" ..!= Map.empty lpHidden <- o ..:? "hidden" ..!= False @@ -192,6 +201,7 @@ lockCachedWanted stackFile resolver fillWanted = do lockExists <- doesFileExist lockFile if not lockExists then do + logDebug "Lock file doesn't exist" (snap, slocs, completed) <- loadAndCompleteSnapshotRaw resolver Map.empty let compiler = snapshotCompiler snap @@ -201,15 +211,17 @@ lockCachedWanted stackFile resolver fillWanted = do let pkgs = mapMaybe (uncurry $ maybeWantedLockedPackage wanted) (completed <> prjCompleted) snapshots <- for slocs $ \(orig, sloc) -> do - compl <- case sloc of + case sloc of SLFilePath fp -> do (sha, size) <- shaSize (resolvedAbsolute fp) - pure $ CSLFilePath fp sha size + pure $ LockedCompleted orig (CSLFilePath fp sha size) SLCompiler c -> - pure $ CSLCompiler c - SLUrl url blobKey -> - pure $ CSLUrl url blobKey - pure $ LockedLocation orig compl + pure $ LockedExact (CSLCompiler c) + sl@(SLUrl url blobKey) -> + let csurl = CSLUrl url blobKey + in if toRawSL sl == orig + then pure $ LockedExact csurl + else pure $ LockedCompleted orig csurl liftIO $ Yaml.encodeFile (toFilePath lockFile) $ Locked { lckStackSha = stackSha , lckStackSize = stackSize @@ -222,9 +234,10 @@ lockCachedWanted stackFile resolver fillWanted = do lmt <- liftIO $ getModificationTime lockFile unresolvedLocked <- loadYamlThrow parseJSON lockFile locked0 <- resolvePaths (Just $ parent stackFile) unresolvedLocked - let pkgLocCache = Map.fromList - [ (llOriginal ll, llCompleted ll) - | ll <- map lpLocation $ Map.elems (lckPackages locked0) ] + let pkgLocCache = Map.fromList $ + map (lockPair . lpLocation) $ Map.elems (lckPackages locked0) + lockPair (LockedExact compl) = (toRawPLI compl, compl) + lockPair (LockedCompleted orig compl) = (orig, compl) sha0 = lckStackSha locked0 size0 = lckStackSize locked0 result <- liftIO $ checkOutdated stackFile lmt size0 sha0 @@ -232,15 +245,21 @@ lockCachedWanted stackFile resolver fillWanted = do case result of Right () -> (False, sha0, size0) Left (sha, sz) -> (True, sha, sz) - let lockedSnapshots = Map.fromList - [ (orig, compl) - | LockedLocation orig compl <- NE.toList (lckSnapshots locked0) - ] + let lockedSnapshots = Map.fromList $ map toPair $ NE.toList (lckSnapshots locked0) + toPair (LockedExact compl) = (toRawSL' compl, compl) + toPair (LockedCompleted orig compl) = (orig, compl) + toRawSL' (CSLCompiler c) = RSLCompiler c + toRawSL' (CSLUrl url blobKey) = toRawSL (SLUrl url blobKey) + toRawSL' (CSLFilePath fp _ _) = toRawSL (SLFilePath fp) layers <- readSnapshotLayers resolver (outdated, valid) <- fmap partitionEithers . forM (NE.toList layers) $ \(rsloc, sloc) -> liftIO $ - let outdatedLoc = Left . LockedLocation rsloc - validLoc = Right . LockedLocation rsloc + let toLockedSL _orig compl@(CSLCompiler _) = LockedExact compl + toLockedSL orig compl@(CSLUrl url bk) + | toRawSL (SLUrl url bk) == orig = LockedExact compl + toLockedSL orig compl = LockedCompleted orig compl + outdatedLoc = Left . toLockedSL rsloc + validLoc = Right . toLockedSL rsloc in case Map.lookup rsloc lockedSnapshots of Nothing -> case sloc of @@ -262,10 +281,13 @@ lockCachedWanted stackFile resolver fillWanted = do let lockIsUpToDate = not syOutdated && null outdated if lockIsUpToDate then do + logDebug "Lock file exist and is up-to-date" let compiler = lckCompiler locked0 pkgs = flip Map.mapWithKey (lckPackages locked0) $ \nm lp haddocks -> do run <- askRunInIO - let location = llCompleted (lpLocation lp) + let location = case lpLocation lp of + LockedExact c -> c + LockedCompleted _ c -> c common = CommonPackage { cpName = nm , cpGPD = run $ loadCabalFileImmutable location @@ -281,6 +303,7 @@ lockCachedWanted stackFile resolver fillWanted = do (wanted, _prjCompleted) <- fillWanted pkgLocCache compiler pkgs pure wanted else do + logDebug "Lock file exist but is not up-to-date" (snap, _slocs, completed) <- loadAndCompleteSnapshotRaw resolver pkgLocCache let compiler = snapshotCompiler snap @@ -306,7 +329,10 @@ lockCachedWanted stackFile resolver fillWanted = do , lpFromSnapshot = dpFromSnapshot dp , lpGhcOptions = cpGhcOptions common , lpHidden = dpHidden dp - , lpLocation = LockedLocation rpli pli + , lpLocation = + if toRawPLI pli == rpli + then LockedExact pli + else LockedCompleted rpli pli } ) shaSize fp = do diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 43ead38f6e..e3ee6eaf94 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -69,6 +70,7 @@ module Pantry , RawPackageLocation (..) , PackageLocation (..) , toRawPL + , toRawPLI , RawPackageLocationImmutable (..) , PackageLocationImmutable (..) @@ -198,7 +200,7 @@ import RIO.PrettyPrint import RIO.Process import RIO.Directory (getAppUserDataDirectory) import qualified Data.Yaml as Yaml -import Data.Aeson.Extended (WithJSONWarnings (..), Value) +import Data.Aeson.Extended (unWarningParser, (...:?), WithJSONWarnings (..), Value) import Data.Aeson.Types (parseEither) import Data.Monoid (Endo (..)) import Pantry.HTTP @@ -963,7 +965,9 @@ loadSnapshot loc = do type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) type CompletedSL = (RawSnapshotLocation, SnapshotLocation) --- | Get completed locations of all snapshot layers from a 'RawSnapshotLocation' +-- | Get completed locations of all snapshot layers from a 'RawSnapshotLocation'. +-- Uses only fields 'compiler', 'parent' and 'solver' without parsing other +-- snapshot fields -- -- @since 0.1.0.0 readSnapshotLayers :: @@ -971,12 +975,12 @@ readSnapshotLayers :: => RawSnapshotLocation -> RIO env (NonEmpty CompletedSL) readSnapshotLayers loc = do - eres <- loadRawSnapshotLayer loc + eres <- loadRawSnapshotLayerParent loc case eres of Left wc -> pure $ (RSLCompiler wc, SLCompiler wc) :| [] - Right (rsl, sloc) -> - (sloc <|) <$> readSnapshotLayers (rslParent rsl) + Right (RawSnapshotLayerParent p, sloc) -> + (sloc <|) <$> readSnapshotLayers p -- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting -- any incomplete package locations @@ -1029,7 +1033,7 @@ loadAndCompleteSnapshotRaw loc cachePL = do , snapshotPackages = packages , snapshotDrop = apcDrop unused } - return (snapshot, sloc <| slocs0, completed ++ completed0) + return (snapshot, sloc <| slocs0, completed0 ++ completed) data SingleOrNot a = Single !a @@ -1216,6 +1220,54 @@ addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig dro pure (allPackages, reverse revCompleted, unused) +-- helper data type for reading only parent snapshot locaitons +newtype RawSnapshotLayerParent = RawSnapshotLayerParent RawSnapshotLocation + +instance Yaml.FromJSON (Unresolved RawSnapshotLayerParent) where + parseJSON = Yaml.withObject "Snapshot" $ \o -> do + mcompiler <- o Yaml..:? "compiler" + mresolver <- unWarningParser $ o ...:? ["snapshot", "resolver"] + unresolvedSnapshotParent <- + case (mcompiler, mresolver) of + (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" + (Just compiler, Nothing) -> pure $ pure (RSLCompiler compiler) + (_, Just (WithJSONWarnings (Unresolved usl) _)) -> pure $ Unresolved $ \mdir -> do + sl <- usl mdir + case (sl, mcompiler) of + (RSLCompiler c1, Just c2) -> throwIO $ InvalidOverrideCompiler c1 c2 + _ -> pure sl + + pure $ RawSnapshotLayerParent <$> unresolvedSnapshotParent + +loadRawSnapshotLayerParent + :: (HasPantryConfig env, HasLogFunc env) + => RawSnapshotLocation + -> RIO env (Either WantedCompiler (RawSnapshotLayerParent, CompletedSL)) +loadRawSnapshotLayerParent (RSLCompiler compiler) = pure $ Left compiler +loadRawSnapshotLayerParent sl@(RSLUrl url blob) = + handleAny (throwIO . InvalidSnapshot sl) $ do + bs <- loadFromURL url blob + value <- Yaml.decodeThrow bs + lparent <- parserHelperLayerParent sl value Nothing + pure $ Right (lparent, (sl, SLUrl url (bsToBlobKey bs))) +loadRawSnapshotLayerParent sl@(RSLFilePath fp) = + handleAny (throwIO . InvalidSnapshot sl) $ do + value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp + lparent <- parserHelperLayerParent sl value $ Just $ parent $ resolvedAbsolute fp + pure $ Right (lparent, (sl, SLFilePath fp)) + +parserHelperLayerParent + :: HasLogFunc env + => RawSnapshotLocation + -> Value + -> Maybe (Path Abs Dir) + -> RIO env RawSnapshotLayerParent +parserHelperLayerParent rsl val mdir = + case parseEither Yaml.parseJSON val of + Left e -> throwIO $ Couldn'tParseSnapshot rsl e + Right x -> do + resolvePaths mdir x + -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- -- Returns a 'Left' value if provided an 'SLCompiler' From 79ce99e90860593ab1f5d3caf6c72c85966e3988 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 22 Apr 2019 16:22:27 +0300 Subject: [PATCH 29/65] Optional snapshot publication timestamp --- subs/curator/src/Curator/Snapshot.hs | 3 +++ subs/pantry/src/Pantry.hs | 1 + subs/pantry/src/Pantry/Types.hs | 15 ++++++++++++++- 3 files changed, 18 insertions(+), 1 deletion(-) diff --git a/subs/curator/src/Curator/Snapshot.hs b/subs/curator/src/Curator/Snapshot.hs index b83d536a64..2ad3ea1158 100644 --- a/subs/curator/src/Curator/Snapshot.hs +++ b/subs/curator/src/Curator/Snapshot.hs @@ -38,6 +38,7 @@ import RIO.Seq (Seq) import qualified RIO.Seq as Seq import qualified RIO.Text as T import qualified RIO.Text.Partial as TP +import RIO.Time (getCurrentTime) makeSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) @@ -49,6 +50,7 @@ makeSnapshot cons = do Map.toList $ consPackages cons let snapshotPackages = Set.fromList [ pn | (pn, Just _) <- locs ] inSnapshot pn = pn `Set.member` snapshotPackages + now <- getCurrentTime pure RawSnapshotLayer { rslParent = RSLCompiler $ WCGhc $ consGhcVersion cons @@ -60,6 +62,7 @@ makeSnapshot cons = do , rslHidden = Map.filterWithKey (\pn hide -> hide && inSnapshot pn) (pcHide <$> consPackages cons) , rslGhcOptions = mempty + , rslPublishTime = Just now } getFlags :: PackageConstraints -> Maybe (Map FlagName Bool) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 167ba1ced5..4dc4b98490 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -812,6 +812,7 @@ completeSnapshotLayer rsnapshot = do , slFlags = rslFlags rsnapshot , slHidden = rslHidden rsnapshot , slGhcOptions = rslGhcOptions rsnapshot + , slPublishTime = rslPublishTime rsnapshot } traverseConcurrently_ diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 44a6318d41..60ffd03b30 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -114,7 +114,7 @@ import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import RIO.Char (isSpace) import RIO.List (intersperse) -import RIO.Time (toGregorian, Day, fromGregorianValid) +import RIO.Time (toGregorian, Day, fromGregorianValid, UTCTime) import qualified RIO.Map as Map import qualified RIO.HashMap as HM import qualified Data.Map.Strict as Map (mapKeysMonotonic) @@ -1984,6 +1984,10 @@ data RawSnapshotLayer = RawSnapshotLayer -- ^ GHC options per package -- -- @since 0.1.0.0 + , rslPublishTime :: !(Maybe UTCTime) + -- ^ See 'slPublishTime' + -- + -- @since 0.1.0.0 } deriving (Show, Eq, Generic) @@ -2006,6 +2010,7 @@ instance ToJSON RawSnapshotLayer where , if Map.null (rslGhcOptions rsnap) then [] else ["ghc-options" .= toCabalStringMap (rslGhcOptions rsnap)] + , maybe [] (\time -> ["publish-time" .= time]) (rslPublishTime rsnap) ] instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLayer)) where @@ -2028,6 +2033,7 @@ instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLayer)) where rslFlags <- (unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty) rslHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) rslGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) + rslPublishTime <- o ..:? "publish-time" pure $ (\rslLocations (rslParent, rslCompiler) -> RawSnapshotLayer {..}) <$> ((concat . map NE.toList) <$> sequenceA unresolvedLocs) <*> unresolvedSnapshotParent @@ -2072,6 +2078,11 @@ data SnapshotLayer = SnapshotLayer -- ^ GHC options per package -- -- @since 0.1.0.0 + , slPublishTime :: !(Maybe UTCTime) + -- ^ Publication timestamp for this snapshot. This field is optional, and + -- is for informational purposes only. + -- + -- @since 0.1.0.0 } deriving (Show, Eq, Generic) @@ -2084,6 +2095,7 @@ instance ToJSON SnapshotLayer where , if Map.null (slFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (slFlags snap))] , if Map.null (slHidden snap) then [] else ["hidden" .= toCabalStringMap (slHidden snap)] , if Map.null (slGhcOptions snap) then [] else ["ghc-options" .= toCabalStringMap (slGhcOptions snap)] + , maybe [] (\time -> ["publish-time" .= time]) (slPublishTime snap) ] -- | Convert snapshot layer into its "raw" equivalent. @@ -2098,6 +2110,7 @@ toRawSnapshotLayer sl = RawSnapshotLayer , rslFlags = slFlags sl , rslHidden = slHidden sl , rslGhcOptions = slGhcOptions sl + , rslPublishTime = slPublishTime sl } newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256} From b0c9c75056f812dc8f4227e62a6263f2b99ab189 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 22 Apr 2019 19:48:18 +0300 Subject: [PATCH 30/65] Avoid deadlock in file locking --- subs/pantry/src/Pantry/SQLite.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/SQLite.hs b/subs/pantry/src/Pantry/SQLite.hs index d273a34cdd..47d26a5652 100644 --- a/subs/pantry/src/Pantry/SQLite.hs +++ b/subs/pantry/src/Pantry/SQLite.hs @@ -28,6 +28,16 @@ initStorage description migration fp inner = do runMigrationSilent migration forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig + -- This addresses a weird race condition that can result in a + -- deadlock. If multiple threads in the same process try to access + -- the database, it's possible that they will end up deadlocking on + -- the file lock, due to delays which can occur in the freeing of + -- previous locks. I don't fully grok the situation yet, but + -- introducing an MVar to ensure that, within a process, only one + -- thread is attempting to lock the file is both a valid workaround + -- and good practice. + baton <- newMVar () + withSqlitePoolInfo (sqinfo False) 1 $ \pool -> inner $ Storage -- NOTE: Currently, we take a write lock on every action. This is -- a bit heavyweight, but it avoids the SQLITE_BUSY errors @@ -36,7 +46,7 @@ initStorage description migration fp inner = do -- completely. We can investigate more elegant solutions in the -- future, such as separate read and write actions or introducing -- smarter retry logic. - { withStorage_ = withWriteLock fp . flip runSqlPool pool + { withStorage_ = withMVar baton . const . withWriteLock fp . flip runSqlPool pool , withWriteLock_ = id } where From 58d10889f4bc7941e64d328c0e9a0dda93b510b5 Mon Sep 17 00:00:00 2001 From: Emanuel Borsboom Date: Mon, 22 Apr 2019 12:00:48 -0700 Subject: [PATCH 31/65] package.yaml: bump stack version to 2.0.0 --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index ddf427abe0..e2fd0fa72b 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: stack -version: '1.10.0' +version: '2.0.0' synopsis: The Haskell Tool Stack description: ! 'Please see the README.md for usage information, and the wiki on Github for more details. Also, note that From a5c9b1b971747998017ca9ac51455f43a454f249 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 11 Jan 2019 17:10:12 +0300 Subject: [PATCH 32/65] Additions necessary for integration of pantry into stackage-server: * Addition of few class instances and exports needed for stackage-server * Fixed concurrent blob and file name writes in multi-connection sql pool setting. Added few more exports needed for stackage-server * Improved speed and safety by added database aware queries. Switched all queries to MonadIO * Removed pantry cabal file and added it to gitignore * Export PackageName and Version and aded NFData instances for PackageNameP and VersionP * Lower restriction from RIO to MonadUnliftIO for sql query running in `withStorage` * Turned on `-Wall` for pantry tests. --- .gitignore | 1 + subs/pantry/.hindent.yaml | 1 + subs/pantry/package.yaml | 7 + subs/pantry/src/Pantry.hs | 16 +-- subs/pantry/src/Pantry/Archive.hs | 6 +- subs/pantry/src/Pantry/Hackage.hs | 59 ++++++-- subs/pantry/src/Pantry/Storage.hs | 218 +++++++++++++++++------------- subs/pantry/src/Pantry/Tree.hs | 2 +- subs/pantry/src/Pantry/Types.hs | 56 ++++++-- 9 files changed, 237 insertions(+), 129 deletions(-) create mode 100644 subs/pantry/.hindent.yaml diff --git a/.gitignore b/.gitignore index d2645e022c..af5d767bea 100644 --- a/.gitignore +++ b/.gitignore @@ -29,3 +29,4 @@ tags /etc/scripts/stack-scripts.cabal .hspec-failures better-cache/ +/subs/*/*.cabal diff --git a/subs/pantry/.hindent.yaml b/subs/pantry/.hindent.yaml new file mode 100644 index 0000000000..5e5e32ff0f --- /dev/null +++ b/subs/pantry/.hindent.yaml @@ -0,0 +1 @@ +indent-size: 2 diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index bbbd842967..99a184c028 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -86,6 +86,9 @@ dependencies: - directory - filepath +ghc-options: + - -Wall + library: source-dirs: src/ when: @@ -104,6 +107,10 @@ library: # For testing - Pantry.Internal - Pantry.Internal.StaticBytes + # For stackage-server + - Pantry.Storage + - Pantry.Types + - Pantry.Hackage # FIXME must be removed from pantry! - Data.Aeson.Extended diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index e973c2d778..2b4c953f2e 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -179,7 +179,7 @@ import qualified RIO.FilePath as FilePath import Pantry.Archive import Pantry.Repo import qualified Pantry.SHA256 as SHA256 -import Pantry.Storage +import Pantry.Storage hiding (TreeEntry, PackageName, Version) import Pantry.Tree import Pantry.Types import Pantry.Hackage @@ -299,8 +299,8 @@ getLatestHackageLocation req name preferred = do forM mVerCfKey $ \(version, cfKey@(BlobKey sha size)) -> do let pir = PackageIdentifierRevision name version (CFIHash sha (Just size)) - treeKey <- getHackageTarballKey pir - pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey + treeKey' <- getHackageTarballKey pir + pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey' -- | Returns the latest revision of the given package version available from -- Hackage. @@ -318,8 +318,8 @@ getLatestHackageRevision req name version = do Nothing -> pure Nothing Just (revision, cfKey@(BlobKey sha size)) -> do let cfi = CFIHash sha (Just size) - treeKey <- getHackageTarballKey (PackageIdentifierRevision name version cfi) - return $ Just (revision, cfKey, treeKey) + treeKey' <- getHackageTarballKey (PackageIdentifierRevision name version cfi) + return $ Just (revision, cfKey, treeKey') fetchTreeKeys :: (HasPantryConfig env, HasLogFunc env, Foldable f) @@ -739,8 +739,8 @@ completePackageLocation (RPLIHackage pir0@(PackageIdentifierRevision name versio pir = PackageIdentifierRevision name version cfi logDebug $ "Added in cabal file hash: " <> display pir pure (pir, BlobKey sha size) - treeKey <- getHackageTarballKey pir - pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey + treeKey' <- getHackageTarballKey pir + pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey' completePackageLocation pl@(RPLIArchive archive rpm) = do -- getArchive checks archive and package metadata (sha, size, package) <- getArchive pl archive rpm @@ -1344,7 +1344,7 @@ getRawPackageLocationTreeKey -> RIO env TreeKey getRawPackageLocationTreeKey pl = case getRawTreeKey pl of - Just treeKey -> pure treeKey + Just treeKey' -> pure treeKey' Nothing -> case pl of RPLIHackage pir _ -> getHackageTarballKey pir diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 4549445792..574ba660e2 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -13,7 +13,7 @@ module Pantry.Archive import RIO import qualified Pantry.SHA256 as SHA256 -import Pantry.Storage +import Pantry.Storage hiding (Tree, TreeEntry) import Pantry.Tree import Pantry.Types import RIO.Process @@ -447,7 +447,7 @@ parseArchive rpli archive fp = do BFCabal _ _ -> when (buildFilePath /= cabalFileName name) $ throwIO $ WrongCabalFileName rpli buildFilePath name _ -> return () -- It's good! Store the tree, let's bounce - (tid, treeKey) <- withStorage $ storeTree rpli ident tree buildFile + (tid, treeKey') <- withStorage $ storeTree rpli ident tree buildFile packageCabal <- case buildFile of BFCabal _ _ -> pure $ PCCabalFile buildFileEntry BFHpack _ -> do @@ -458,7 +458,7 @@ parseArchive rpli archive fp = do let cabalTreeEntry = TreeEntry cabalKey (teType buildFileEntry) pure $ PCHpack $ PHpack { phOriginal = buildFileEntry, phGenerated = cabalTreeEntry, phVersion = hpackSoftwareVersion} pure Package - { packageTreeKey = treeKey + { packageTreeKey = treeKey' , packageTree = tree , packageCabalEntry = packageCabal , packageIdent = ident diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 7eaad0fb60..62f3d9caf6 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -4,10 +4,12 @@ {-# LANGUAGE ScopedTypeVariables #-} module Pantry.Hackage ( updateHackageIndex + , forceUpdateHackageIndex , DidUpdateOccur (..) , RequireHackageIndex (..) , hackageIndexTarballL , getHackageTarball + , getHackageTarballOnGPD , getHackageTarballKey , getHackageCabalFile , getHackagePackageVersions @@ -28,7 +30,7 @@ import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import Pantry.Archive import Pantry.Types hiding (FileType (..)) -import Pantry.Storage +import Pantry.Storage hiding (TreeEntry, PackageName, Version) import Pantry.Tree import qualified Pantry.SHA256 as SHA256 import Network.URI (parseURI) @@ -39,6 +41,7 @@ import qualified Distribution.PackageDescription as Cabal import System.IO (SeekMode (..)) import qualified Data.List.NonEmpty as NE import Data.Text.Metrics (damerauLevenshtein) +import Distribution.PackageDescription (GenericPackageDescription) import Distribution.Types.Version (versionNumbers) import Distribution.Types.VersionRange (withinRange) @@ -80,7 +83,26 @@ updateHackageIndex :: (HasPantryConfig env, HasLogFunc env) => Maybe Utf8Builder -- ^ reason for updating, if any -> RIO env DidUpdateOccur -updateHackageIndex mreason = do +updateHackageIndex = updateHackageIndexInternal False + +-- | Same as `updateHackageIndex`, but force the database update even if hackage +-- security tells that there is no change. This can be useful in order to make +-- sure the database is in sync with the locally downloaded tarball +-- +-- @since 0.1.0.0 +forceUpdateHackageIndex + :: (HasPantryConfig env, HasLogFunc env) + => Maybe Utf8Builder + -> RIO env DidUpdateOccur +forceUpdateHackageIndex = updateHackageIndexInternal True + + +updateHackageIndexInternal + :: (HasPantryConfig env, HasLogFunc env) + => Bool -- ^ Force the database update. + -> Maybe Utf8Builder -- ^ reason for updating, if any + -> RIO env DidUpdateOccur +updateHackageIndexInternal forceUpdate mreason = do storage <- view $ pantryConfigL.to pcStorage gateUpdate $ withWriteLock_ storage $ do for_ mreason logInfo @@ -118,6 +140,9 @@ updateHackageIndex mreason = do HS.checkForUpdates repo maybeNow case didUpdate of + _ | forceUpdate -> do + logInfo "Forced package update is initialized" + updateCache tarball HS.NoUpdates -> do x <- needsCacheUpdate tarball if x @@ -200,11 +225,13 @@ updateHackageIndex mreason = do if oldHash == oldHashCheck then oldSize <$ logInfo "Updating preexisting cache, should be quick" else 0 <$ do - logInfo "Package index change detected, that's pretty unusual" - logInfo $ "Old size: " <> display oldSize - logInfo $ "Old hash (orig) : " <> display oldHash - logInfo $ "New hash (check): " <> display oldHashCheck - logInfo "Forcing a recache" + logWarn $ mconcat [ + "Package index change detected, that's pretty unusual: " + , "\n Old size: " <> display oldSize + , "\n Old hash (orig) : " <> display oldHash + , "\n New hash (check): " <> display oldHashCheck + , "\n Forcing a recache" + ] pure (offset, newHash, newSize) lift $ logInfo $ "Populating cache from file size " <> display newSize <> ", hash " <> display newHash @@ -503,11 +530,22 @@ getHackageTarball => PackageIdentifierRevision -> Maybe TreeKey -> RIO env Package -getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = do +getHackageTarball = getHackageTarballOnGPD (\ _ _ -> pure ()) + +-- | Same as `getHackageTarball`, but allows an extra action to be performed on the parsed +-- `GenericPackageDescription` and newly created `TreeId`. +getHackageTarballOnGPD + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => (TreeId -> GenericPackageDescription -> RIO env ()) + -> PackageIdentifierRevision + -> Maybe TreeKey + -> RIO env Package +getHackageTarballOnGPD onGPD pir mtreeKey = do + let PackageIdentifierRevision name ver _cfi = pir cabalFile <- resolveCabalFileInfo pir - cabalFileKey <- withStorage $ getBlobKey cabalFile let rpli = RPLIHackage pir mtreeKey withCachedTree rpli name ver cabalFile $ do + cabalFileKey <- withStorage $ getBlobKey cabalFile mpair <- withStorage $ loadHackageTarballInfo name ver (sha, size) <- case mpair of @@ -569,7 +607,8 @@ getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = do , mismatchActual = gpdIdent } - (_tid, treeKey') <- withStorage $ storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) + (tid, treeKey') <- withStorage $ storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) + onGPD tid gpd pure Package { packageTreeKey = treeKey' , packageTree = tree' diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 539d28c5df..2a0b9df546 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -9,10 +9,12 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} module Pantry.Storage ( SqlBackend , initStorage , withStorage + , migrateAll , storeBlob , loadBlob , loadBlobById @@ -33,6 +35,9 @@ module Pantry.Storage , loadTree , storeHPack , loadPackageById + , getPackageNameById + , getPackageNameId + , getVersionId , getTreeForKey , storeHackageTree , loadHackageTree @@ -51,14 +56,24 @@ module Pantry.Storage , getSnapshotCacheId , storeSnapshotModuleCache , loadExposedModulePackages - + , PackageNameId + , PackageName + , VersionId + , ModuleNameId + , Version + , Unique(..) + , EntityField(..) -- avoid warnings , BlobId + , unBlobKey , HackageCabalId + , HackageCabal(..) , HackageTarballId , CacheUpdateId , FilePathId + , Tree(..) , TreeId + , TreeEntry(..) , TreeEntryId , ArchiveCacheId , RepoCacheId @@ -243,39 +258,61 @@ withStorage withStorage action = flip SQLite.withStorage_ action =<< view (P.pantryConfigL.to P.pcStorage) + +rdbmsAwareQuery + :: MonadIO m + => ReaderT SqlBackend m a + -> ReaderT SqlBackend m a + -> ReaderT SqlBackend m a +rdbmsAwareQuery postgresQuery sqliteQuery = do + rdbms <- connRDBMS <$> ask + case rdbms of + "postgresql" -> postgresQuery + "sqlite" -> sqliteQuery + _ -> error $ "rdbmsAwareQuery: unsupported rdbms '" ++ T.unpack rdbms ++ "'" + + +getPackageNameById + :: MonadIO m + => PackageNameId + -> ReaderT SqlBackend m (Maybe P.PackageName) +getPackageNameById = fmap (unPackageNameP . packageNameName <$>) . get + + getPackageNameId - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName - -> ReaderT SqlBackend (RIO env) PackageNameId + -> ReaderT SqlBackend m PackageNameId getPackageNameId = fmap (either entityKey id) . insertBy . PackageName . PackageNameP getVersionId - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.Version - -> ReaderT SqlBackend (RIO env) VersionId + -> ReaderT SqlBackend m VersionId getVersionId = fmap (either entityKey id) . insertBy . Version . VersionP -getFilePathId - :: (HasPantryConfig env, HasLogFunc env) - => SafeFilePath - -> ReaderT SqlBackend (RIO env) FilePathId -getFilePathId = fmap (either entityKey id) . insertBy . FilePath - storeBlob - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => ByteString - -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey) + -> ReaderT SqlBackend m (BlobId, BlobKey) storeBlob bs = do let sha = SHA256.hashBytes bs size = FileSize $ fromIntegral $ B.length bs keys <- selectKeysList [BlobSha ==. sha] [] key <- case keys of - [] -> insert Blob - { blobSha = sha - , blobSize = size - , blobContents = bs - } + [] -> rdbmsAwareQuery + (do rawExecute + "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON CONFLICT DO NOTHING" + [toPersistValue sha, toPersistValue size, toPersistValue bs] + rawSql "SELECT blob.id FROM blob WHERE blob.sha = ?" [toPersistValue sha] >>= \case + [Single key] -> pure key + _ -> error "soreBlob: there was a critical problem storing a blob.") + (insert Blob + { blobSha = sha + , blobSize = size + , blobContents = bs + }) key:rest -> assert (null rest) (pure key) pure (key, P.BlobKey sha size) @@ -295,27 +332,17 @@ loadBlob (P.BlobKey sha size) = do ". Expected size: " <> display size <> ". Actual size: " <> display (blobSize bt)) -loadBlobBySHA - :: (HasPantryConfig env, HasLogFunc env) - => SHA256 - -> ReaderT SqlBackend (RIO env) (Maybe BlobId) +loadBlobBySHA :: MonadIO m => SHA256 -> ReaderT SqlBackend m (Maybe BlobId) loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobSha ==. sha] [] -loadBlobById - :: (HasPantryConfig env, HasLogFunc env) - => BlobId - -> ReaderT SqlBackend (RIO env) ByteString +loadBlobById :: MonadIO m => BlobId -> ReaderT SqlBackend m ByteString loadBlobById bid = do mbt <- get bid case mbt of Nothing -> error "loadBlobById: ID doesn't exist in database" Just bt -> pure $ blobContents bt - -getBlobKey - :: (HasPantryConfig env, HasLogFunc env) - => BlobId - -> ReaderT SqlBackend (RIO env) BlobKey +getBlobKey :: MonadIO m => BlobId -> ReaderT SqlBackend m BlobKey getBlobKey bid = do res <- rawSql "SELECT sha, size FROM blob WHERE id=?" [toPersistValue bid] case res of @@ -323,19 +350,13 @@ getBlobKey bid = do [(Single sha, Single size)] -> pure $ P.BlobKey sha size _ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res) -getBlobId - :: (HasPantryConfig env, HasLogFunc env) - => BlobKey - -> ReaderT SqlBackend (RIO env) (Maybe BlobId) +getBlobId :: MonadIO m => BlobKey -> ReaderT SqlBackend m (Maybe BlobId) getBlobId (P.BlobKey sha size) = do res <- rawSql "SELECT id FROM blob WHERE sha=? AND size=?" [toPersistValue sha, toPersistValue size] pure $ listToMaybe $ map unSingle res -loadURLBlob - :: (HasPantryConfig env, HasLogFunc env) - => Text - -> ReaderT SqlBackend (RIO env) (Maybe ByteString) +loadURLBlob :: MonadIO m => Text -> ReaderT SqlBackend m (Maybe ByteString) loadURLBlob url = do ment <- rawSql "SELECT blob.contents\n\ @@ -348,11 +369,7 @@ loadURLBlob url = do [] -> pure Nothing (Single bs) : _ -> pure $ Just bs -storeURLBlob - :: (HasPantryConfig env, HasLogFunc env) - => Text - -> ByteString - -> ReaderT SqlBackend (RIO env) () +storeURLBlob :: MonadIO m => Text -> ByteString -> ReaderT SqlBackend m () storeURLBlob url blob = do (blobId, _) <- storeBlob blob now <- getCurrentTime @@ -362,17 +379,15 @@ storeURLBlob url blob = do , urlBlobTime = now } -clearHackageRevisions - :: (HasPantryConfig env, HasLogFunc env) - => ReaderT SqlBackend (RIO env) () +clearHackageRevisions :: MonadIO m => ReaderT SqlBackend m () clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal]) storeHackageRevision - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName -> P.Version -> BlobId - -> ReaderT SqlBackend (RIO env) () + -> ReaderT SqlBackend m () storeHackageRevision name version key = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -389,9 +404,9 @@ storeHackageRevision name version key = do } loadHackagePackageVersions - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName - -> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey)) + -> ReaderT SqlBackend m (Map P.Version (Map Revision BlobKey)) loadHackagePackageVersions name = do nameid <- getPackageNameId name -- would be better with esequeleto @@ -407,10 +422,10 @@ loadHackagePackageVersions name = do (version, Map.singleton revision (P.BlobKey key size)) loadHackagePackageVersion - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName -> P.Version - -> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey)) + -> ReaderT SqlBackend m (Map Revision (BlobId, P.BlobKey)) loadHackagePackageVersion name version = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -427,18 +442,18 @@ loadHackagePackageVersion name version = do (revision, (bid, P.BlobKey sha size)) loadLatestCacheUpdate - :: (HasPantryConfig env, HasLogFunc env) - => ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256)) + :: MonadIO m + => ReaderT SqlBackend m (Maybe (FileSize, SHA256)) loadLatestCacheUpdate = fmap go <$> selectFirst [] [Desc CacheUpdateTime] where go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu) storeCacheUpdate - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => FileSize -> SHA256 - -> ReaderT SqlBackend (RIO env) () + -> ReaderT SqlBackend m () storeCacheUpdate size sha = do now <- getCurrentTime insert_ CacheUpdate @@ -448,12 +463,12 @@ storeCacheUpdate size sha = do } storeHackageTarballInfo - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName -> P.Version -> SHA256 -> FileSize - -> ReaderT SqlBackend (RIO env) () + -> ReaderT SqlBackend m () storeHackageTarballInfo name version sha size = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -465,10 +480,10 @@ storeHackageTarballInfo name version sha size = do } loadHackageTarballInfo - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName -> P.Version - -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize)) + -> ReaderT SqlBackend m (Maybe (SHA256, FileSize)) loadHackageTarballInfo name version = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -561,6 +576,26 @@ hpackVersionId = do insertBy $ Version {versionVersion = P.VersionP hpackSoftwareVersion} +getFilePathId + :: MonadIO m + => SafeFilePath + -> ReaderT SqlBackend m FilePathId +getFilePathId sfp = + selectKeysList [FilePathPath ==. sfp] [] >>= \case + [fpId] -> pure fpId + [] -> rdbmsAwareQuery + (do rawExecute + "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING" + [toPersistValue sfp] + rawSql "SELECT id FROM file_path WHERE path = ?" [toPersistValue sfp] >>= \case + [Single key] -> pure key + _ -> error "getFilePathId: there was a critical problem storing a blob.") + (insert $ FilePath sfp) + _ -> error $ "getFilePathId: FilePath unique constraint key is violated for: " ++ fp + where + fp = T.unpack (P.unSafeFilePath sfp) + + storeTree :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions @@ -623,10 +658,7 @@ getTree tid = do Just ts -> pure ts loadTreeByEnt $ Entity tid ts -loadTree - :: (HasPantryConfig env, HasLogFunc env) - => P.TreeKey - -> ReaderT SqlBackend (RIO env) (Maybe P.Tree) +loadTree :: MonadIO m => P.TreeKey -> ReaderT SqlBackend m (Maybe P.Tree) loadTree key = do ment <- getTreeForKey key case ment of @@ -634,9 +666,9 @@ loadTree key = do Just ent -> Just <$> loadTreeByEnt ent getTreeForKey - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => TreeKey - -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)) + -> ReaderT SqlBackend m (Maybe (Entity Tree)) getTreeForKey (P.TreeKey key) = do mbid <- getBlobId key case mbid of @@ -672,8 +704,8 @@ loadPackageById rpli tid = do "loadPackageByid: invalid foreign key " ++ show (treeVersion ts) Just (Version (P.VersionP version)) -> pure version let ident = P.PackageIdentifier name version - (pentry, mtree) <- - case (treeCabal ts) of + (pantry, mtree) <- + case treeCabal ts of Just keyBlob -> do cabalKey <- getBlobKey keyBlob return @@ -700,7 +732,7 @@ loadPackageById rpli tid = do Package { packageTreeKey = P.TreeKey blobKey , packageTree = mtree - , packageCabalEntry = pentry + , packageCabalEntry = pantry , packageIdent = ident } @@ -741,9 +773,9 @@ getHPackCabalFile hpackRecord ts tmap cabalFile = do , tree) loadTreeByEnt - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => Entity Tree - -> ReaderT SqlBackend (RIO env) P.Tree + -> ReaderT SqlBackend m P.Tree loadTreeByEnt (Entity tid _t) = do entries <- rawSql "SELECT file_path.path, blob.sha, blob.size, tree_entry.type\n\ @@ -758,12 +790,12 @@ loadTreeByEnt (Entity tid _t) = do entries storeHackageTree - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName -> P.Version -> BlobId -> P.TreeKey - -> ReaderT SqlBackend (RIO env) () + -> ReaderT SqlBackend m () storeHackageTree name version cabal treeKey' = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -776,11 +808,11 @@ storeHackageTree name version cabal treeKey' = do [HackageCabalTree =. Just (entityKey ent)] loadHackageTreeKey - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName -> P.Version -> SHA256 - -> ReaderT SqlBackend (RIO env) (Maybe TreeKey) + -> ReaderT SqlBackend m (Maybe TreeKey) loadHackageTreeKey name ver sha = do res <- rawSql "SELECT treeblob.sha, treeblob.size\n\ @@ -827,13 +859,13 @@ loadHackageTree rpli name ver bid = do Just tid -> Just <$> loadPackageById rpli tid storeArchiveCache - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => Text -- ^ URL -> Text -- ^ subdir -> SHA256 -> FileSize -> P.TreeKey - -> ReaderT SqlBackend (RIO env) () + -> ReaderT SqlBackend m () storeArchiveCache url subdir sha size treeKey' = do now <- getCurrentTime ment <- getTreeForKey treeKey' @@ -847,10 +879,10 @@ storeArchiveCache url subdir sha size treeKey' = do } loadArchiveCache - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => Text -- ^ URL -> Text -- ^ subdir - -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)] + -> ReaderT SqlBackend m [(SHA256, FileSize, TreeId)] loadArchiveCache url subdir = map go <$> selectList [ ArchiveCacheUrl ==. url , ArchiveCacheSubdir ==. subdir @@ -860,11 +892,11 @@ loadArchiveCache url subdir = map go <$> selectList go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) storeRepoCache - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => Repo -> Text -- ^ subdir -> TreeId - -> ReaderT SqlBackend (RIO env) () + -> ReaderT SqlBackend m () storeRepoCache repo subdir tid = do now <- getCurrentTime insert_ RepoCache @@ -877,10 +909,10 @@ storeRepoCache repo subdir tid = do } loadRepoCache - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => Repo -> Text -- ^ subdir - -> ReaderT SqlBackend (RIO env) (Maybe TreeId) + -> ReaderT SqlBackend m (Maybe TreeId) loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst [ RepoCacheUrl ==. repoUrl repo , RepoCacheType ==. repoType repo @@ -890,10 +922,10 @@ loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst [Desc RepoCacheTime] storePreferredVersion - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName -> Text - -> ReaderT SqlBackend (RIO env) () + -> ReaderT SqlBackend m () storePreferredVersion name p = do nameid <- getPackageNameId name ment <- getBy $ UniquePreferred nameid @@ -905,18 +937,18 @@ storePreferredVersion name p = do Just (Entity pid _) -> update pid [PreferredVersionsPreferred =. p] loadPreferredVersion - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName - -> ReaderT SqlBackend (RIO env) (Maybe Text) + -> ReaderT SqlBackend m (Maybe Text) loadPreferredVersion name = do nameid <- getPackageNameId name fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) sinkHackagePackageNames - :: (HasPantryConfig env, HasLogFunc env) + :: MonadUnliftIO m => (P.PackageName -> Bool) - -> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a - -> ReaderT SqlBackend (RIO env) a + -> ConduitT P.PackageName Void (ReaderT SqlBackend m) a + -> ReaderT SqlBackend m a sinkHackagePackageNames predicate sink = do acqSrc <- selectSourceRes [] [] with acqSrc $ \src -> runConduit @@ -1019,8 +1051,8 @@ unpackTreeToDir rpli (toFilePath -> dir) (P.TreeMap m) = do setPermissions dest $ setOwnerExecutable True perms countHackageCabals - :: (HasPantryConfig env, HasLogFunc env) - => ReaderT SqlBackend (RIO env) Int + :: MonadIO m + => ReaderT SqlBackend m Int countHackageCabals = do res <- rawSql "SELECT COUNT(*)\n\ diff --git a/subs/pantry/src/Pantry/Tree.hs b/subs/pantry/src/Pantry/Tree.hs index 63625280bc..63f2e25808 100644 --- a/subs/pantry/src/Pantry/Tree.hs +++ b/subs/pantry/src/Pantry/Tree.hs @@ -10,7 +10,7 @@ import RIO import qualified RIO.Map as Map import qualified RIO.Text as T import qualified RIO.ByteString as B -import Pantry.Storage +import Pantry.Storage hiding (Tree, TreeEntry) import Pantry.Types import RIO.FilePath ((), takeDirectory) import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 60ffd03b30..8098fc11f5 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -10,7 +10,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE MultiWayIf #-} module Pantry.Types ( PantryConfig (..) @@ -122,6 +121,7 @@ import qualified RIO.Set as Set import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..)) import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText, Parser) import Data.Aeson.Extended +import Data.Aeson.Encoding.Internal (unsafeToEncoding) import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) import Database.Persist import Database.Persist.Sql @@ -130,7 +130,7 @@ import qualified Pantry.SHA256 as SHA256 import qualified Distribution.Compat.ReadP as Parse import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) import Distribution.Parsec.Common (PError (..), PWarning (..), showPos) -import Distribution.Types.PackageName (PackageName, unPackageName) +import Distribution.Types.PackageName (PackageName, unPackageName, mkPackageName) import Distribution.Types.VersionRange (VersionRange) import Distribution.PackageDescription (FlagName, unFlagName, GenericPackageDescription) import Distribution.Types.PackageId (PackageIdentifier (..)) @@ -205,8 +205,8 @@ newtype Revision = Revision Word -- whether a pool is used, and the default implementation in -- "Pantry.Storage" does not use a pool. data Storage = Storage - { withStorage_ :: (forall env a. HasLogFunc env => ReaderT SqlBackend (RIO env) a -> RIO env a) - , withWriteLock_ :: (forall env a. HasLogFunc env => RIO env a -> RIO env a) + { withStorage_ :: forall m a. MonadUnliftIO m => ReaderT SqlBackend m a -> m a + , withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a } -- | Configuration value used by the entire pantry package. Create one @@ -483,9 +483,9 @@ data Repo = Repo -- -- @since 0.1.0.0 , repoSubdir :: !Text - -- ^ Subdirectory within the archive to get the package from. - -- - -- @since 0.1.0.0 + -- ^ Subdirectory within the archive to get the package from. + -- + -- @since 0.1.0.0 } deriving (Generic, Eq, Ord, Typeable) instance NFData Repo @@ -540,6 +540,7 @@ instance FromJSON (WithJSONWarnings HackageSecurityConfig) where hscIgnoreExpiry <- o ..:? "ignore-expiry" ..!= False pure HackageSecurityConfig {..} + -- | An environment which contains a 'PantryConfig'. -- -- @since 0.1.0.0 @@ -549,6 +550,7 @@ class HasPantryConfig env where -- @since 0.1.0.0 pantryConfigL :: Lens' env PantryConfig + -- | File size in bytes -- -- @since 0.1.0.0 @@ -587,7 +589,9 @@ instance FromJSON BlobKey where <*> o .: "size" newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName } - deriving (Show) + deriving (Eq, Ord, Show, Read, NFData) +instance Display PackageNameP where + display = fromString . packageNameString . unPackageNameP instance PersistField PackageNameP where toPersistValue (PackageNameP pn) = PersistText $ T.pack $ packageNameString pn fromPersistValue v = do @@ -597,9 +601,20 @@ instance PersistField PackageNameP where Just pn -> Right $ PackageNameP pn instance PersistFieldSql PackageNameP where sqlType _ = SqlString - -newtype VersionP = VersionP Version - deriving (Show) +instance ToJSON PackageNameP where + toJSON (PackageNameP pn) = String $ T.pack $ packageNameString pn +instance FromJSON PackageNameP where + parseJSON = withText "PackageNameP" $ pure . PackageNameP . mkPackageName . T.unpack +instance ToJSONKey PackageNameP where + toJSONKey = + ToJSONKeyText + (T.pack . packageNameString . unPackageNameP) + (unsafeToEncoding . getUtf8Builder . display) +instance FromJSONKey PackageNameP where + fromJSONKey = FromJSONKeyText $ PackageNameP . mkPackageName . T.unpack + +newtype VersionP = VersionP { unVersionP :: Version } + deriving (Eq, Ord, Show, Read, NFData) instance PersistField VersionP where toPersistValue (VersionP v) = PersistText $ T.pack $ versionString v fromPersistValue v = do @@ -609,9 +624,20 @@ instance PersistField VersionP where Just ver -> Right $ VersionP ver instance PersistFieldSql VersionP where sqlType _ = SqlString - -newtype ModuleNameP = ModuleNameP ModuleName - deriving (Show) +instance Display VersionP where + display (VersionP v) = fromString $ versionString v +instance ToJSON VersionP where + toJSON (VersionP v) = String $ T.pack $ versionString v +instance FromJSON VersionP where + parseJSON = + withText "VersionP" $ + either (fail . displayException) (pure . VersionP) . parseVersionThrowing . T.unpack + +newtype ModuleNameP = ModuleNameP + { unModuleNameP :: ModuleName + } deriving (Eq, Ord, Show, NFData) +instance Display ModuleNameP where + display = fromString . moduleNameString . unModuleNameP instance PersistField ModuleNameP where toPersistValue (ModuleNameP mn) = PersistText $ T.pack $ moduleNameString mn fromPersistValue v = do @@ -1624,6 +1650,7 @@ data HpackExecutable -- ^ Executable at the provided path deriving (Show, Read, Eq, Ord) + -- | Which compiler a snapshot wants to use. The build tool may elect -- to do some fuzzy matching of versions (e.g., allowing different -- patch versions). @@ -1637,6 +1664,7 @@ data WantedCompiler !Version -- ^ GHCJS version followed by GHC version deriving (Show, Eq, Ord, Generic) + instance NFData WantedCompiler instance Display WantedCompiler where display (WCGhc vghc) = "ghc-" <> fromString (versionString vghc) From 24381d9444def8be549ba0d70970b8e1f029f787 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Apr 2019 02:52:14 +0300 Subject: [PATCH 33/65] Add `Pantry.Internal.Stackage` that exports all of the stuff needed for Stackage Server --- subs/pantry/package.yaml | 4 +- subs/pantry/src/Pantry.hs | 1 - subs/pantry/src/Pantry/Internal/Stackage.hs | 50 +++++++++++++++++++++ 3 files changed, 51 insertions(+), 4 deletions(-) create mode 100644 subs/pantry/src/Pantry/Internal/Stackage.hs diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 99a184c028..57ad825507 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -108,9 +108,7 @@ library: - Pantry.Internal - Pantry.Internal.StaticBytes # For stackage-server - - Pantry.Storage - - Pantry.Types - - Pantry.Hackage + - Pantry.Internal.Stackage # FIXME must be removed from pantry! - Data.Aeson.Extended diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 2b4c953f2e..ea2f6cab7a 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -- | Content addressable Haskell package management, providing for -- secure, reproducible acquisition of Haskell package contents and -- metadata. diff --git a/subs/pantry/src/Pantry/Internal/Stackage.hs b/subs/pantry/src/Pantry/Internal/Stackage.hs new file mode 100644 index 0000000000..d5e42b2159 --- /dev/null +++ b/subs/pantry/src/Pantry/Internal/Stackage.hs @@ -0,0 +1,50 @@ +-- | All types and functions exported from this module are for advanced usage +-- only. They are needed for stackage-server integration with pantry. +module Pantry.Internal.Stackage + ( module X + ) where + +import Pantry.Hackage as X + ( forceUpdateHackageIndex + , getHackageTarballOnGPD + ) +import Pantry.Storage as X + ( BlobId + , EntityField(..) + , HackageCabalId + , ModuleNameId + , PackageName + , PackageNameId + , Tree(..) + , TreeEntry(..) + , TreeEntryId + , TreeId + , Unique(..) + , Version + , VersionId + , getBlobKey + , getPackageNameById + , getPackageNameId + , getTreeForKey + , getVersionId + , loadBlobById + , migrateAll + , treeCabal + , unBlobKey + ) +import Pantry.Types as X + ( ModuleNameP(..) + , PackageNameP(..) + , PantryConfig(..) + , SafeFilePath + , Storage(..) + , VersionP(..) + , mkSafeFilePath + , packageNameString + , packageTreeKey + , parsePackageName + , parseVersion + , parseVersionThrowing + , unSafeFilePath + , versionString + ) From de9cf4a4a8bf8ed9afb9b9b31b5d7a2cce44be4d Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Apr 2019 03:10:10 +0300 Subject: [PATCH 34/65] Adjust `getHackageTarball` to not rely on callback style and introduce an extra data type to handle it --- subs/pantry/src/Pantry.hs | 5 +- subs/pantry/src/Pantry/Hackage.hs | 144 +++++++++++--------- subs/pantry/src/Pantry/Internal/Stackage.hs | 3 +- 3 files changed, 83 insertions(+), 69 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index ea2f6cab7a..1f0d2d3ea3 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -701,7 +701,8 @@ loadPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env Package -loadPackage (PLIHackage ident cfHash tree) = getHackageTarball (pirForHash ident cfHash) (Just tree) +loadPackage (PLIHackage ident cfHash tree) = + htrPackage <$> getHackageTarball (pirForHash ident cfHash) (Just tree) loadPackage pli@(PLIArchive archive pm) = getArchivePackage (toRawPLI pli) (toRawArchive archive) (toRawPM pm) loadPackage (PLIRepo repo pm) = getRepo repo (toRawPM pm) @@ -712,7 +713,7 @@ loadPackageRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env Package -loadPackageRaw (RPLIHackage pir mtree) = getHackageTarball pir mtree +loadPackageRaw (RPLIHackage pir mtree) = htrPackage <$> getHackageTarball pir mtree loadPackageRaw rpli@(RPLIArchive archive pm) = getArchivePackage rpli archive pm loadPackageRaw (RPLIRepo repo rpm) = getRepo repo rpm diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 62f3d9caf6..fc02529ad0 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -9,13 +9,13 @@ module Pantry.Hackage , RequireHackageIndex (..) , hackageIndexTarballL , getHackageTarball - , getHackageTarballOnGPD , getHackageTarballKey , getHackageCabalFile , getHackagePackageVersions , getHackagePackageVersionRevisions , getHackageTypoCorrections , UsePreferredVersions (..) + , HackageTarballResult(..) ) where import RIO @@ -72,6 +72,17 @@ hackageIndexTarballL = hackageDirL.to ( indexRelFile) -- @since 0.1.0.0 data DidUpdateOccur = UpdateOccurred | NoUpdateOccurred + +-- | Information returned by `getHackageTarball` +-- +-- @since 0.1.0.0 +data HackageTarballResult = HackageTarballResult + { htrPackage :: !Package + -- ^ Package that was loaded from Hackage tarball + , htrFreshPackageInfo :: !(Maybe (GenericPackageDescription, TreeId)) + -- ^ This information is only available whenever package was just loaded into pantry. + } + -- | Download the most recent 01-index.tar file from Hackage and -- update the database tables. -- @@ -503,16 +514,17 @@ withCachedTree -> PackageName -> Version -> BlobId -- ^ cabal file contents - -> RIO env Package - -> RIO env Package + -> RIO env HackageTarballResult + -> RIO env HackageTarballResult withCachedTree rpli name ver bid inner = do mres <- withStorage $ loadHackageTree rpli name ver bid case mres of - Just package -> pure package + Just package -> pure $ HackageTarballResult package Nothing Nothing -> do - package <- inner - withStorage $ storeHackageTree name ver bid $ packageTreeKey package - pure package + htr <- inner + withStorage $ + storeHackageTree name ver bid $ packageTreeKey $ htrPackage htr + pure htr getHackageTarballKey :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) @@ -521,26 +533,16 @@ getHackageTarballKey getHackageTarballKey pir@(PackageIdentifierRevision name ver (CFIHash sha _msize)) = do mres <- withStorage $ loadHackageTreeKey name ver sha case mres of - Nothing -> packageTreeKey <$> getHackageTarball pir Nothing + Nothing -> packageTreeKey . htrPackage <$> getHackageTarball pir Nothing Just key -> pure key -getHackageTarballKey pir = packageTreeKey <$> getHackageTarball pir Nothing +getHackageTarballKey pir = packageTreeKey . htrPackage <$> getHackageTarball pir Nothing getHackageTarball :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageIdentifierRevision -> Maybe TreeKey - -> RIO env Package -getHackageTarball = getHackageTarballOnGPD (\ _ _ -> pure ()) - --- | Same as `getHackageTarball`, but allows an extra action to be performed on the parsed --- `GenericPackageDescription` and newly created `TreeId`. -getHackageTarballOnGPD - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => (TreeId -> GenericPackageDescription -> RIO env ()) - -> PackageIdentifierRevision - -> Maybe TreeKey - -> RIO env Package -getHackageTarballOnGPD onGPD pir mtreeKey = do + -> RIO env HackageTarballResult +getHackageTarball pir mtreeKey = do let PackageIdentifierRevision name ver _cfi = pir cabalFile <- resolveCabalFileInfo pir let rpli = RPLIHackage pir mtreeKey @@ -562,56 +564,66 @@ getHackageTarballOnGPD onGPD pir mtreeKey = do Just pair2 -> pure pair2 pc <- view pantryConfigL let urlPrefix = hscDownloadPrefix $ pcHackageSecurity pc - url = mconcat - [ urlPrefix - , "package/" - , T.pack $ Distribution.Text.display name - , "-" - , T.pack $ Distribution.Text.display ver - , ".tar.gz" - ] - package <- getArchivePackage - rpli - RawArchive - { raLocation = ALUrl url - , raHash = Just sha - , raSize = Just size - , raSubdir = T.empty -- no subdirs on Hackage - } - RawPackageMetadata - { rpmName = Just name - , rpmVersion = Just ver - , rpmTreeKey = Nothing -- with a revision cabal file will differ giving a different tree - , rpmCabal = Nothing -- cabal file in the tarball may be different! - } - + url = + mconcat + [ urlPrefix + , "package/" + , T.pack $ Distribution.Text.display name + , "-" + , T.pack $ Distribution.Text.display ver + , ".tar.gz" + ] + package <- + getArchivePackage + rpli + RawArchive + { raLocation = ALUrl url + , raHash = Just sha + , raSize = Just size + , raSubdir = T.empty -- no subdirs on Hackage + } + RawPackageMetadata + { rpmName = Just name + , rpmVersion = Just ver + , rpmTreeKey = Nothing -- with a revision cabal file will differ giving a different tree + , rpmCabal = Nothing -- cabal file in the tarball may be different! + } case packageTree package of TreeMap m -> do - let (PCCabalFile (TreeEntry _ ft)) = packageCabalEntry package + let ft = + case packageCabalEntry package of + PCCabalFile (TreeEntry _ ft') -> ft' + _ -> error "Impossible: Hackage does not support hpack" cabalEntry = TreeEntry cabalFileKey ft tree' = TreeMap $ Map.insert (cabalFileName name) cabalEntry m ident = PackageIdentifier name ver - - cabalBS <- withStorage $ do - let BlobKey sha' _ = cabalFileKey - mcabalBS <- loadBlobBySHA sha' - case mcabalBS of - Nothing -> error $ "Invariant violated, cabal file key: " ++ show cabalFileKey - Just bid -> loadBlobById bid - + cabalBS <- + withStorage $ do + let BlobKey sha' _ = cabalFileKey + mcabalBS <- loadBlobBySHA sha' + case mcabalBS of + Nothing -> + error $ + "Invariant violated, cabal file key: " ++ show cabalFileKey + Just bid -> loadBlobById bid (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBS let gpdIdent = Cabal.package $ Cabal.packageDescription gpd - when (ident /= gpdIdent) $ throwIO $ - MismatchedCabalFileForHackage pir Mismatch - { mismatchExpected = ident - , mismatchActual = gpdIdent + when (ident /= gpdIdent) $ + throwIO $ + MismatchedCabalFileForHackage + pir + Mismatch {mismatchExpected = ident, mismatchActual = gpdIdent} + (tid, treeKey') <- + withStorage $ + storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) + pure + HackageTarballResult + { htrPackage = + Package + { packageTreeKey = treeKey' + , packageTree = tree' + , packageIdent = ident + , packageCabalEntry = PCCabalFile cabalEntry + } + , htrFreshPackageInfo = Just (gpd, tid) } - - (tid, treeKey') <- withStorage $ storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) - onGPD tid gpd - pure Package - { packageTreeKey = treeKey' - , packageTree = tree' - , packageIdent = ident - , packageCabalEntry = PCCabalFile cabalEntry - } diff --git a/subs/pantry/src/Pantry/Internal/Stackage.hs b/subs/pantry/src/Pantry/Internal/Stackage.hs index d5e42b2159..4c315cd42e 100644 --- a/subs/pantry/src/Pantry/Internal/Stackage.hs +++ b/subs/pantry/src/Pantry/Internal/Stackage.hs @@ -6,7 +6,8 @@ module Pantry.Internal.Stackage import Pantry.Hackage as X ( forceUpdateHackageIndex - , getHackageTarballOnGPD + , getHackageTarball + , HackageTarballResult(..) ) import Pantry.Storage as X ( BlobId From 0d920aeac5c5127594f0ee4cff549386c3a8889e Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Apr 2019 03:30:11 +0300 Subject: [PATCH 35/65] Make rdbms aware queries more type safe with clearer documentation --- subs/pantry/src/Pantry/Storage.hs | 81 ++++++++++++++++++++----------- 1 file changed, 54 insertions(+), 27 deletions(-) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 2a0b9df546..fd72eb5a1a 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TemplateHaskell #-} @@ -258,17 +259,25 @@ withStorage withStorage action = flip SQLite.withStorage_ action =<< view (P.pantryConfigL.to P.pcStorage) +-- | This is a helper type to distinguish db queries between different rdbms backends. The important +-- part is that the affects described in this data type should be semantically equivalent between +-- the supported engines. +data RdbmsActions m a = RdbmsActions + { raSqlite :: !(ReaderT SqlBackend m a) + -- ^ A query that is specific to SQLite + , raPostgres :: !(ReaderT SqlBackend m a) + } +-- | This function provides a way to create queries supported by multiple sql backends. rdbmsAwareQuery :: MonadIO m - => ReaderT SqlBackend m a + => RdbmsActions m a -> ReaderT SqlBackend m a - -> ReaderT SqlBackend m a -rdbmsAwareQuery postgresQuery sqliteQuery = do +rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do rdbms <- connRDBMS <$> ask case rdbms of - "postgresql" -> postgresQuery - "sqlite" -> sqliteQuery + "postgresql" -> raPostgres + "sqlite" -> raSqlite _ -> error $ "rdbmsAwareQuery: unsupported rdbms '" ++ T.unpack rdbms ++ "'" @@ -301,18 +310,26 @@ storeBlob bs = do keys <- selectKeysList [BlobSha ==. sha] [] key <- case keys of - [] -> rdbmsAwareQuery - (do rawExecute - "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON CONFLICT DO NOTHING" - [toPersistValue sha, toPersistValue size, toPersistValue bs] - rawSql "SELECT blob.id FROM blob WHERE blob.sha = ?" [toPersistValue sha] >>= \case - [Single key] -> pure key - _ -> error "soreBlob: there was a critical problem storing a blob.") - (insert Blob - { blobSha = sha - , blobSize = size - , blobContents = bs - }) + [] -> + rdbmsAwareQuery + RdbmsActions + { raSqlite = + insert Blob {blobSha = sha, blobSize = size, blobContents = bs} + , raPostgres = + do rawExecute + "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON CONFLICT DO NOTHING" + [ toPersistValue sha + , toPersistValue size + , toPersistValue bs + ] + rawSql + "SELECT blob.id FROM blob WHERE blob.sha = ?" + [toPersistValue sha] >>= \case + [Single key] -> pure key + _ -> + error + "soreBlob: there was a critical problem storing a blob." + } key:rest -> assert (null rest) (pure key) pure (key, P.BlobKey sha size) @@ -571,7 +588,7 @@ hpackVersionId :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => ReaderT SqlBackend (RIO env) VersionId hpackVersionId = do - hpackSoftwareVersion <- lift $ hpackVersion + hpackSoftwareVersion <- lift hpackVersion fmap (either entityKey id) $ insertBy $ Version {versionVersion = P.VersionP hpackSoftwareVersion} @@ -583,15 +600,25 @@ getFilePathId getFilePathId sfp = selectKeysList [FilePathPath ==. sfp] [] >>= \case [fpId] -> pure fpId - [] -> rdbmsAwareQuery - (do rawExecute - "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING" - [toPersistValue sfp] - rawSql "SELECT id FROM file_path WHERE path = ?" [toPersistValue sfp] >>= \case - [Single key] -> pure key - _ -> error "getFilePathId: there was a critical problem storing a blob.") - (insert $ FilePath sfp) - _ -> error $ "getFilePathId: FilePath unique constraint key is violated for: " ++ fp + [] -> + rdbmsAwareQuery + RdbmsActions + { raSqlite = insert $ FilePath sfp + , raPostgres = + do rawExecute + "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING" + [toPersistValue sfp] + rawSql + "SELECT id FROM file_path WHERE path = ?" + [toPersistValue sfp] >>= \case + [Single key] -> pure key + _ -> + error + "getFilePathId: there was a critical problem storing a blob." + } + _ -> + error $ + "getFilePathId: FilePath unique constraint key is violated for: " ++ fp where fp = T.unpack (P.unSafeFilePath sfp) From 4767c4e1fe6d43fc04b7789e1586a04e3473e18e Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Apr 2019 03:33:38 +0300 Subject: [PATCH 36/65] Rename binding to packageEntry --- subs/pantry/src/Pantry/Storage.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index fd72eb5a1a..a54890dfa9 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -731,7 +731,7 @@ loadPackageById rpli tid = do "loadPackageByid: invalid foreign key " ++ show (treeVersion ts) Just (Version (P.VersionP version)) -> pure version let ident = P.PackageIdentifier name version - (pantry, mtree) <- + (packageEntry, mtree) <- case treeCabal ts of Just keyBlob -> do cabalKey <- getBlobKey keyBlob @@ -759,7 +759,7 @@ loadPackageById rpli tid = do Package { packageTreeKey = P.TreeKey blobKey , packageTree = mtree - , packageCabalEntry = pantry + , packageCabalEntry = packageEntry , packageIdent = ident } From a3f71ab1a7d7c46c4d5c5c7cc0275fd77e535cd3 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 23 Apr 2019 11:14:58 +0300 Subject: [PATCH 37/65] Simplify locks: use them only as completion cache --- src/Stack/Lock.hs | 338 ++++------------------------- src/Stack/SourceMap.hs | 2 +- src/Stack/Types/SourceMap.hs | 2 +- src/test/Stack/LockSpec.hs | 210 ++++++------------ subs/pantry/src/Pantry.hs | 99 ++------- subs/pantry/src/Pantry/Internal.hs | 1 - subs/pantry/src/Pantry/Types.hs | 10 +- 7 files changed, 127 insertions(+), 535 deletions(-) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 4e4556a197..91cc5bc319 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -2,12 +2,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Stack.Lock ( lockCachedWanted , LockedLocation(..) - , LockedPackage(..) , Locked(..) ) where @@ -17,109 +15,29 @@ import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Yaml as Yaml import Pantry -import Pantry.Internal (Unresolved(..)) -import qualified Pantry.SHA256 as SHA256 import Path (addFileExtension, parent) -import Path.IO (doesFileExist, getModificationTime, resolveFile) -import qualified RIO.ByteString as B +import Path.IO (doesFileExist) import RIO.Process -import qualified RIO.Text as T -import RIO.Time (UTCTime) import Stack.Prelude import Stack.SourceMap import Stack.Types.Config import Stack.Types.SourceMap -data CompletedSnapshotLocation - = CSLFilePath !(ResolvedPath File) - !SHA256 - !FileSize - | CSLCompiler !WantedCompiler - | CSLUrl !Text !BlobKey +data LockedLocation = + LockedLocation RawPackageLocationImmutable + PackageLocationImmutable deriving (Show, Eq) -instance ToJSON CompletedSnapshotLocation where - toJSON (CSLFilePath fp sha size) = - object [ "file" .= resolvedRelative fp - , "sha" .= sha - , "size" .= size - ] - toJSON (CSLCompiler c) = - object ["compiler" .= toJSON c] - toJSON (CSLUrl url (BlobKey sha size)) = - object [ "url" .= url - , "sha" .= sha - , "size" .= size - ] - -instance FromJSON (WithJSONWarnings (Unresolved CompletedSnapshotLocation)) where - parseJSON v = file v <|> url v <|> compiler v - where - file = withObjectWarnings "CSLFilepath" $ \o -> do - ufp <- o ..: "file" - sha <- o ..: "sha" - size <- o ..: "size" - pure $ Unresolved $ \mdir -> - case mdir of - Nothing -> throwIO $ InvalidFilePathSnapshot ufp - Just dir -> do - absolute <- resolveFile dir (T.unpack ufp) - let fp = ResolvedPath (RelFilePath ufp) absolute - pure $ CSLFilePath fp sha size - url = withObjectWarnings "CSLUrl" $ \o -> do - url' <- o ..: "url" - sha <- o ..: "sha" - size <- o ..: "size" - pure $ Unresolved $ \_ -> pure $ CSLUrl url' (BlobKey sha size) - compiler = withObjectWarnings "CSLCompiler" $ \o -> do - c <- o ..: "compiler" - pure $ Unresolved $ \_ -> pure $ CSLCompiler c - -data LockedLocation a b - = LockedExact b - | LockedCompleted a - b - deriving (Show, Eq) - -instance (ToJSON a, ToJSON b) => ToJSON (LockedLocation a b) where - toJSON (LockedExact o) = - object ["exact" .= o] - toJSON (LockedCompleted o c) = +instance ToJSON LockedLocation where + toJSON (LockedLocation o c) = object [ "original" .= o, "completed" .= c ] -instance ( FromJSON (WithJSONWarnings (Unresolved a)) - , FromJSON (WithJSONWarnings (Unresolved b)) - ) => - FromJSON (WithJSONWarnings (Unresolved (LockedLocation a b))) where - parseJSON v = withObjectWarnings "LockedLocation" (\o -> lockedExact o <|> lockedCompleted o) v - where - lockedExact o = do - exact <- jsonSubWarnings $ o ..: "exact" - pure $ LockedExact <$> exact - lockedCompleted o = do - original <- jsonSubWarnings $ o ..: "original" - completed <- jsonSubWarnings $ o ..: "completed" - pure $ LockedCompleted <$> original <*> completed - -data LockedPackage = LockedPackage - { lpLocation :: !(LockedLocation RawPackageLocationImmutable PackageLocationImmutable) - , lpFlags :: !(Map FlagName Bool) - , lpHidden :: !Bool - , lpGhcOptions :: ![Text] - , lpFromSnapshot :: !FromSnapshot - } deriving (Show, Eq) - -instance ToJSON LockedPackage where - toJSON LockedPackage {..} = - let toBoolean FromSnapshot = True - toBoolean NotFromSnapshot = False - in object $ concat - [ ["location" .= lpLocation] - , if Map.null lpFlags then [] else ["flags" .= toCabalStringMap lpFlags] - , if lpFromSnapshot == FromSnapshot then [] else ["from-snapshot" .= toBoolean lpFromSnapshot] - , if not lpHidden then [] else ["hidden" .= lpHidden] - , if null lpGhcOptions then [] else ["ghc-options" .= lpGhcOptions] - ] +instance FromJSON (WithJSONWarnings (Unresolved LockedLocation)) where + parseJSON = + withObjectWarnings "LockedLocation" $ \o -> do + original <- jsonSubWarnings $ o ..: "original" + completed <- jsonSubWarnings $ o ..: "completed" + pure $ (\single c -> LockedLocation (unSingleRPLI single) c) <$> original <*> completed -- Special wrapper extracting only 1 RawPackageLocationImmutable -- serialization should not produce locations with multiple subdirs @@ -131,61 +49,23 @@ instance FromJSON (WithJSONWarnings (Unresolved SingleRPLI)) where do WithJSONWarnings unresolvedRPLIs ws <- parseJSON v let withWarnings x = WithJSONWarnings x ws - pure $ withWarnings $ Unresolved $ \mdir -> do - rpli <- NE.head <$> resolvePaths mdir unresolvedRPLIs - pure $ SingleRPLI rpli - -instance FromJSON (WithJSONWarnings (Unresolved LockedPackage)) where - parseJSON = withObjectWarnings "LockedPackage" $ \o -> do - let unwrap (LockedExact c) = LockedExact c - unwrap (LockedCompleted single c) = LockedCompleted (unSingleRPLI single) c - location <- jsonSubWarnings $ o ..: "location" - lpFlags <- fmap unCabalStringMap $ o ..:? "flags" ..!= Map.empty - lpHidden <- o ..:? "hidden" ..!= False - lpGhcOptions <- o ..:? "ghc-options" ..!= [] - let fromBoolean True = FromSnapshot - fromBoolean False = NotFromSnapshot - lpFromSnapshot <- fmap fromBoolean $ o ..:? "from-snapshot" ..!= True - pure $ (\lpLocation -> LockedPackage {..}) <$> fmap unwrap location + pure $ withWarnings $ SingleRPLI . NE.head <$> unresolvedRPLIs -data Locked = Locked - { lckStackSha :: !SHA256 - , lckStackSize :: !FileSize - , lckCompiler :: WantedCompiler - , lckSnapshots :: NE.NonEmpty (LockedLocation RawSnapshotLocation CompletedSnapshotLocation) - , lckPackages :: Map PackageName LockedPackage - } - deriving (Show, Eq) +newtype Locked = Locked [LockedLocation] -instance FromJSON (WithJSONWarnings (Unresolved Locked)) where - parseJSON = withObjectWarnings "Locked" $ \o -> do - stackYaml <- o ..: "stack-yaml" - lckStackSha <- stackYaml ..: "sha256" - lckStackSize <- stackYaml ..: "size" - lckCompiler <- o ..: "compiler" - snapshots <- jsonSubWarningsT $ o ..: "snapshots" - packages <- fmap unCabalStringMap $ jsonSubWarningsT $ o ..: "packages" - pure $ (\lckSnapshots lckPackages -> Locked {..}) <$> sequenceA snapshots <*> sequenceA packages - -instance ToJSON Locked where - toJSON Locked {..} = - object - [ "stack-yaml" .= object ["sha256" .= lckStackSha, "size" .= lckStackSize] - , "compiler" .= lckCompiler - , "snapshots" .= lckSnapshots - , "packages" .= toCabalStringMap lckPackages - ] +instance FromJSON (Unresolved Locked) where + parseJSON v = do + locs <- unWarningParser $ jsonSubWarningsT (lift $ parseJSON v) + pure $ Locked <$> sequenceA locs loadYamlThrow :: HasLogFunc env - => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a + => (Value -> Yaml.Parser a) -> Path Abs File -> RIO env a loadYamlThrow parser path = do val <- liftIO $ Yaml.decodeFileThrow (toFilePath path) case Yaml.parseEither parser val of Left err -> throwIO $ Yaml.AesonException err - Right (WithJSONWarnings res warnings) -> do - logJSONWarnings (toFilePath path) warnings - return res + Right res -> return res lockCachedWanted :: (HasPantryConfig env, HasProcessContext env, HasLogFunc env) @@ -199,162 +79,22 @@ lockCachedWanted :: lockCachedWanted stackFile resolver fillWanted = do lockFile <- liftIO $ addFileExtension "lock" stackFile lockExists <- doesFileExist lockFile - if not lockExists - then do - logDebug "Lock file doesn't exist" - (snap, slocs, completed) <- - loadAndCompleteSnapshotRaw resolver Map.empty - let compiler = snapshotCompiler snap - snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap) - (wanted, prjCompleted) <- fillWanted Map.empty compiler snPkgs - (stackSha, stackSize) <- shaSize stackFile - let pkgs = mapMaybe (uncurry $ maybeWantedLockedPackage wanted) - (completed <> prjCompleted) - snapshots <- for slocs $ \(orig, sloc) -> do - case sloc of - SLFilePath fp -> do - (sha, size) <- shaSize (resolvedAbsolute fp) - pure $ LockedCompleted orig (CSLFilePath fp sha size) - SLCompiler c -> - pure $ LockedExact (CSLCompiler c) - sl@(SLUrl url blobKey) -> - let csurl = CSLUrl url blobKey - in if toRawSL sl == orig - then pure $ LockedExact csurl - else pure $ LockedCompleted orig csurl - liftIO $ Yaml.encodeFile (toFilePath lockFile) $ - Locked { lckStackSha = stackSha - , lckStackSize = stackSize - , lckCompiler = smwCompiler wanted - , lckSnapshots = snapshots - , lckPackages = Map.fromList pkgs - } - pure wanted - else do - lmt <- liftIO $ getModificationTime lockFile - unresolvedLocked <- loadYamlThrow parseJSON lockFile - locked0 <- resolvePaths (Just $ parent stackFile) unresolvedLocked - let pkgLocCache = Map.fromList $ - map (lockPair . lpLocation) $ Map.elems (lckPackages locked0) - lockPair (LockedExact compl) = (toRawPLI compl, compl) - lockPair (LockedCompleted orig compl) = (orig, compl) - sha0 = lckStackSha locked0 - size0 = lckStackSize locked0 - result <- liftIO $ checkOutdated stackFile lmt size0 sha0 - let (syOutdated, sySha, sySize) = - case result of - Right () -> (False, sha0, size0) - Left (sha, sz) -> (True, sha, sz) - let lockedSnapshots = Map.fromList $ map toPair $ NE.toList (lckSnapshots locked0) - toPair (LockedExact compl) = (toRawSL' compl, compl) - toPair (LockedCompleted orig compl) = (orig, compl) - toRawSL' (CSLCompiler c) = RSLCompiler c - toRawSL' (CSLUrl url blobKey) = toRawSL (SLUrl url blobKey) - toRawSL' (CSLFilePath fp _ _) = toRawSL (SLFilePath fp) - layers <- readSnapshotLayers resolver - (outdated, valid) <- - fmap partitionEithers . forM (NE.toList layers) $ \(rsloc, sloc) -> liftIO $ - let toLockedSL _orig compl@(CSLCompiler _) = LockedExact compl - toLockedSL orig compl@(CSLUrl url bk) - | toRawSL (SLUrl url bk) == orig = LockedExact compl - toLockedSL orig compl = LockedCompleted orig compl - outdatedLoc = Left . toLockedSL rsloc - validLoc = Right . toLockedSL rsloc - in case Map.lookup rsloc lockedSnapshots of - Nothing -> - case sloc of - SLFilePath fp -> do - (sha, size) <- shaSize $ resolvedAbsolute fp - pure $ outdatedLoc (CSLFilePath fp sha size) - SLCompiler c -> - pure $ outdatedLoc (CSLCompiler c) - SLUrl u bk -> - pure $ outdatedLoc (CSLUrl u bk) - Just loc@(CSLFilePath fp sha size) -> do - result' <- checkOutdated (resolvedAbsolute fp) lmt size sha - case result' of - Right () -> pure $ validLoc loc - Left (sha', size') -> - pure $ outdatedLoc (CSLFilePath fp sha' size') - Just immutable -> - pure $ validLoc immutable - let lockIsUpToDate = not syOutdated && null outdated - if lockIsUpToDate - then do - logDebug "Lock file exist and is up-to-date" - let compiler = lckCompiler locked0 - pkgs = flip Map.mapWithKey (lckPackages locked0) $ \nm lp haddocks -> do - run <- askRunInIO - let location = case lpLocation lp of - LockedExact c -> c - LockedCompleted _ c -> c - common = CommonPackage - { cpName = nm - , cpGPD = run $ loadCabalFileImmutable location - , cpFlags = lpFlags lp - , cpGhcOptions = lpGhcOptions lp - , cpHaddocks = haddocks - } - pure $ DepPackage{ dpLocation = PLImmutable location - , dpCommon = common - , dpHidden = lpHidden lp - , dpFromSnapshot = lpFromSnapshot lp - } - (wanted, _prjCompleted) <- fillWanted pkgLocCache compiler pkgs - pure wanted - else do - logDebug "Lock file exist but is not up-to-date" - (snap, _slocs, completed) <- - loadAndCompleteSnapshotRaw resolver pkgLocCache - let compiler = snapshotCompiler snap - snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap) - (wanted, prjCompleted) <- fillWanted pkgLocCache compiler snPkgs - let pkgs = mapMaybe (uncurry $ maybeWantedLockedPackage wanted) - (completed <> prjCompleted) - liftIO $ Yaml.encodeFile (toFilePath lockFile) $ - Locked { lckStackSha = sySha - , lckStackSize = sySize - , lckCompiler = smwCompiler wanted - , lckSnapshots = NE.fromList $ outdated ++ valid - , lckPackages = Map.fromList pkgs - } - pure wanted - where - maybeWantedLockedPackage wanted rpli pli = do - let name = pkgName (packageLocationIdent pli) - dp <- Map.lookup name (smwDeps wanted) - let common = dpCommon dp - pure ( name - , LockedPackage { lpFlags = cpFlags common - , lpFromSnapshot = dpFromSnapshot dp - , lpGhcOptions = cpGhcOptions common - , lpHidden = dpHidden dp - , lpLocation = - if toRawPLI pli == rpli - then LockedExact pli - else LockedCompleted rpli pli - } - ) - shaSize fp = do - bs <- B.readFile $ toFilePath fp - let size = FileSize . fromIntegral $ B.length bs - sha = SHA256.hashBytes bs - return (sha, size) - -checkOutdated :: - Path Abs File - -> UTCTime - -> FileSize - -> SHA256 - -> IO (Either (SHA256, FileSize) ()) -checkOutdated fp dt size sha = do - mt <- getModificationTime fp - if mt < dt - then pure $ Right () - else do - bs <- B.readFile $ toFilePath fp - let newSize = FileSize . fromIntegral $ B.length bs - newSha = SHA256.hashBytes bs - if newSize /= size || sha /= newSha - then pure $ Left (newSha, newSize) - else pure $ Right () + pkgLocCache <- if not lockExists + then do + logDebug "Lock file doesn't exist" + pure Map.empty + else do + logDebug "Using package location completions from a lock file" + unresolvedLocked <- loadYamlThrow parseJSON lockFile + Locked locked0 <- resolvePaths (Just $ parent stackFile) unresolvedLocked + pure $ Map.fromList [(orig, compl) | LockedLocation orig compl <- locked0] + + (snap, completed) <- + loadAndCompleteSnapshotRaw resolver pkgLocCache + let compiler = snapshotCompiler snap + snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap) + (wanted, prjCompleted) <- fillWanted Map.empty compiler snPkgs + liftIO $ Yaml.encodeFile (toFilePath lockFile) $ + map (uncurry LockedLocation) $ + prjCompleted <> completed + pure wanted diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs index e16467c59f..40970b48dd 100644 --- a/src/Stack/SourceMap.hs +++ b/src/Stack/SourceMap.hs @@ -260,7 +260,7 @@ loadProjectSnapshotCandidate :: -> Bool -> RIO env (SnapshotCandidate env) loadProjectSnapshotCandidate loc printWarnings buildHaddocks = do - (snapshot, _, _) <- loadAndCompleteSnapshotRaw loc Map.empty + (snapshot, _) <- loadAndCompleteSnapshotRaw loc Map.empty deps <- Map.traverseWithKey (snapToDepPackage False) (snapshotPackages snapshot) let wc = snapshotCompiler snapshot globals <- Map.map GlobalPackageVersion <$> globalsFromHints wc diff --git a/src/Stack/Types/SourceMap.hs b/src/Stack/Types/SourceMap.hs index 4af5ed4731..56b712ff61 100644 --- a/src/Stack/Types/SourceMap.hs +++ b/src/Stack/Types/SourceMap.hs @@ -46,7 +46,7 @@ data CommonPackage = CommonPackage data FromSnapshot = FromSnapshot | NotFromSnapshot - deriving (Show, Eq) + deriving (Show) -- | A view of a dependency package, specified in stack.yaml data DepPackage = DepPackage diff --git a/src/test/Stack/LockSpec.hs b/src/test/Stack/LockSpec.hs index 1b35852261..aa67d58dcf 100644 --- a/src/test/Stack/LockSpec.hs +++ b/src/test/Stack/LockSpec.hs @@ -4,9 +4,7 @@ module Stack.LockSpec where -import Data.Aeson.Extended (WithJSONWarnings(..)) import Data.ByteString (ByteString) -import qualified Data.Map as Map import qualified Data.Yaml as Yaml import Distribution.Types.PackageName (mkPackageName) import Distribution.Types.Version (mkVersion) @@ -14,7 +12,6 @@ import Pantry import qualified Pantry.SHA256 as SHA256 import RIO import Stack.Lock -import Stack.Types.SourceMap (FromSnapshot(..)) import Test.Hspec import Text.RawString.QQ @@ -32,110 +29,58 @@ decodeLocked bs = do val <- Yaml.decodeThrow bs case Yaml.parseEither Yaml.parseJSON val of Left err -> throwIO $ Yaml.AesonException err - Right (WithJSONWarnings res warnings) -> do - unless (null warnings) $ - throwIO $ Yaml.AesonException $ "Unexpected warnings: " ++ show warnings + Right res -> do -- we just assume no file references resolvePaths Nothing res spec :: Spec spec = do - it "parses lock file (empty with GHC resolver)" $ do + it "parses lock file (empty)" $ do let lockFile :: ByteString lockFile = [r|#some -packages: {} -snapshots: -- completed: - compiler: ghc-8.2.2 - original: - compiler: ghc-8.2.2 -stack-yaml: - size: 90 - sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 -compiler: ghc-8.2.2 +[] |] - pkgImm <- lckPackages <$> decodeLocked lockFile - Map.toList pkgImm `shouldBe` [] - it "parses lock file (empty with LTS)" $ do + Locked pkgImm <- decodeLocked lockFile + pkgImm `shouldBe` [] + it "parses lock file (wai + warp)" $ do let lockFile :: ByteString lockFile = [r|#some -packages: {} -snapshots: -- completed: - sha: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a - size: 527801 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml - original: lts-11.22 -- completed: - compiler: ghc-8.2.2 - original: - compiler: ghc-8.2.2 -stack-yaml: - size: 90 - sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 -compiler: ghc-8.2.2 +- original: + subdir: wai + git: https://github.com/yesodweb/wai.git + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 + completed: + subdir: wai + cabal-file: + size: 1765 + sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 + name: wai + version: 3.2.1.2 + git: https://github.com/yesodweb/wai.git + pantry-tree: + size: 714 + sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 +- original: + subdir: warp + git: https://github.com/yesodweb/wai.git + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 + completed: + subdir: warp + cabal-file: + size: 10725 + sha256: cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758 + name: warp + version: 3.2.25 + git: https://github.com/yesodweb/wai.git + pantry-tree: + size: 5103 + sha256: f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 |] - pkgImm <- lckPackages <$> decodeLocked lockFile - Map.toList pkgImm `shouldBe` [] - it "parses lock file (non empty)" $ do - let lockFile :: ByteString - lockFile = - [r|#some -packages: - wai: - location: - original: - subdir: wai - git: https://github.com/yesodweb/wai.git - commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 - completed: - subdir: wai - cabal-file: - size: 1765 - sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 - name: wai - version: 3.2.1.2 - git: https://github.com/yesodweb/wai.git - pantry-tree: - size: 714 - sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 - commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 - warp: - location: - original: - subdir: warp - git: https://github.com/yesodweb/wai.git - commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 - completed: - subdir: warp - cabal-file: - size: 10725 - sha256: cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758 - name: warp - version: 3.2.25 - git: https://github.com/yesodweb/wai.git - pantry-tree: - size: 5103 - sha256: f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a - commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 -snapshots: -- completed: - sha: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a - size: 527801 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml - original: lts-11.22 -- completed: - compiler: ghc-8.2.2 - original: - compiler: ghc-8.2.2 -stack-yaml: - size: 90 - sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 -compiler: ghc-8.2.2 -|] - pkgImm <- Map.toList . lckPackages <$> decodeLocked lockFile + Locked pkgImm <- decodeLocked lockFile let waiSubdirRepo subdir = Repo { repoType = RepoGit , repoUrl = "https://github.com/yesodweb/wai.git" @@ -149,10 +94,9 @@ compiler: ghc-8.2.2 , rpmCabal = Nothing } pkgImm `shouldBe` - [ ( "wai" - , lockedPackageWithLocations - (RPLIRepo (waiSubdirRepo "wai") emptyRPM) - (PLIRepo (waiSubdirRepo "wai") + [ LockedLocation + (RPLIRepo (waiSubdirRepo "wai") emptyRPM) + (PLIRepo (waiSubdirRepo "wai") (PackageMetadata { pmIdent = PackageIdentifier { pkgName = mkPackageName "wai" @@ -169,11 +113,9 @@ compiler: ghc-8.2.2 "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" 1765 })) - ) - , ( "warp" - , lockedPackageWithLocations - (RPLIRepo (waiSubdirRepo "warp") emptyRPM) - (PLIRepo (waiSubdirRepo "warp") + , LockedLocation + (RPLIRepo (waiSubdirRepo "warp") emptyRPM) + (PLIRepo (waiSubdirRepo "warp") (PackageMetadata { pmIdent = PackageIdentifier { pkgName = mkPackageName "warp" @@ -190,48 +132,29 @@ compiler: ghc-8.2.2 "cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758" 10725 })) - ) ] it "parses snapshot lock file (non empty)" $ do let lockFile :: ByteString lockFile = [r|#some -packages: - string-quote: - location: - original: - hackage: string-quote-0.0.1 - completed: - hackage: string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3,758 - pantry-tree: - size: 273 - sha256: d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f -snapshots: -- completed: - sha: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a - size: 527801 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml - original: lts-11.22 -- completed: - compiler: ghc-8.2.2 - original: - compiler: ghc-8.2.2 -stack-yaml: - size: 90 - sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 -compiler: ghc-8.2.2 +- original: + hackage: string-quote-0.0.1 + completed: + hackage: string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3,758 + pantry-tree: + size: 273 + sha256: d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f |] - pkgImm <- Map.toList . lckPackages <$> decodeLocked lockFile + Locked pkgImm <- decodeLocked lockFile pkgImm `shouldBe` - [("string-quote" - , lockedPackageWithLocations - ( RPLIHackage + [ LockedLocation + (RPLIHackage (PackageIdentifierRevision (mkPackageName "string-quote") (mkVersion [0, 0, 1]) CFILatest) Nothing) - ( PLIHackage + (PLIHackage (PackageIdentifier { pkgName = mkPackageName "string-quote" , pkgVersion = mkVersion [0, 0, 1] @@ -243,16 +166,17 @@ compiler: ghc-8.2.2 (BlobKey (decodeSHA "d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f") - (FileSize 273)))) + (FileSize 273))) ) ] - -lockedPackageWithLocations :: RawPackageLocationImmutable -> PackageLocationImmutable -> LockedPackage -lockedPackageWithLocations rpli pli = - LockedPackage{ lpLocation = LockedLocation rpli pli - , lpFlags = mempty - , lpGhcOptions = mempty - , lpFromSnapshot = FromSnapshot - , lpHidden = False - } +-- +--lockedPackageWithLocations :: RawPackageLocationImmutable -> PackageLocationImmutable -> LockedPackage +--lockedPackageWithLocations rpli pli = +-- LockedPackage{ lpLocation = LockedLocation rpli pli +-- , lpFlags = mempty +-- , lpGhcOptions = mempty +-- , lpFromSnapshot = FromSnapshot +-- , lpHidden = False +-- } +-- diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index e3ee6eaf94..1c724accd7 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -70,7 +69,6 @@ module Pantry , RawPackageLocation (..) , PackageLocation (..) , toRawPL - , toRawPLI , RawPackageLocationImmutable (..) , PackageLocationImmutable (..) @@ -94,7 +92,6 @@ module Pantry , loadRawSnapshotLayer , loadSnapshotLayer , loadSnapshot - , readSnapshotLayers , loadAndCompleteSnapshot , loadAndCompleteSnapshotRaw , CompletedPLI @@ -200,12 +197,11 @@ import RIO.PrettyPrint import RIO.Process import RIO.Directory (getAppUserDataDirectory) import qualified Data.Yaml as Yaml -import Data.Aeson.Extended (unWarningParser, (...:?), WithJSONWarnings (..), Value) +import Data.Aeson.Extended (WithJSONWarnings (..), Value) import Data.Aeson.Types (parseEither) import Data.Monoid (Endo (..)) import Pantry.HTTP import Data.Char (isHexDigit) -import Data.List.NonEmpty (NonEmpty((:|)), (<|)) -- | Create a new 'PantryConfig' with the given settings. -- @@ -906,7 +902,7 @@ loadSnapshotRaw loc = do , rsPackages = mempty , rsDrop = mempty } - Right (rsl, _sha) -> do + Right rsl -> do snap0 <- loadSnapshotRaw $ rslParent rsl (packages, unused) <- addPackagesToSnapshot @@ -963,24 +959,6 @@ loadSnapshot loc = do } type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) -type CompletedSL = (RawSnapshotLocation, SnapshotLocation) - --- | Get completed locations of all snapshot layers from a 'RawSnapshotLocation'. --- Uses only fields 'compiler', 'parent' and 'solver' without parsing other --- snapshot fields --- --- @since 0.1.0.0 -readSnapshotLayers :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawSnapshotLocation - -> RIO env (NonEmpty CompletedSL) -readSnapshotLayers loc = do - eres <- loadRawSnapshotLayerParent loc - case eres of - Left wc -> - pure $ (RSLCompiler wc, SLCompiler wc) :| [] - Right (RawSnapshotLayerParent p, sloc) -> - (sloc <|) <$> readSnapshotLayers p -- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting -- any incomplete package locations @@ -990,7 +968,7 @@ loadAndCompleteSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file - -> RIO env (Snapshot, NonEmpty CompletedSL, [CompletedPLI]) + -> RIO env (Snapshot, [CompletedPLI]) loadAndCompleteSnapshot loc cachedPL = loadAndCompleteSnapshotRaw (toRawSL loc) cachedPL @@ -1002,7 +980,7 @@ loadAndCompleteSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file - -> RIO env (Snapshot, NonEmpty CompletedSL, [CompletedPLI]) + -> RIO env (Snapshot, [CompletedPLI]) loadAndCompleteSnapshotRaw loc cachePL = do eres <- loadRawSnapshotLayer loc case eres of @@ -1012,9 +990,9 @@ loadAndCompleteSnapshotRaw loc cachePL = do , snapshotPackages = mempty , snapshotDrop = mempty } - in pure (snapshot, (RSLCompiler wc, SLCompiler wc) :| [], []) - Right (rsl, sloc) -> do - (snap0, slocs0, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cachePL + in pure (snapshot, []) + Right rsl -> do + (snap0, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cachePL (packages, completed, unused) <- addAndCompletePackagesToSnapshot loc @@ -1033,7 +1011,7 @@ loadAndCompleteSnapshotRaw loc cachePL = do , snapshotPackages = packages , snapshotDrop = apcDrop unused } - return (snapshot, sloc <| slocs0, completed0 ++ completed) + return (snapshot, completed0 ++ completed) data SingleOrNot a = Single !a @@ -1165,7 +1143,7 @@ cachedSnapshotCompletePackageLocation cachePackages rpli = do -- set. -- -- Returns any of the 'AddPackagesConfig' values not used and also all --- package location completions. +-- non-trivial package location completions. -- -- @since 0.1.0.0 addAndCompletePackagesToSnapshot @@ -1193,7 +1171,10 @@ addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig dro , spHidden = Map.findWithDefault False name hiddens , spGhcOptions = Map.findWithDefault [] name options }) - pure (p:ps, (rawLoc, complLoc):completed) + completed' = if toRawPLI complLoc == rawLoc + then completed + else (rawLoc, complLoc):completed + pure (p:ps, completed') (revNew, revCompleted) <- foldM addPackage ([], []) newPackages let (newSingles, newMultiples) = partitionEithers @@ -1220,54 +1201,6 @@ addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig dro pure (allPackages, reverse revCompleted, unused) --- helper data type for reading only parent snapshot locaitons -newtype RawSnapshotLayerParent = RawSnapshotLayerParent RawSnapshotLocation - -instance Yaml.FromJSON (Unresolved RawSnapshotLayerParent) where - parseJSON = Yaml.withObject "Snapshot" $ \o -> do - mcompiler <- o Yaml..:? "compiler" - mresolver <- unWarningParser $ o ...:? ["snapshot", "resolver"] - unresolvedSnapshotParent <- - case (mcompiler, mresolver) of - (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" - (Just compiler, Nothing) -> pure $ pure (RSLCompiler compiler) - (_, Just (WithJSONWarnings (Unresolved usl) _)) -> pure $ Unresolved $ \mdir -> do - sl <- usl mdir - case (sl, mcompiler) of - (RSLCompiler c1, Just c2) -> throwIO $ InvalidOverrideCompiler c1 c2 - _ -> pure sl - - pure $ RawSnapshotLayerParent <$> unresolvedSnapshotParent - -loadRawSnapshotLayerParent - :: (HasPantryConfig env, HasLogFunc env) - => RawSnapshotLocation - -> RIO env (Either WantedCompiler (RawSnapshotLayerParent, CompletedSL)) -loadRawSnapshotLayerParent (RSLCompiler compiler) = pure $ Left compiler -loadRawSnapshotLayerParent sl@(RSLUrl url blob) = - handleAny (throwIO . InvalidSnapshot sl) $ do - bs <- loadFromURL url blob - value <- Yaml.decodeThrow bs - lparent <- parserHelperLayerParent sl value Nothing - pure $ Right (lparent, (sl, SLUrl url (bsToBlobKey bs))) -loadRawSnapshotLayerParent sl@(RSLFilePath fp) = - handleAny (throwIO . InvalidSnapshot sl) $ do - value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - lparent <- parserHelperLayerParent sl value $ Just $ parent $ resolvedAbsolute fp - pure $ Right (lparent, (sl, SLFilePath fp)) - -parserHelperLayerParent - :: HasLogFunc env - => RawSnapshotLocation - -> Value - -> Maybe (Path Abs Dir) - -> RIO env RawSnapshotLayerParent -parserHelperLayerParent rsl val mdir = - case parseEither Yaml.parseJSON val of - Left e -> throwIO $ Couldn'tParseSnapshot rsl e - Right x -> do - resolvePaths mdir x - -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- -- Returns a 'Left' value if provided an 'SLCompiler' @@ -1278,19 +1211,19 @@ parserHelperLayerParent rsl val mdir = loadRawSnapshotLayer :: (HasPantryConfig env, HasLogFunc env) => RawSnapshotLocation - -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)) + -> RIO env (Either WantedCompiler RawSnapshotLayer) loadRawSnapshotLayer (RSLCompiler compiler) = pure $ Left compiler loadRawSnapshotLayer sl@(RSLUrl url blob) = handleAny (throwIO . InvalidSnapshot sl) $ do bs <- loadFromURL url blob value <- Yaml.decodeThrow bs snapshot <- warningsParserHelperRaw sl value Nothing - pure $ Right (snapshot, (sl, SLUrl url (bsToBlobKey bs))) + pure $ Right snapshot loadRawSnapshotLayer sl@(RSLFilePath fp) = handleAny (throwIO . InvalidSnapshot sl) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp snapshot <- warningsParserHelperRaw sl value $ Just $ parent $ resolvedAbsolute fp - pure $ Right (snapshot, (sl, SLFilePath fp)) + pure $ Right snapshot -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- diff --git a/subs/pantry/src/Pantry/Internal.hs b/subs/pantry/src/Pantry/Internal.hs index 1423dee364..be603a94f9 100644 --- a/subs/pantry/src/Pantry/Internal.hs +++ b/subs/pantry/src/Pantry/Internal.hs @@ -9,7 +9,6 @@ module Pantry.Internal , pcHpackExecutable , normalizeParents , makeTarRelative - , Unresolved (..) ) where import Control.Exception (assert) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 0b2148e050..c2c548e0dc 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -44,7 +44,7 @@ module Pantry.Types , renderTree , parseTree , SHA256 - , Unresolved (..) + , Unresolved , resolvePaths , Package (..) , PackageCabal (..) @@ -294,7 +294,7 @@ instance NFData (ResolvedPath t) data RawPackageLocation = RPLImmutable !RawPackageLocationImmutable | RPLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Generic) instance NFData RawPackageLocation -- | Location to load a package from. Can either be immutable (see @@ -305,17 +305,13 @@ instance NFData RawPackageLocation data PackageLocation = PLImmutable !PackageLocationImmutable | PLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Generic) instance NFData PackageLocation instance Display PackageLocation where display (PLImmutable loc) = display loc display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp -instance ToJSON PackageLocation where - toJSON (PLImmutable pli) = toJSON pli - toJSON (PLMutable resolved) = toJSON (resolvedRelative resolved) - -- | Convert `PackageLocation` to its "raw" equivalent -- -- @since 0.1.0.0 From bbc35419ebe0f14f805c0de9b3f43ce33df088af Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Apr 2019 12:47:54 +0300 Subject: [PATCH 38/65] Revert back `withStorage_` signature restricted to `RIO` --- subs/pantry/src/Pantry/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 8098fc11f5..7a2e1484e7 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -205,7 +205,7 @@ newtype Revision = Revision Word -- whether a pool is used, and the default implementation in -- "Pantry.Storage" does not use a pool. data Storage = Storage - { withStorage_ :: forall m a. MonadUnliftIO m => ReaderT SqlBackend m a -> m a + { withStorage_ :: forall env a. HasLogFunc env => ReaderT SqlBackend (RIO env) a -> RIO env a , withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a } From 89002d3db9f2f054a0d522ba7a629f6e2ff13f07 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 23 Apr 2019 14:08:44 +0300 Subject: [PATCH 39/65] Minor pantry cleanups * loadGlobalHints caches inside the pantry dir * More Has instances for PantryApp * Use a Snapshot, not a RawSnapshot, in curator --- src/Stack/SourceMap.hs | 3 +- src/Stack/Types/Config.hs | 7 --- subs/curator/app/Main.hs | 48 +++---------------- subs/curator/src/Curator/Snapshot.hs | 22 ++++----- subs/curator/src/Curator/Unpack.hs | 20 ++++---- subs/pantry/src/Pantry.hs | 28 ++++++++--- subs/pantry/src/Pantry/Internal.hs | 1 + subs/pantry/src/Pantry/Types.hs | 8 ++++ .../pantry/test/Pantry/GlobalHintsSpec.hs | 37 +++++++------- 9 files changed, 77 insertions(+), 97 deletions(-) rename src/test/Stack/SourceMapSpec.hs => subs/pantry/test/Pantry/GlobalHintsSpec.hs (53%) diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs index 986525ab5e..98a4346ff3 100644 --- a/src/Stack/SourceMap.hs +++ b/src/Stack/SourceMap.hs @@ -141,8 +141,7 @@ globalsFromHints :: => WantedCompiler -> RIO env (Map PackageName Version) globalsFromHints compiler = do - ghfp <- globalHintsFile - mglobalHints <- loadGlobalHints ghfp compiler + mglobalHints <- loadGlobalHints compiler case mglobalHints of Just hints -> pure hints Nothing -> do diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 69e9e1e9c0..515a047067 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -53,7 +53,6 @@ module Stack.Types.Config ,parseGHCVariant ,HasGHCVariant(..) ,snapshotsDir - ,globalHintsFile -- ** EnvConfig & HasEnvConfig ,EnvConfig(..) ,HasSourceMap(..) @@ -1247,12 +1246,6 @@ snapshotsDir = do platform <- platformGhcRelDir return $ root relDirSnapshots platform --- | Cached global hints file -globalHintsFile :: (MonadReader env m, HasConfig env) => m (Path Abs File) -globalHintsFile = do - root <- view stackRootL - pure $ root relDirGlobalHints relFileGlobalHintsYaml - -- | Installation root for dependencies installationRootDeps :: (HasEnvConfig env) => RIO env (Path Abs Dir) installationRootDeps = do diff --git a/subs/curator/app/Main.hs b/subs/curator/app/Main.hs index b59d1fa2d1..8483aebe62 100644 --- a/subs/curator/app/Main.hs +++ b/subs/curator/app/Main.hs @@ -16,8 +16,6 @@ import Paths_curator (version) import qualified RIO.ByteString.Lazy as BL import RIO.List (stripPrefix) import qualified RIO.Map as Map -import RIO.PrettyPrint -import RIO.PrettyPrint.StylesUpdate import RIO.Process import qualified RIO.Text as T import RIO.Time @@ -106,7 +104,7 @@ update = do constraints :: Target -> RIO PantryApp () constraints target = - withFixedColorTerm $ case target of + case target of TargetLts x y | y > 0 -> do let prev = y - 1 url = concat [ "https://raw.githubusercontent.com/commercialhaskell/stackage-constraints/master/lts-" @@ -151,10 +149,10 @@ snapshot = do complete <- completeSnapshotLayer incomplete liftIO $ encodeFile snapshotFilename complete -loadSnapshotYaml :: RIO PantryApp Pantry.RawSnapshot +loadSnapshotYaml :: RIO PantryApp Pantry.Snapshot loadSnapshotYaml = do abs' <- resolveFile' snapshotFilename - loadSnapshot $ SLFilePath $ + fmap fst $ loadAndCompleteSnapshot $ SLFilePath $ ResolvedPath (RelFilePath (fromString snapshotFilename)) abs' checkSnapshot :: RIO PantryApp () @@ -162,39 +160,7 @@ checkSnapshot = do logInfo "Checking dependencies in snapshot.yaml" decodeFileThrow constraintsFilename >>= \constraints' -> do snapshot' <- loadSnapshotYaml - withFixedColorTerm $ checkDependencyGraph constraints' snapshot' - -data FixedColorTermApp = FixedColorTermApp - { fctApp :: PantryApp - , fctWidth :: Int - } - -pantryAppL :: Lens' FixedColorTermApp PantryApp -pantryAppL = lens fctApp (\s a -> s{ fctApp = a}) - -instance HasLogFunc FixedColorTermApp where - logFuncL = pantryAppL.logFuncL - -instance HasStylesUpdate FixedColorTermApp where - stylesUpdateL = lens (const $ StylesUpdate []) (\s _ -> s) - -instance HasTerm FixedColorTermApp where - useColorL = lens (const True) (\s _ -> s) - termWidthL = lens fctWidth (\s w -> s{ fctWidth = w }) - -instance HasPantryConfig FixedColorTermApp where - pantryConfigL = pantryAppL.pantryConfigL - -instance HasProcessContext FixedColorTermApp where - processContextL = pantryAppL.processContextL - -withFixedColorTerm :: RIO FixedColorTermApp a -> RIO PantryApp a -withFixedColorTerm action = do - app <- ask - runRIO (FixedColorTermApp app defaultTerminalWidth) action - -defaultTerminalWidth :: Int -defaultTerminalWidth = 100 + checkDependencyGraph constraints' snapshot' unpackDir :: FilePath unpackDir = "unpack-dir" @@ -202,9 +168,7 @@ unpackDir = "unpack-dir" unpackFiles :: RIO PantryApp () unpackFiles = do logInfo "Unpacking files" - abs' <- resolveFile' snapshotFilename - snapshot' <- loadSnapshot $ SLFilePath $ - ResolvedPath (RelFilePath (fromString snapshotFilename)) abs' + snapshot' <- loadSnapshotYaml constraints' <- decodeFileThrow constraintsFilename dest <- resolveDir' unpackDir unpackSnapshot constraints' snapshot' dest @@ -222,7 +186,7 @@ hackageDistro target = do logInfo "Uploading Hackage distro for snapshot.yaml" snapshot' <- loadSnapshotYaml let packageVersions = - Map.mapMaybe (snapshotVersion . rspLocation) (rsPackages snapshot') + Map.mapMaybe (snapshotVersion . spLocation) (snapshotPackages snapshot') uploadHackageDistro target packageVersions uploadDocs' :: Target -> RIO PantryApp () diff --git a/subs/curator/src/Curator/Snapshot.hs b/subs/curator/src/Curator/Snapshot.hs index db8d6bc52f..033098ce4e 100644 --- a/subs/curator/src/Curator/Snapshot.hs +++ b/subs/curator/src/Curator/Snapshot.hs @@ -134,18 +134,18 @@ instance Exception TraverseValidateExceptions checkDependencyGraph :: (HasTerm env, HasProcessContext env, HasPantryConfig env) => Constraints - -> RawSnapshot + -> Snapshot -> RIO env () checkDependencyGraph constraints snapshot = do - let compiler = rsCompiler snapshot + let compiler = snapshotCompiler snapshot compilerVer = case compiler of WCGhc v -> v WCGhcGit {} -> error "GHC-GIT is not supported" WCGhcjs _ _ -> error "GHCJS is not supported" let snapshotPackages = Map.fromList - [ (pn, snapshotVersion (rspLocation sp)) - | (pn, sp) <- Map.toList (rsPackages snapshot) + [ (pn, snapshotVersion (spLocation sp)) + | (pn, sp) <- Map.toList (Pantry.snapshotPackages snapshot) ] ghcBootPackages0 <- liftIO $ getBootPackages compilerVer let ghcBootPackages = prunedBootPackages ghcBootPackages0 (Map.keysSet snapshotPackages) @@ -160,7 +160,7 @@ checkDependencyGraph constraints snapshot = do Just (Just cabalVersion) -> do let isWiredIn pn _ = pn `Set.member` wiredInGhcPackages (wiredIn, packages) = - Map.partitionWithKey isWiredIn (rsPackages snapshot) + Map.partitionWithKey isWiredIn (Pantry.snapshotPackages snapshot) if not (Map.null wiredIn) then do let errMsg = "GHC wired-in package can not be overriden" @@ -262,8 +262,8 @@ pkgBoundsError dep maintainers mdepVer isBoot users = display :: DT.Text a => a -> Text display = T.pack . DT.display -snapshotVersion :: RawPackageLocationImmutable -> Maybe Version -snapshotVersion (RPLIHackage (PackageIdentifierRevision _ v _) _) = Just v +snapshotVersion :: PackageLocationImmutable -> Maybe Version +snapshotVersion (PLIHackage (PackageIdentifier _ v) _ _) = Just v snapshotVersion _ = Nothing data DependencyError = @@ -350,10 +350,10 @@ getPkgInfo :: => Constraints -> Version -> PackageName - -> RawSnapshotPackage + -> SnapshotPackage -> RIO env PkgInfo -getPkgInfo constraints compilerVer pname rsp = do - gpd <- loadCabalFileRawImmutable (rspLocation rsp) +getPkgInfo constraints compilerVer pname sp = do + gpd <- loadCabalFileImmutable (spLocation sp) logDebug $ "Extracting deps for " <> displayShow pname let mpc = Map.lookup pname (consPackages constraints) skipBuild = maybe False pcSkipBuild mpc @@ -398,7 +398,7 @@ getPkgInfo constraints compilerVer pname rsp = do , comp == CompLibrary || comp == CompExecutable , dep <- deps ] return PkgInfo - { piVersion = snapshotVersion (rspLocation rsp) + { piVersion = snapshotVersion (spLocation sp) , piAllDeps = allDeps , piTreeDeps = treeDeps , piCabalVersion = C.specVersion $ C.packageDescription gpd diff --git a/subs/curator/src/Curator/Unpack.hs b/subs/curator/src/Curator/Unpack.hs index 13c6198237..b52088e242 100644 --- a/subs/curator/src/Curator/Unpack.hs +++ b/subs/curator/src/Curator/Unpack.hs @@ -19,25 +19,29 @@ import qualified RIO.Set as Set unpackSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Constraints - -> RawSnapshot + -> Snapshot -> Path Abs Dir -> RIO env () unpackSnapshot cons snap root = do unpacked <- parseRelDir "unpacked" (suffixes, flags, (skipTest, expectTestFailure), (skipBench, expectBenchmarkFailure), - (skipHaddock, expectHaddockFailure)) <- fmap fold $ for (rsPackages snap) $ \sp -> do - let pl = rspLocation sp - TreeKey (BlobKey sha _size) <- getRawPackageLocationTreeKey pl - PackageIdentifier name version <- getRawPackageLocationIdent pl + (skipHaddock, expectHaddockFailure)) <- fmap fold $ for (snapshotPackages snap) $ \sp -> do + let pl = spLocation sp + TreeKey (BlobKey sha _size) <- getPackageLocationTreeKey pl + let (PackageIdentifier name version) = + case pl of + PLIHackage ident _ _ -> ident + PLIArchive _ pm -> pmIdent pm + PLIRepo _ pm -> pmIdent pm let (flags, skipBuild, test, bench, haddock) = case Map.lookup name $ consPackages cons of Nothing -> (mempty, False, CAExpectSuccess, CAExpectSuccess, CAExpectSuccess) Just pc -> (pcFlags pc, pcSkipBuild pc, pcTests pc, pcBenchmarks pc, pcHaddock pc) - unless (flags == rspFlags sp) $ error $ unlines + unless (flags == spFlags sp) $ error $ unlines [ "mismatched flags for " ++ show pl - , " snapshot: " ++ show (rspFlags sp) + , " snapshot: " ++ show (spFlags sp) , " constraints: " ++ show flags ] if skipBuild @@ -58,7 +62,7 @@ unpackSnapshot cons snap root = do ignoringAbsence $ removeDirRecur destTmp ensureDir destTmp logInfo $ "Unpacking " <> display pl - unpackPackageLocationRaw destTmp pl + unpackPackageLocation destTmp pl renameDir destTmp dest pure ( Set.singleton suffix diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index e973c2d778..c5cbb7f6da 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -192,6 +192,7 @@ import qualified Hpack import qualified Hpack.Config as Hpack import Network.HTTP.Download import RIO.PrettyPrint +import RIO.PrettyPrint.StylesUpdate import RIO.Process import RIO.Directory (getAppUserDataDirectory) import qualified Data.Yaml as Yaml @@ -1380,6 +1381,9 @@ getTreeKey (PLIRepo _ pm) = pmTreeKey pm data PantryApp = PantryApp { paSimpleApp :: !SimpleApp , paPantryConfig :: !PantryConfig + , paUseColor :: !Bool + , paTermWidth :: !Int + , paStylesUpdate :: !StylesUpdate } simpleAppL :: Lens' PantryApp SimpleApp @@ -1394,6 +1398,11 @@ instance HasPantryConfig PantryApp where pantryConfigL = lens paPantryConfig (\x y -> x { paPantryConfig = y }) instance HasProcessContext PantryApp where processContextL = simpleAppL.processContextL +instance HasStylesUpdate PantryApp where + stylesUpdateL = lens paStylesUpdate (\x y -> x { paStylesUpdate = y }) +instance HasTerm PantryApp where + useColorL = lens paUseColor (\x y -> x { paUseColor = y }) + termWidthL = lens paTermWidth (\x y -> x { paTermWidth = y }) -- | Run some code against pantry using basic sane settings. -- @@ -1415,6 +1424,9 @@ runPantryApp f = runSimpleApp $ do PantryApp { paSimpleApp = sa , paPantryConfig = pc + , paTermWidth = 100 + , paUseColor = True + , paStylesUpdate = mempty } f @@ -1436,6 +1448,9 @@ runPantryAppClean f = liftIO $ withSystemTempDirectory "pantry-clean" $ \dir -> PantryApp { paSimpleApp = sa , paPantryConfig = pc + , paTermWidth = 100 + , paUseColor = True + , paStylesUpdate = mempty } f @@ -1443,17 +1458,17 @@ runPantryAppClean f = liftIO $ withSystemTempDirectory "pantry-clean" $ \dir -> -- -- @since 0.1.0.0 loadGlobalHints - :: HasTerm env - => Path Abs File -- ^ local cached file location - -> WantedCompiler + :: (HasTerm env, HasPantryConfig env) + => WantedCompiler -> RIO env (Maybe (Map PackageName Version)) -loadGlobalHints dest wc = +loadGlobalHints wc = inner False where inner alreadyDownloaded = do + dest <- getGlobalHintsFile req <- parseRequest "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/global-hints.yaml" downloaded <- download req dest - eres <- tryAny inner2 + eres <- tryAny (inner2 dest) mres <- case eres of Left e -> Nothing <$ logError ("Error when parsing global hints: " <> displayShow e) @@ -1472,7 +1487,8 @@ loadGlobalHints dest wc = pure Nothing _ -> pure mres - inner2 = liftIO + inner2 dest + = liftIO $ Map.lookup wc . fmap (fmap unCabalString . unCabalStringMap) <$> Yaml.decodeFileThrow (toFilePath dest) diff --git a/subs/pantry/src/Pantry/Internal.hs b/subs/pantry/src/Pantry/Internal.hs index be603a94f9..d536f5fc75 100644 --- a/subs/pantry/src/Pantry/Internal.hs +++ b/subs/pantry/src/Pantry/Internal.hs @@ -9,6 +9,7 @@ module Pantry.Internal , pcHpackExecutable , normalizeParents , makeTarRelative + , getGlobalHintsFile ) where import Control.Exception (assert) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 60ffd03b30..43d66e5faf 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -105,6 +105,7 @@ module Pantry.Types , toRawPM , cabalFileName , SnapshotCacheHash (..) + , getGlobalHintsFile ) where import RIO @@ -2115,3 +2116,10 @@ toRawSnapshotLayer sl = RawSnapshotLayer newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256} deriving (Show) + +-- | Get the path to the global hints cache file +getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File) +getGlobalHintsFile = do + root <- view $ pantryConfigL.to pcRootDir + globalHintsRelFile <- parseRelFile "global-hints-cache.yaml" + pure $ root globalHintsRelFile diff --git a/src/test/Stack/SourceMapSpec.hs b/subs/pantry/test/Pantry/GlobalHintsSpec.hs similarity index 53% rename from src/test/Stack/SourceMapSpec.hs rename to subs/pantry/test/Pantry/GlobalHintsSpec.hs index aa416049b7..8d01bf0a7e 100644 --- a/src/test/Stack/SourceMapSpec.hs +++ b/subs/pantry/test/Pantry/GlobalHintsSpec.hs @@ -1,33 +1,28 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Stack.SourceMapSpec (spec) where +module Pantry.GlobalHintsSpec (spec) where import Distribution.Types.PackageName (mkPackageName) import Distribution.Version (mkVersion) -import Stack.Options.GlobalParser (globalOptsFromMonoid) -import Stack.Prelude -import Stack.Runners -import Stack.SourceMap (loadGlobalHints) -import Stack.Types.Config (globalLogLevel) +import RIO +import Pantry (loadGlobalHints, WantedCompiler (..), runPantryAppClean) +import Pantry.Internal import Test.Hspec import qualified RIO.Map as Map -import RIO.ByteString (hPut) -import Path.IO (resolveFile') +import Path (toFilePath) spec :: Spec spec = do - describe "loadGlobalHints" $ do - let it' name inner = it name $ withSystemTempFile "global-hints.yaml" $ \fp h -> do - hPut h "this should be ignored" - hClose h :: IO () - abs' <- resolveFile' fp - globalOpts <- globalOptsFromMonoid False mempty - withRunnerGlobal globalOpts { globalLogLevel = LevelOther "silent" } $ inner abs' - it' "unknown compiler" $ \fp -> do - mmap <- loadGlobalHints fp $ WCGhc (mkVersion [0, 0, 0, 0, 0, 0, 0]) + let it' name inner = it name $ example $ runPantryAppClean $ do + file <- getGlobalHintsFile + writeFileBinary (toFilePath file) "this should be ignored" + inner + it' "unknown compiler" $ do + mmap <- loadGlobalHints $ WCGhc (mkVersion [0, 0, 0, 0, 0, 0, 0]) liftIO $ mmap `shouldBe` Nothing - it' "known compiler" $ \fp -> do - mmap <- loadGlobalHints fp $ WCGhc (mkVersion [8, 4, 3]) + it' "known compiler" $ do + mmap <- loadGlobalHints $ WCGhc (mkVersion [8, 4, 3]) case mmap of Nothing -> error "not found" Just m -> liftIO $ do @@ -35,8 +30,8 @@ spec = do Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 11, 1, 0]) Map.lookup (mkPackageName "bytestring") m `shouldBe` Just (mkVersion [0, 10, 8, 2]) Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing - it' "older known compiler" $ \fp -> do - mmap <- loadGlobalHints fp $ WCGhc (mkVersion [7, 8, 4]) + it' "older known compiler" $ do + mmap <- loadGlobalHints $ WCGhc (mkVersion [7, 8, 4]) case mmap of Nothing -> error "not found" Just m -> liftIO $ do From a6f4abff639897837bbbc19559110828cfdfc5b9 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Apr 2019 15:11:35 +0300 Subject: [PATCH 40/65] Switch to RIO from MonadIO for all queries --- subs/pantry/src/Pantry/Storage.hs | 149 +++++++++++------------------- 1 file changed, 56 insertions(+), 93 deletions(-) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index a54890dfa9..025d05a5e9 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -262,17 +262,16 @@ withStorage action = -- | This is a helper type to distinguish db queries between different rdbms backends. The important -- part is that the affects described in this data type should be semantically equivalent between -- the supported engines. -data RdbmsActions m a = RdbmsActions - { raSqlite :: !(ReaderT SqlBackend m a) +data RdbmsActions env a = RdbmsActions + { raSqlite :: !(ReaderT SqlBackend (RIO env) a) -- ^ A query that is specific to SQLite - , raPostgres :: !(ReaderT SqlBackend m a) + , raPostgres :: !(ReaderT SqlBackend (RIO env) a) } -- | This function provides a way to create queries supported by multiple sql backends. rdbmsAwareQuery - :: MonadIO m - => RdbmsActions m a - -> ReaderT SqlBackend m a + :: RdbmsActions env a + -> ReaderT SqlBackend (RIO env) a rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do rdbms <- connRDBMS <$> ask case rdbms of @@ -282,28 +281,24 @@ rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do getPackageNameById - :: MonadIO m - => PackageNameId - -> ReaderT SqlBackend m (Maybe P.PackageName) + :: PackageNameId + -> ReaderT SqlBackend (RIO env) (Maybe P.PackageName) getPackageNameById = fmap (unPackageNameP . packageNameName <$>) . get getPackageNameId - :: MonadIO m - => P.PackageName - -> ReaderT SqlBackend m PackageNameId + :: P.PackageName + -> ReaderT SqlBackend (RIO env) PackageNameId getPackageNameId = fmap (either entityKey id) . insertBy . PackageName . PackageNameP getVersionId - :: MonadIO m - => P.Version - -> ReaderT SqlBackend m VersionId + :: P.Version + -> ReaderT SqlBackend (RIO env) VersionId getVersionId = fmap (either entityKey id) . insertBy . Version . VersionP storeBlob - :: MonadIO m - => ByteString - -> ReaderT SqlBackend m (BlobId, BlobKey) + :: ByteString + -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey) storeBlob bs = do let sha = SHA256.hashBytes bs size = FileSize $ fromIntegral $ B.length bs @@ -349,17 +344,17 @@ loadBlob (P.BlobKey sha size) = do ". Expected size: " <> display size <> ". Actual size: " <> display (blobSize bt)) -loadBlobBySHA :: MonadIO m => SHA256 -> ReaderT SqlBackend m (Maybe BlobId) +loadBlobBySHA :: SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId) loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobSha ==. sha] [] -loadBlobById :: MonadIO m => BlobId -> ReaderT SqlBackend m ByteString +loadBlobById :: BlobId -> ReaderT SqlBackend (RIO env) ByteString loadBlobById bid = do mbt <- get bid case mbt of Nothing -> error "loadBlobById: ID doesn't exist in database" Just bt -> pure $ blobContents bt -getBlobKey :: MonadIO m => BlobId -> ReaderT SqlBackend m BlobKey +getBlobKey :: BlobId -> ReaderT SqlBackend (RIO env) BlobKey getBlobKey bid = do res <- rawSql "SELECT sha, size FROM blob WHERE id=?" [toPersistValue bid] case res of @@ -367,13 +362,13 @@ getBlobKey bid = do [(Single sha, Single size)] -> pure $ P.BlobKey sha size _ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res) -getBlobId :: MonadIO m => BlobKey -> ReaderT SqlBackend m (Maybe BlobId) +getBlobId :: BlobKey -> ReaderT SqlBackend (RIO env) (Maybe BlobId) getBlobId (P.BlobKey sha size) = do res <- rawSql "SELECT id FROM blob WHERE sha=? AND size=?" [toPersistValue sha, toPersistValue size] pure $ listToMaybe $ map unSingle res -loadURLBlob :: MonadIO m => Text -> ReaderT SqlBackend m (Maybe ByteString) +loadURLBlob :: Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString) loadURLBlob url = do ment <- rawSql "SELECT blob.contents\n\ @@ -386,7 +381,7 @@ loadURLBlob url = do [] -> pure Nothing (Single bs) : _ -> pure $ Just bs -storeURLBlob :: MonadIO m => Text -> ByteString -> ReaderT SqlBackend m () +storeURLBlob :: Text -> ByteString -> ReaderT SqlBackend (RIO env) () storeURLBlob url blob = do (blobId, _) <- storeBlob blob now <- getCurrentTime @@ -396,15 +391,11 @@ storeURLBlob url blob = do , urlBlobTime = now } -clearHackageRevisions :: MonadIO m => ReaderT SqlBackend m () +clearHackageRevisions :: ReaderT SqlBackend (RIO env) () clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal]) -storeHackageRevision - :: MonadIO m - => P.PackageName - -> P.Version - -> BlobId - -> ReaderT SqlBackend m () +storeHackageRevision :: + P.PackageName -> P.Version -> BlobId -> ReaderT SqlBackend (RIO env) () storeHackageRevision name version key = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -421,9 +412,8 @@ storeHackageRevision name version key = do } loadHackagePackageVersions - :: MonadIO m - => P.PackageName - -> ReaderT SqlBackend m (Map P.Version (Map Revision BlobKey)) + :: P.PackageName + -> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey)) loadHackagePackageVersions name = do nameid <- getPackageNameId name -- would be better with esequeleto @@ -439,10 +429,9 @@ loadHackagePackageVersions name = do (version, Map.singleton revision (P.BlobKey key size)) loadHackagePackageVersion - :: MonadIO m - => P.PackageName + :: P.PackageName -> P.Version - -> ReaderT SqlBackend m (Map Revision (BlobId, P.BlobKey)) + -> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey)) loadHackagePackageVersion name version = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -459,18 +448,13 @@ loadHackagePackageVersion name version = do (revision, (bid, P.BlobKey sha size)) loadLatestCacheUpdate - :: MonadIO m - => ReaderT SqlBackend m (Maybe (FileSize, SHA256)) + :: ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256)) loadLatestCacheUpdate = fmap go <$> selectFirst [] [Desc CacheUpdateTime] where go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu) -storeCacheUpdate - :: MonadIO m - => FileSize - -> SHA256 - -> ReaderT SqlBackend m () +storeCacheUpdate :: FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) () storeCacheUpdate size sha = do now <- getCurrentTime insert_ CacheUpdate @@ -480,12 +464,11 @@ storeCacheUpdate size sha = do } storeHackageTarballInfo - :: MonadIO m - => P.PackageName + :: P.PackageName -> P.Version -> SHA256 -> FileSize - -> ReaderT SqlBackend m () + -> ReaderT SqlBackend (RIO env) () storeHackageTarballInfo name version sha size = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -497,10 +480,9 @@ storeHackageTarballInfo name version sha size = do } loadHackageTarballInfo - :: MonadIO m - => P.PackageName + :: P.PackageName -> P.Version - -> ReaderT SqlBackend m (Maybe (SHA256, FileSize)) + -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize)) loadHackageTarballInfo name version = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -593,10 +575,8 @@ hpackVersionId = do insertBy $ Version {versionVersion = P.VersionP hpackSoftwareVersion} -getFilePathId - :: MonadIO m - => SafeFilePath - -> ReaderT SqlBackend m FilePathId + +getFilePathId :: SafeFilePath -> ReaderT SqlBackend (RIO env) FilePathId getFilePathId sfp = selectKeysList [FilePathPath ==. sfp] [] >>= \case [fpId] -> pure fpId @@ -685,7 +665,7 @@ getTree tid = do Just ts -> pure ts loadTreeByEnt $ Entity tid ts -loadTree :: MonadIO m => P.TreeKey -> ReaderT SqlBackend m (Maybe P.Tree) +loadTree :: P.TreeKey -> ReaderT SqlBackend (RIO env) (Maybe P.Tree) loadTree key = do ment <- getTreeForKey key case ment of @@ -693,9 +673,8 @@ loadTree key = do Just ent -> Just <$> loadTreeByEnt ent getTreeForKey - :: MonadIO m - => TreeKey - -> ReaderT SqlBackend m (Maybe (Entity Tree)) + :: TreeKey + -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)) getTreeForKey (P.TreeKey key) = do mbid <- getBlobId key case mbid of @@ -790,7 +769,7 @@ getHPackCabalFile hpackRecord ts tmap cabalFile = do cbTreeEntry = P.TreeEntry cabalKey fileType hpackTreeEntry = P.TreeEntry hpackKey fileType tree = P.TreeMap $ Map.insert cabalFile cbTreeEntry tmap - return $ + return ( P.PCHpack $ P.PHpack { P.phOriginal = hpackTreeEntry @@ -799,10 +778,7 @@ getHPackCabalFile hpackRecord ts tmap cabalFile = do } , tree) -loadTreeByEnt - :: MonadIO m - => Entity Tree - -> ReaderT SqlBackend m P.Tree +loadTreeByEnt :: Entity Tree -> ReaderT SqlBackend (RIO env) P.Tree loadTreeByEnt (Entity tid _t) = do entries <- rawSql "SELECT file_path.path, blob.sha, blob.size, tree_entry.type\n\ @@ -817,12 +793,11 @@ loadTreeByEnt (Entity tid _t) = do entries storeHackageTree - :: MonadIO m - => P.PackageName + :: P.PackageName -> P.Version -> BlobId -> P.TreeKey - -> ReaderT SqlBackend m () + -> ReaderT SqlBackend (RIO env) () storeHackageTree name version cabal treeKey' = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -835,11 +810,10 @@ storeHackageTree name version cabal treeKey' = do [HackageCabalTree =. Just (entityKey ent)] loadHackageTreeKey - :: MonadIO m - => P.PackageName + :: P.PackageName -> P.Version -> SHA256 - -> ReaderT SqlBackend m (Maybe TreeKey) + -> ReaderT SqlBackend (RIO env) (Maybe TreeKey) loadHackageTreeKey name ver sha = do res <- rawSql "SELECT treeblob.sha, treeblob.size\n\ @@ -886,13 +860,12 @@ loadHackageTree rpli name ver bid = do Just tid -> Just <$> loadPackageById rpli tid storeArchiveCache - :: MonadIO m - => Text -- ^ URL + :: Text -- ^ URL -> Text -- ^ subdir -> SHA256 -> FileSize -> P.TreeKey - -> ReaderT SqlBackend m () + -> ReaderT SqlBackend (RIO env) () storeArchiveCache url subdir sha size treeKey' = do now <- getCurrentTime ment <- getTreeForKey treeKey' @@ -906,10 +879,9 @@ storeArchiveCache url subdir sha size treeKey' = do } loadArchiveCache - :: MonadIO m - => Text -- ^ URL + :: Text -- ^ URL -> Text -- ^ subdir - -> ReaderT SqlBackend m [(SHA256, FileSize, TreeId)] + -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)] loadArchiveCache url subdir = map go <$> selectList [ ArchiveCacheUrl ==. url , ArchiveCacheSubdir ==. subdir @@ -919,11 +891,10 @@ loadArchiveCache url subdir = map go <$> selectList go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) storeRepoCache - :: MonadIO m - => Repo + :: Repo -> Text -- ^ subdir -> TreeId - -> ReaderT SqlBackend m () + -> ReaderT SqlBackend (RIO env) () storeRepoCache repo subdir tid = do now <- getCurrentTime insert_ RepoCache @@ -936,10 +907,9 @@ storeRepoCache repo subdir tid = do } loadRepoCache - :: MonadIO m - => Repo + :: Repo -> Text -- ^ subdir - -> ReaderT SqlBackend m (Maybe TreeId) + -> ReaderT SqlBackend (RIO env) (Maybe TreeId) loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst [ RepoCacheUrl ==. repoUrl repo , RepoCacheType ==. repoType repo @@ -948,11 +918,8 @@ loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst ] [Desc RepoCacheTime] -storePreferredVersion - :: MonadIO m - => P.PackageName - -> Text - -> ReaderT SqlBackend m () +storePreferredVersion :: + P.PackageName -> Text -> ReaderT SqlBackend (RIO env) () storePreferredVersion name p = do nameid <- getPackageNameId name ment <- getBy $ UniquePreferred nameid @@ -963,10 +930,8 @@ storePreferredVersion name p = do } Just (Entity pid _) -> update pid [PreferredVersionsPreferred =. p] -loadPreferredVersion - :: MonadIO m - => P.PackageName - -> ReaderT SqlBackend m (Maybe Text) +loadPreferredVersion :: + P.PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text) loadPreferredVersion name = do nameid <- getPackageNameId name fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) @@ -1077,9 +1042,7 @@ unpackTreeToDir rpli (toFilePath -> dir) (P.TreeMap m) = do perms <- getPermissions dest setPermissions dest $ setOwnerExecutable True perms -countHackageCabals - :: MonadIO m - => ReaderT SqlBackend m Int +countHackageCabals :: ReaderT SqlBackend (RIO env) Int countHackageCabals = do res <- rawSql "SELECT COUNT(*)\n\ From aafe48bb89a322b78d9b9417e9d2f4bddbdb3836 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Apr 2019 15:42:41 +0300 Subject: [PATCH 41/65] Removed redundant constraints --- subs/pantry/src/Pantry/Storage.hs | 59 +++++++++++++------------------ 1 file changed, 25 insertions(+), 34 deletions(-) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 025d05a5e9..a6a9e99aca 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -266,6 +266,7 @@ data RdbmsActions env a = RdbmsActions { raSqlite :: !(ReaderT SqlBackend (RIO env) a) -- ^ A query that is specific to SQLite , raPostgres :: !(ReaderT SqlBackend (RIO env) a) + -- ^ A query that is specific to PostgreSQL } -- | This function provides a way to create queries supported by multiple sql backends. @@ -328,8 +329,8 @@ storeBlob bs = do key:rest -> assert (null rest) (pure key) pure (key, P.BlobKey sha size) -loadBlob - :: (HasPantryConfig env, HasLogFunc env) +loadBlob :: + HasLogFunc env => BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString) loadBlob (P.BlobKey sha size) = do @@ -491,8 +492,7 @@ loadHackageTarballInfo name version = do go (Entity _ ht) = (hackageTarballSha ht, hackageTarballSize ht) storeCabalFile :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => ByteString + ByteString -> P.PackageName -> ReaderT SqlBackend (RIO env) BlobId storeCabalFile cabalBS pkgName = do @@ -502,8 +502,7 @@ storeCabalFile cabalBS pkgName = do return bid loadFilePath :: - (HasPantryConfig env, HasLogFunc env) - => SafeFilePath + SafeFilePath -> ReaderT SqlBackend (RIO env) (Entity FilePath) loadFilePath path = do fp <- getBy $ UniqueSfp path @@ -514,18 +513,18 @@ loadFilePath path = do (T.unpack $ P.unSafeFilePath path) Just record -> return record -loadHPackTreeEntity :: (HasPantryConfig env, HasLogFunc env) => TreeId -> ReaderT SqlBackend (RIO env) (Entity TreeEntry) +loadHPackTreeEntity :: TreeId -> ReaderT SqlBackend (RIO env) (Entity TreeEntry) loadHPackTreeEntity tid = do filepath <- loadFilePath P.hpackSafeFilePath let filePathId :: FilePathId = entityKey filepath hpackTreeEntry <- - selectFirst [TreeEntryTree ==. tid, TreeEntryPath ==. filePathId] [] - hpackEntity <- - case hpackTreeEntry of - Nothing -> - error $ "loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId: " ++ (show tid) - Just record -> return record - return hpackEntity + selectFirst [TreeEntryTree ==. tid, TreeEntryPath ==. filePathId] [] + case hpackTreeEntry of + Nothing -> + error $ + "loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId: " ++ + show tid + Just record -> return record storeHPack :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) @@ -539,7 +538,7 @@ storeHPack rpli tid = do Nothing -> generateHPack rpli tid vid Just record -> return $ entityKey record -loadCabalBlobKey :: (HasPantryConfig env, HasLogFunc env) => HPackId -> ReaderT SqlBackend (RIO env) BlobKey +loadCabalBlobKey :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey loadCabalBlobKey hpackId = do hpackRecord <- getJust hpackId getBlobKey $ hPackCabalBlob hpackRecord @@ -653,9 +652,7 @@ storeTree rpli (P.PackageIdentifier name version) tree@(P.TreeMap m) buildFile = P.BFCabal _ _ -> return () return (tid, pTreeKey) -getTree :: (HasPantryConfig env, HasLogFunc env) - => TreeId - -> ReaderT SqlBackend (RIO env) P.Tree +getTree :: TreeId -> ReaderT SqlBackend (RIO env) P.Tree getTree tid = do (mts :: Maybe Tree) <- get tid ts <- @@ -742,13 +739,13 @@ loadPackageById rpli tid = do , packageIdent = ident } -getHPackBlobKey :: (HasPantryConfig env, HasLogFunc env) => HPack -> ReaderT SqlBackend (RIO env) BlobKey +getHPackBlobKey :: HPack -> ReaderT SqlBackend (RIO env) BlobKey getHPackBlobKey hpackRecord = do let treeId = hPackTree hpackRecord hpackEntity <- loadHPackTreeEntity treeId getBlobKey (treeEntryBlob $ entityVal hpackEntity) -getHPackBlobKeyById :: (HasPantryConfig env, HasLogFunc env) => HPackId -> ReaderT SqlBackend (RIO env) BlobKey +getHPackBlobKeyById :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey getHPackBlobKeyById hpackId = do hpackRecord <- getJust hpackId getHPackBlobKey hpackRecord @@ -937,10 +934,9 @@ loadPreferredVersion name = do fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) sinkHackagePackageNames - :: MonadUnliftIO m - => (P.PackageName -> Bool) - -> ConduitT P.PackageName Void (ReaderT SqlBackend m) a - -> ReaderT SqlBackend m a + :: (P.PackageName -> Bool) + -> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a + -> ReaderT SqlBackend (RIO env) a sinkHackagePackageNames predicate sink = do acqSrc <- selectSourceRes [] [] with acqSrc $ \src -> runConduit @@ -1054,29 +1050,25 @@ countHackageCabals = do pure n getSnapshotCacheByHash - :: (HasPantryConfig env, HasLogFunc env) - => SnapshotCacheHash + :: SnapshotCacheHash -> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId) getSnapshotCacheByHash = fmap (fmap entityKey) . getBy . UniqueSnapshotCache . unSnapshotCacheHash getSnapshotCacheId - :: (HasPantryConfig env, HasLogFunc env) - => SnapshotCacheHash + :: SnapshotCacheHash -> ReaderT SqlBackend (RIO env) SnapshotCacheId getSnapshotCacheId = fmap (either entityKey id) . insertBy . SnapshotCache . unSnapshotCacheHash getModuleNameId - :: (HasPantryConfig env, HasLogFunc env) - => P.ModuleName + :: P.ModuleName -> ReaderT SqlBackend (RIO env) ModuleNameId getModuleNameId = fmap (either entityKey id) . insertBy . ModuleName . P.ModuleNameP storeSnapshotModuleCache - :: (HasPantryConfig env, HasLogFunc env) - => SnapshotCacheId + :: SnapshotCacheId -> Map P.PackageName (Set P.ModuleName) -> ReaderT SqlBackend (RIO env) () storeSnapshotModuleCache cache packageModules = @@ -1091,8 +1083,7 @@ storeSnapshotModuleCache cache packageModules = } loadExposedModulePackages - :: (HasPantryConfig env, HasLogFunc env) - => SnapshotCacheId + :: SnapshotCacheId -> P.ModuleName -> ReaderT SqlBackend (RIO env) [P.PackageName] loadExposedModulePackages cacheId mName = From 3aeaceccde99c1981ca3c2dc28a5bebfb9ebe5a0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 23 Apr 2019 17:24:27 +0300 Subject: [PATCH 42/65] Switch from missiles to dont to avoid stm test failure --- test/integration/tests/1438-configure-options/Main.hs | 8 ++++---- .../1438-configure-options/files/stack-everything.yaml | 2 +- .../tests/1438-configure-options/files/stack-locals.yaml | 2 +- .../tests/1438-configure-options/files/stack-name.yaml | 4 ++-- .../tests/1438-configure-options/files/stack-targets.yaml | 2 +- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/test/integration/tests/1438-configure-options/Main.hs b/test/integration/tests/1438-configure-options/Main.hs index 77c05c8ede..6d4762fec0 100644 --- a/test/integration/tests/1438-configure-options/Main.hs +++ b/test/integration/tests/1438-configure-options/Main.hs @@ -12,7 +12,7 @@ main = do unless ("this is an invalid option" `isInfixOf` str) $ error "Configure option is not present" - stack ["build", "--stack-yaml", "stack-locals.yaml", "acme-missiles"] - stack ["build", "--stack-yaml", "stack-targets.yaml", "acme-missiles"] - stackErr ["build", "--stack-yaml", "stack-name.yaml", "acme-missiles"] - stackErr ["build", "--stack-yaml", "stack-everything.yaml", "acme-missiles"] + stack ["build", "--stack-yaml", "stack-locals.yaml", "acme-dont"] + stack ["build", "--stack-yaml", "stack-targets.yaml", "acme-dont"] + stackErr ["build", "--stack-yaml", "stack-name.yaml", "acme-dont"] + stackErr ["build", "--stack-yaml", "stack-everything.yaml", "acme-dont"] diff --git a/test/integration/tests/1438-configure-options/files/stack-everything.yaml b/test/integration/tests/1438-configure-options/files/stack-everything.yaml index 97466037f3..1e9cba4d18 100644 --- a/test/integration/tests/1438-configure-options/files/stack-everything.yaml +++ b/test/integration/tests/1438-configure-options/files/stack-everything.yaml @@ -1,7 +1,7 @@ resolver: ghc-8.2.2 extra-deps: -- acme-missiles-0.3@rev:0 +- acme-dont-1.1@rev:0 configure-options: $everything: diff --git a/test/integration/tests/1438-configure-options/files/stack-locals.yaml b/test/integration/tests/1438-configure-options/files/stack-locals.yaml index b51962c094..9e7c4215bc 100644 --- a/test/integration/tests/1438-configure-options/files/stack-locals.yaml +++ b/test/integration/tests/1438-configure-options/files/stack-locals.yaml @@ -1,7 +1,7 @@ resolver: ghc-8.2.2 extra-deps: -- acme-missiles-0.3@rev:0 +- acme-dont-1.1@rev:0 configure-options: $locals: diff --git a/test/integration/tests/1438-configure-options/files/stack-name.yaml b/test/integration/tests/1438-configure-options/files/stack-name.yaml index 3f2ec3e77c..98f92afe69 100644 --- a/test/integration/tests/1438-configure-options/files/stack-name.yaml +++ b/test/integration/tests/1438-configure-options/files/stack-name.yaml @@ -1,10 +1,10 @@ resolver: ghc-8.2.2 extra-deps: -- acme-missiles-0.3@rev:0 +- acme-dont-1.1@rev:0 configure-options: name: - this is an invalid option - acme-missiles: + acme-dont: - this is an invalid option diff --git a/test/integration/tests/1438-configure-options/files/stack-targets.yaml b/test/integration/tests/1438-configure-options/files/stack-targets.yaml index 5a3b3490bf..7705a92050 100644 --- a/test/integration/tests/1438-configure-options/files/stack-targets.yaml +++ b/test/integration/tests/1438-configure-options/files/stack-targets.yaml @@ -1,7 +1,7 @@ resolver: ghc-8.2.2 extra-deps: -- acme-missiles-0.3@rev:0 +- acme-dont-1.1@rev:0 configure-options: $targets: From 40e905d0f55f18d6bfefdccc4e61712d64bf0561 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 24 Apr 2019 06:35:44 +0300 Subject: [PATCH 43/65] Nicer DB locked messages * Include indication of whether it's Pantry or Stack * Don't mention anything for the first 5 seconds to avoid spamming the user Since there are now two different delays involved, I've extracted the "talkUntil" logic to its own function. In theory, this could be added as a library function with some more cleanup. --- subs/pantry/src/Pantry/SQLite.hs | 101 +++++++++++++++++++++++-------- 1 file changed, 77 insertions(+), 24 deletions(-) diff --git a/subs/pantry/src/Pantry/SQLite.hs b/subs/pantry/src/Pantry/SQLite.hs index 47d26a5652..be48ecda53 100644 --- a/subs/pantry/src/Pantry/SQLite.hs +++ b/subs/pantry/src/Pantry/SQLite.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} module Pantry.SQLite ( Storage (..) , initStorage @@ -23,7 +25,7 @@ initStorage initStorage description migration fp inner = do ensureDir $ parent fp - migrates <- withWriteLock fp $ wrapMigrationFailure $ + migrates <- withWriteLock (display description) fp $ wrapMigrationFailure $ withSqliteConnInfo (sqinfo True) $ runReaderT $ runMigrationSilent migration forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig @@ -46,7 +48,7 @@ initStorage description migration fp inner = do -- completely. We can investigate more elegant solutions in the -- future, such as separate read and write actions or introducing -- smarter retry logic. - { withStorage_ = withMVar baton . const . withWriteLock fp . flip runSqlPool pool + { withStorage_ = withMVar baton . const . withWriteLock (display description) fp . flip runSqlPool pool , withWriteLock_ = id } where @@ -69,33 +71,84 @@ initStorage description migration fp inner = do -- above. withWriteLock :: HasLogFunc env - => Path Abs File -- ^ SQLite database file + => Utf8Builder -- ^ database description, for lock messages + -> Path Abs File -- ^ SQLite database file -> RIO env a -> RIO env a -withWriteLock dbFile inner = do +withWriteLock desc dbFile inner = do let lockFile = toFilePath dbFile ++ ".pantry-write-lock" withRunInIO $ \run -> do mres <- withTryFileLock lockFile Exclusive $ const $ run inner case mres of Just res -> pure res Nothing -> do - run $ logInfo "Unable to get a write lock on the Pantry database, waiting..." - shouldStopComplainingVar <- newTVarIO False - let complainer = fix $ \loop -> do - delay <- registerDelay $ 60 * 1000 * 1000 -- 1 minute - shouldComplain <- - atomically $ - -- Delay has triggered, time to complain again - (readTVar delay >>= checkSTM >> pure True) <|> - -- Time to stop complaining, ignore that delay immediately - (readTVar shouldStopComplainingVar >>= checkSTM >> pure False) - when shouldComplain $ do - run $ logWarn "Still waiting on the Pantry database write lock..." - loop - stopComplaining = atomically $ writeTVar shouldStopComplainingVar True - worker = withFileLock lockFile Exclusive $ const $ do - run $ logInfo "Acquired the Pantry database write lock" - stopComplaining - run inner - runConcurrently $ Concurrently complainer - *> Concurrently (worker `finally` stopComplaining) + let complainer :: Talker IO + complainer delay = run $ do + -- Wait five seconds before giving the first message to + -- avoid spamming the user for uninteresting file locks + delay $ 5 * 1000 * 1000 -- 5 seconds + logInfo $ "Unable to get a write lock on the " <> desc <> " database, waiting..." + + -- Now loop printing a message every 1 minute + forever $ do + delay (60 * 1000 * 1000) -- 1 minute + `onException` logInfo ("Acquired the " <> desc <> " database write lock") + logWarn ("Still waiting on the " <> desc <> " database write lock...") + talkUntil complainer $ \stopComplaining -> + withFileLock lockFile Exclusive $ const $ do + stopComplaining + run inner + +-- | A thread which can send some information to the user and delay. +type Talker m = Delay -> m () + +-- | Delay the given number of microseconds. If 'StopTalking' is +-- triggered before the timer completes, a 'DoneTalking' exception +-- will be thrown (which is caught internally by 'talkUntil'). +type Delay = forall mio. MonadIO mio => Int -> mio () + +-- | Tell the 'Talker' to stop talking. The next time 'Delay' is +-- called, or if a 'Delay' is currently blocking, the 'Talker' thread +-- will exit with an exception. +type StopTalking m = m () + +-- | Internal exception used by 'talkUntil' to allow short-circuiting +-- of the 'Talker'. Should not be used outside of the 'talkUntil' +-- function. +data DoneTalking = DoneTalking + deriving (Show, Typeable) +instance Exception DoneTalking + +-- | Keep running the 'Talker' action until either the inner action +-- completes or calls the 'StopTalking' action. This can be used to +-- give the user status information while running a long running +-- operations. +talkUntil + :: forall m a. MonadUnliftIO m + => Talker m + -> (StopTalking m -> m a) + -> m a +talkUntil talker inner = do + -- Variable to indicate 'Delay'ing should result in a 'DoneTalking' + -- exception. + shouldStopVar <- newTVarIO False + let -- Relatively simple: set shouldStopVar to True + stopTalking = atomically $ writeTVar shouldStopVar True + + delay :: Delay + delay usec = do + -- Register a delay with the runtime system + delayDoneVar <- registerDelay usec + join $ atomically $ + -- Delay has triggered, keep going + (pure () <$ (readTVar delayDoneVar >>= checkSTM)) <|> + -- Time to stop talking, throw a 'DoneTalking' exception immediately + (throwIO DoneTalking <$ (readTVar shouldStopVar >>= checkSTM)) + + -- Run the 'Talker' and inner action together + runConcurrently $ + -- Ignore a 'DoneTalking' exception from the talker, that's expected behavior + Concurrently (talker delay `catch` \DoneTalking -> pure ()) *> + -- Run the inner action, giving it the 'StopTalking' action, and + -- ensuring it is called regardless of exceptions. + Concurrently (inner stopTalking `finally` stopTalking) From 1e86f2a92d2dd056cabb8f54239df2ede02df276 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Wed, 24 Apr 2019 12:01:38 +0300 Subject: [PATCH 44/65] Extract github repos into explicit constants --- subs/curator/app/Main.hs | 4 ++-- subs/curator/src/Curator/Constants.hs | 8 ++++++++ subs/curator/src/Curator/Repo.hs | 4 ++-- 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/subs/curator/app/Main.hs b/subs/curator/app/Main.hs index b59d1fa2d1..d44e809f59 100644 --- a/subs/curator/app/Main.hs +++ b/subs/curator/app/Main.hs @@ -109,9 +109,9 @@ constraints target = withFixedColorTerm $ case target of TargetLts x y | y > 0 -> do let prev = y - 1 - url = concat [ "https://raw.githubusercontent.com/commercialhaskell/stackage-constraints/master/lts-" + url = concat [ "https://raw.githubusercontent.com/" ++ constraintsRepo ++ "/master/lts/" , show x - , "." + , "/" , show prev , ".yaml" ] diff --git a/subs/curator/src/Curator/Constants.hs b/subs/curator/src/Curator/Constants.hs index ee42a911b1..f14ee0ebb6 100644 --- a/subs/curator/src/Curator/Constants.hs +++ b/subs/curator/src/Curator/Constants.hs @@ -1,6 +1,8 @@ module Curator.Constants ( snapshotFilename , constraintsFilename + , snapshotsRepo + , constraintsRepo ) where snapshotFilename :: FilePath @@ -8,3 +10,9 @@ snapshotFilename = "snapshot.yaml" constraintsFilename :: FilePath constraintsFilename = "constraints.yaml" + +snapshotsRepo :: String +snapshotsRepo = "commercialhaskell/stackage-next" + +constraintsRepo :: String +constraintsRepo = "commercialhaskell/stackage-constraints-next" diff --git a/subs/curator/src/Curator/Repo.hs b/subs/curator/src/Curator/Repo.hs index 373c17e840..33f0a7ecf5 100644 --- a/subs/curator/src/Curator/Repo.hs +++ b/subs/curator/src/Curator/Repo.hs @@ -58,7 +58,7 @@ checkoutSnapshotsRepo :: -> m ([String] -> m (), Path Abs File, String) checkoutSnapshotsRepo t = checkoutRepo t dir url where - url = "git@github.com:commercialhaskell/stackage-next" + url = "git@github.com:" ++ snapshotsRepo dir = $(mkRelDir "stackage-snapshots") checkoutConstraintsRepo :: @@ -72,7 +72,7 @@ checkoutConstraintsRepo :: -> m ([String] -> m (), Path Abs File, String) checkoutConstraintsRepo t = checkoutRepo t dir url where - url = "git@github.com:commercialhaskell/stackage-constraints-next" + url = "git@github.com:" ++ constraintsRepo dir = $(mkRelDir "stackage-constraints") checkoutRepo :: From 0683dc3149cfc9088bd110401a1f5924a35f018f Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Wed, 24 Apr 2019 12:59:27 +0300 Subject: [PATCH 45/65] Delete old constraints file befor downloading from Github --- subs/curator/app/Main.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/subs/curator/app/Main.hs b/subs/curator/app/Main.hs index e1c0c0d875..d5d9357139 100644 --- a/subs/curator/app/Main.hs +++ b/subs/curator/app/Main.hs @@ -11,7 +11,7 @@ import Network.HTTP.Download (download) import Options.Applicative.Simple hiding (action) import qualified Pantry import Path (toFilePath) -import Path.IO (doesFileExist, resolveFile', resolveDir') +import Path.IO (doesFileExist, removeFile, resolveFile', resolveDir') import Paths_curator (version) import qualified RIO.ByteString.Lazy as BL import RIO.List (stripPrefix) @@ -113,9 +113,13 @@ constraints target = , show prev , ".yaml" ] - logInfo $ "Reusing constraints.yaml from lts-" <> display x <> "." <> display prev + logInfo $ "Will reuse constraints.yaml from lts-" <> display x <> "." <> display prev req <- parseUrlThrow url constraintsPath <- resolveFile' constraintsFilename + exists <- doesFileExist constraintsPath + when exists $ do + logWarn "Local constraints file will be deleted before downloading reused constraints" + removeFile constraintsPath downloaded <- download req constraintsPath unless downloaded $ error $ "Could not download constraints.yaml from " <> url From 76139e4ca0f98d94f93f52bc52fbb360b1be4a2a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 24 Apr 2019 14:05:33 +0300 Subject: [PATCH 46/65] onDoneTalking (thanks to @lehins) --- subs/pantry/src/Pantry/SQLite.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/SQLite.hs b/subs/pantry/src/Pantry/SQLite.hs index be48ecda53..fc3a9701f0 100644 --- a/subs/pantry/src/Pantry/SQLite.hs +++ b/subs/pantry/src/Pantry/SQLite.hs @@ -92,7 +92,7 @@ withWriteLock desc dbFile inner = do -- Now loop printing a message every 1 minute forever $ do delay (60 * 1000 * 1000) -- 1 minute - `onException` logInfo ("Acquired the " <> desc <> " database write lock") + `onDoneTalking` logInfo ("Acquired the " <> desc <> " database write lock") logWarn ("Still waiting on the " <> desc <> " database write lock...") talkUntil complainer $ \stopComplaining -> withFileLock lockFile Exclusive $ const $ do @@ -112,6 +112,16 @@ type Delay = forall mio. MonadIO mio => Int -> mio () -- will exit with an exception. type StopTalking m = m () +-- | When a delay was interrupted because we're done talking, perform +-- this action. +onDoneTalking + :: MonadUnliftIO m + => m () -- ^ the delay + -> m () -- ^ action to perform + -> m () +onDoneTalking theDelay theAction = + theDelay `withException` \DoneTalking -> theAction + -- | Internal exception used by 'talkUntil' to allow short-circuiting -- of the 'Talker'. Should not be used outside of the 'talkUntil' -- function. From 8a57805bd414dce27578fd10d5b76d20ff3667df Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 24 Apr 2019 15:03:55 +0300 Subject: [PATCH 47/65] Work around for ghc bug: https://gitlab.haskell.org/ghc/ghc/issues/16077 --- subs/pantry/src/Pantry/Internal/Stackage.hs | 2 +- subs/pantry/src/Pantry/Storage.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry/Internal/Stackage.hs b/subs/pantry/src/Pantry/Internal/Stackage.hs index 4c315cd42e..1a76a2c5d9 100644 --- a/subs/pantry/src/Pantry/Internal/Stackage.hs +++ b/subs/pantry/src/Pantry/Internal/Stackage.hs @@ -31,7 +31,7 @@ import Pantry.Storage as X , loadBlobById , migrateAll , treeCabal - , unBlobKey + , Key(unBlobKey) ) import Pantry.Types as X ( ModuleNameP(..) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index a6a9e99aca..eeecb8d75f 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -66,7 +66,7 @@ module Pantry.Storage , EntityField(..) -- avoid warnings , BlobId - , unBlobKey + , Key(unBlobKey) , HackageCabalId , HackageCabal(..) , HackageTarballId From d5a78e55583914737ea115f7fb9484d5b178300d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 28 Apr 2019 11:32:57 +0300 Subject: [PATCH 48/65] Switch to interruptible branch of filelock --- snapshot-lts-12.yaml | 2 ++ snapshot-nightly.yaml | 2 ++ snapshot.yaml | 2 ++ 3 files changed, 6 insertions(+) diff --git a/snapshot-lts-12.yaml b/snapshot-lts-12.yaml index f667e35dd4..c148cc3a9e 100644 --- a/snapshot-lts-12.yaml +++ b/snapshot-lts-12.yaml @@ -10,6 +10,8 @@ packages: - yaml-0.10.4.0@rev:0 #for hpack-0.31 - persistent-2.9.2@rev:0 - persistent-sqlite-2.9.3@rev:0 +- github: nh2/filelock + commit: 7008cde39887131c7ca91ad1bad19e2c528c5ced drop-packages: # See https://github.com/commercialhaskell/stack/pull/4712 diff --git a/snapshot-nightly.yaml b/snapshot-nightly.yaml index 511f4d6d7b..9c72aebb09 100644 --- a/snapshot-nightly.yaml +++ b/snapshot-nightly.yaml @@ -4,6 +4,8 @@ name: snapshot-for-building-stack-with-ghc-8.6.2 packages: - persistent-2.9.2@rev:0 - persistent-sqlite-2.9.3@rev:0 +- github: nh2/filelock + commit: 7008cde39887131c7ca91ad1bad19e2c528c5ced drop-packages: # See https://github.com/commercialhaskell/stack/pull/4712 diff --git a/snapshot.yaml b/snapshot.yaml index 2ad267e02e..3d595ea9e8 100644 --- a/snapshot.yaml +++ b/snapshot.yaml @@ -19,6 +19,8 @@ packages: - process-1.6.3.0@sha256:fc77cfe75a9653b8c54ae455ead8c06cb8adc4d7a340984d84d8ca880b579919,2370 #because of https://github.com/haskell/process/pull/101 - persistent-2.9.2@rev:0 - persistent-sqlite-2.9.3@rev:0 +- github: nh2/filelock + commit: 7008cde39887131c7ca91ad1bad19e2c528c5ced drop-packages: # See https://github.com/commercialhaskell/stack/pull/4712 From 90dc3c55431c2c609d369a238749102c307abe0b Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Mon, 29 Apr 2019 11:36:47 +0300 Subject: [PATCH 49/65] Fix freeze test (publish-date field was added to snapshots) --- test/integration/tests/4220-freeze-command/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/integration/tests/4220-freeze-command/Main.hs b/test/integration/tests/4220-freeze-command/Main.hs index 15c79d0ab6..cac220e80a 100644 --- a/test/integration/tests/4220-freeze-command/Main.hs +++ b/test/integration/tests/4220-freeze-command/Main.hs @@ -9,9 +9,9 @@ main = do stackCheckStdout ["freeze"] $ \stdOut -> do let contents = fromList [ "resolver:", - "size: 527165", + "size: 527200", "url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/19.yaml", - "sha256: 0116ad1779b20ad2c9d6620f172531f13b12bb69867e78f4277157e28865dfd4", + "sha256: 16758b43c10c731bc142fdc5c005795db8338d7b4a28cd0af6730d739af2b306", "extra-deps:", "pantry-tree:", "hackage: a50-0.5@sha256:b8dfcc13dcbb12e444128bb0e17527a2a7a9bd74ca9450d6f6862c4b394ac054,1491", From c7d384f8b2be82f6acf59bd49b34c129273e7f08 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Mon, 29 Apr 2019 11:36:47 +0300 Subject: [PATCH 50/65] Fix freeze test (publish-date field was added to snapshots) --- test/integration/tests/4220-freeze-command/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/integration/tests/4220-freeze-command/Main.hs b/test/integration/tests/4220-freeze-command/Main.hs index 15c79d0ab6..cac220e80a 100644 --- a/test/integration/tests/4220-freeze-command/Main.hs +++ b/test/integration/tests/4220-freeze-command/Main.hs @@ -9,9 +9,9 @@ main = do stackCheckStdout ["freeze"] $ \stdOut -> do let contents = fromList [ "resolver:", - "size: 527165", + "size: 527200", "url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/19.yaml", - "sha256: 0116ad1779b20ad2c9d6620f172531f13b12bb69867e78f4277157e28865dfd4", + "sha256: 16758b43c10c731bc142fdc5c005795db8338d7b4a28cd0af6730d739af2b306", "extra-deps:", "pantry-tree:", "hackage: a50-0.5@sha256:b8dfcc13dcbb12e444128bb0e17527a2a7a9bd74ca9450d6f6862c4b394ac054,1491", From 4f28d663d4f81098f4d41082e015fc3d7d746812 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Mon, 29 Apr 2019 13:03:18 +0300 Subject: [PATCH 51/65] Don't symlink stack.yaml so lock files won't pollute src dir --- test/integration/IntegrationSpec.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/test/integration/IntegrationSpec.hs b/test/integration/IntegrationSpec.hs index 786a3af8bf..c1ac7ed934 100644 --- a/test/integration/IntegrationSpec.hs +++ b/test/integration/IntegrationSpec.hs @@ -238,8 +238,15 @@ copyTree src dst = Just suffix <- return $ stripPrefix src srcfp let dstfp = dst stripHeadSeparator suffix createDirectoryIfMissing True $ takeDirectory dstfp - createSymbolicLink srcfp dstfp `catch` \(_ :: IOException) -> - copyFile srcfp dstfp -- for Windows + -- copying yaml files so lock files won't get created in + -- the source directory + if takeFileName srcfp /= "package.yaml" && + (takeExtensions srcfp == ".yaml" || takeExtensions srcfp == ".yml") + then + copyFile srcfp dstfp + else + createSymbolicLink srcfp dstfp `catch` \(_ :: IOException) -> + copyFile srcfp dstfp -- for Windows stripHeadSeparator :: FilePath -> FilePath stripHeadSeparator [] = [] From 9b5a2d3e5237552049ee1517945b7b423259d05a Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Mon, 29 Apr 2019 15:22:37 +0300 Subject: [PATCH 52/65] Add not only package but also snapshot location cache in lock files --- src/Stack/Freeze.hs | 2 +- src/Stack/Lock.hs | 87 +++++++++++++++++++----------- src/Stack/SourceMap.hs | 2 +- src/test/Stack/LockSpec.hs | 96 +++++++++++++++------------------ subs/curator/app/Main.hs | 5 +- subs/pantry/src/Pantry.hs | 63 ++++++++++++---------- subs/pantry/src/Pantry/Types.hs | 21 ++++++++ 7 files changed, 159 insertions(+), 117 deletions(-) diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index c751b3145d..77fa033a0c 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -69,7 +69,7 @@ doFreeze p FreezeSnapshot = do case result of Left _wc -> logInfo "No freezing is required for compiler resolver" - Right (snap, _) -> do + Right snap -> do snap' <- completeSnapshotLayer snap let rawCompleted = toRawSnapshotLayer snap' if rawCompleted == snap diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 91cc5bc319..bb9709a82d 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Stack.Lock ( lockCachedWanted @@ -23,21 +24,24 @@ import Stack.SourceMap import Stack.Types.Config import Stack.Types.SourceMap -data LockedLocation = - LockedLocation RawPackageLocationImmutable - PackageLocationImmutable - deriving (Show, Eq) +data LockedLocation a b = LockedLocation + { llOriginal :: a + , llCompleted :: b + } deriving (Eq, Show) -instance ToJSON LockedLocation where - toJSON (LockedLocation o c) = - object [ "original" .= o, "completed" .= c ] +instance (ToJSON a, ToJSON b) => ToJSON (LockedLocation a b) where + toJSON ll = + object [ "original" .= llOriginal ll, "completed" .= llCompleted ll ] -instance FromJSON (WithJSONWarnings (Unresolved LockedLocation)) where +instance ( FromJSON (WithJSONWarnings (Unresolved a)) + , FromJSON (WithJSONWarnings (Unresolved b)) + ) => + FromJSON (WithJSONWarnings (Unresolved (LockedLocation a b))) where parseJSON = withObjectWarnings "LockedLocation" $ \o -> do original <- jsonSubWarnings $ o ..: "original" completed <- jsonSubWarnings $ o ..: "completed" - pure $ (\single c -> LockedLocation (unSingleRPLI single) c) <$> original <*> completed + pure $ LockedLocation <$> original <*> completed -- Special wrapper extracting only 1 RawPackageLocationImmutable -- serialization should not produce locations with multiple subdirs @@ -51,21 +55,35 @@ instance FromJSON (WithJSONWarnings (Unresolved SingleRPLI)) where let withWarnings x = WithJSONWarnings x ws pure $ withWarnings $ SingleRPLI . NE.head <$> unresolvedRPLIs -newtype Locked = Locked [LockedLocation] +data Locked = Locked + { lckSnapshotLocaitons :: [LockedLocation RawSnapshotLocation SnapshotLocation] + , lckPkgImmutableLocations :: [LockedLocation RawPackageLocationImmutable PackageLocationImmutable] + } deriving (Eq, Show) -instance FromJSON (Unresolved Locked) where - parseJSON v = do - locs <- unWarningParser $ jsonSubWarningsT (lift $ parseJSON v) - pure $ Locked <$> sequenceA locs +instance ToJSON Locked where + toJSON Locked {..} = + object + [ "snapshots" .= lckSnapshotLocaitons + , "packages" .= lckPkgImmutableLocations + ] + +instance FromJSON (WithJSONWarnings (Unresolved Locked)) where + parseJSON = withObjectWarnings "Locked" $ \o -> do + snapshots <- jsonSubWarningsT $ o ..: "snapshots" + packages <- jsonSubWarningsT $ o ..: "packages" + let unwrap ll = ll { llOriginal = unSingleRPLI (llOriginal ll) } + pure $ Locked <$> sequenceA snapshots <*> (map unwrap <$> sequenceA packages) loadYamlThrow :: HasLogFunc env - => (Value -> Yaml.Parser a) -> Path Abs File -> RIO env a + => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a loadYamlThrow parser path = do val <- liftIO $ Yaml.decodeFileThrow (toFilePath path) case Yaml.parseEither parser val of Left err -> throwIO $ Yaml.AesonException err - Right res -> return res + Right (WithJSONWarnings res warnings) -> do + logJSONWarnings (toFilePath path) warnings + return res lockCachedWanted :: (HasPantryConfig env, HasProcessContext env, HasLogFunc env) @@ -79,22 +97,29 @@ lockCachedWanted :: lockCachedWanted stackFile resolver fillWanted = do lockFile <- liftIO $ addFileExtension "lock" stackFile lockExists <- doesFileExist lockFile - pkgLocCache <- if not lockExists - then do - logDebug "Lock file doesn't exist" - pure Map.empty - else do - logDebug "Using package location completions from a lock file" - unresolvedLocked <- loadYamlThrow parseJSON lockFile - Locked locked0 <- resolvePaths (Just $ parent stackFile) unresolvedLocked - pure $ Map.fromList [(orig, compl) | LockedLocation orig compl <- locked0] - - (snap, completed) <- - loadAndCompleteSnapshotRaw resolver pkgLocCache + locked <- + if not lockExists + then do + logDebug "Lock file doesn't exist" + pure $ Locked [] [] + else do + logDebug "Using package location completions from a lock file" + unresolvedLocked <- loadYamlThrow parseJSON lockFile + resolvePaths (Just $ parent stackFile) unresolvedLocked + let toMap :: Ord a => [LockedLocation a b] -> Map a b + toMap = Map.fromList . map (\ll -> (llOriginal ll, llCompleted ll)) + slocCache = toMap $ lckSnapshotLocaitons locked + pkgLocCache = toMap $ lckPkgImmutableLocations locked + (snap, slocCompleted, pliCompleted) <- + loadAndCompleteSnapshotRaw resolver slocCache pkgLocCache let compiler = snapshotCompiler snap snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap) (wanted, prjCompleted) <- fillWanted Map.empty compiler snPkgs - liftIO $ Yaml.encodeFile (toFilePath lockFile) $ - map (uncurry LockedLocation) $ - prjCompleted <> completed + let lockLocations = map (uncurry LockedLocation) + newLocked = Locked { lckSnapshotLocaitons = lockLocations slocCompleted + , lckPkgImmutableLocations = + lockLocations $ pliCompleted <> prjCompleted + } + when (newLocked /= locked) $ + liftIO $ Yaml.encodeFile (toFilePath lockFile) newLocked pure wanted diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs index 54f1107b71..6e8070e219 100644 --- a/src/Stack/SourceMap.hs +++ b/src/Stack/SourceMap.hs @@ -262,7 +262,7 @@ loadProjectSnapshotCandidate :: -> Bool -> RIO env (SnapshotCandidate env) loadProjectSnapshotCandidate loc printWarnings buildHaddocks = do - (snapshot, _) <- loadAndCompleteSnapshotRaw loc Map.empty + (snapshot, _, _) <- loadAndCompleteSnapshotRaw loc Map.empty Map.empty deps <- Map.traverseWithKey (snapToDepPackage False) (snapshotPackages snapshot) let wc = snapshotCompiler snapshot globals <- Map.map GlobalPackageVersion <$> globalsFromHints wc diff --git a/src/test/Stack/LockSpec.hs b/src/test/Stack/LockSpec.hs index aa67d58dcf..3d15829987 100644 --- a/src/test/Stack/LockSpec.hs +++ b/src/test/Stack/LockSpec.hs @@ -4,6 +4,7 @@ module Stack.LockSpec where +import Data.Aeson.Extended (WithJSONWarnings(..)) import Data.ByteString (ByteString) import qualified Data.Yaml as Yaml import Distribution.Types.PackageName (mkPackageName) @@ -29,24 +30,60 @@ decodeLocked bs = do val <- Yaml.decodeThrow bs case Yaml.parseEither Yaml.parseJSON val of Left err -> throwIO $ Yaml.AesonException err - Right res -> do + Right (WithJSONWarnings res warnings) -> do + unless (null warnings) $ + throwIO $ Yaml.AesonException $ "Unexpected warnings: " ++ show warnings -- we just assume no file references resolvePaths Nothing res spec :: Spec spec = do - it "parses lock file (empty)" $ do + it "parses lock file (empty with GHC resolver)" $ do let lockFile :: ByteString lockFile = [r|#some -[] +snapshots: +- completed: + compiler: ghc-8.2.2 + original: + compiler: ghc-8.2.2 +packages: [] |] - Locked pkgImm <- decodeLocked lockFile + pkgImm <- lckPkgImmutableLocations <$> decodeLocked lockFile pkgImm `shouldBe` [] - it "parses lock file (wai + warp)" $ do + it "parses lock file (empty with LTS resolver)" $ do let lockFile :: ByteString lockFile = [r|#some +snapshots: +- completed: + size: 527801 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml + sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a + original: lts-11.22 +- completed: + compiler: ghc-8.2.2 + original: + compiler: ghc-8.2.2 +packages: [] +|] + pkgImm <- lckPkgImmutableLocations <$> decodeLocked lockFile + pkgImm `shouldBe` [] + it "parses lock file (LTS, wai + warp)" $ do + let lockFile :: ByteString + lockFile = + [r|#some +snapshots: +- completed: + size: 527801 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml + sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a + original: lts-11.22 +- completed: + compiler: ghc-8.2.2 + original: + compiler: ghc-8.2.2 +packages: - original: subdir: wai git: https://github.com/yesodweb/wai.git @@ -80,7 +117,7 @@ spec = do sha256: f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 |] - Locked pkgImm <- decodeLocked lockFile + pkgImm <- lckPkgImmutableLocations <$> decodeLocked lockFile let waiSubdirRepo subdir = Repo { repoType = RepoGit , repoUrl = "https://github.com/yesodweb/wai.git" @@ -133,50 +170,3 @@ spec = do 10725 })) ] - it "parses snapshot lock file (non empty)" $ do - let lockFile :: ByteString - lockFile = - [r|#some -- original: - hackage: string-quote-0.0.1 - completed: - hackage: string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3,758 - pantry-tree: - size: 273 - sha256: d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f -|] - Locked pkgImm <- decodeLocked lockFile - pkgImm `shouldBe` - [ LockedLocation - (RPLIHackage - (PackageIdentifierRevision - (mkPackageName "string-quote") - (mkVersion [0, 0, 1]) - CFILatest) - Nothing) - (PLIHackage - (PackageIdentifier - { pkgName = mkPackageName "string-quote" - , pkgVersion = mkVersion [0, 0, 1] - }) - (toBlobKey - "7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3" - 758) - (TreeKey - (BlobKey - (decodeSHA - "d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f") - (FileSize 273))) - ) - ] - --- ---lockedPackageWithLocations :: RawPackageLocationImmutable -> PackageLocationImmutable -> LockedPackage ---lockedPackageWithLocations rpli pli = --- LockedPackage{ lpLocation = LockedLocation rpli pli --- , lpFlags = mempty --- , lpGhcOptions = mempty --- , lpFromSnapshot = FromSnapshot --- , lpHidden = False --- } --- diff --git a/subs/curator/app/Main.hs b/subs/curator/app/Main.hs index ebf473fb28..9db9561e1f 100644 --- a/subs/curator/app/Main.hs +++ b/subs/curator/app/Main.hs @@ -158,7 +158,8 @@ loadSnapshotYaml = do abs' <- resolveFile' snapshotFilename let sloc = SLFilePath $ ResolvedPath (RelFilePath (fromString snapshotFilename)) abs' - fmap fst $ loadAndCompleteSnapshot sloc Map.empty + (snap, _, _) <- loadAndCompleteSnapshot sloc Map.empty Map.empty + pure snap checkSnapshot :: RIO PantryApp () checkSnapshot = do @@ -220,4 +221,4 @@ loadPantrySnapshotLayerFile fp = do eres <- loadSnapshotLayer $ SLFilePath (ResolvedPath (RelFilePath (fromString fp)) abs') case eres of Left x -> error $ "should not happen: " ++ show (fp, x) - Right (x, _) -> pure x + Right x -> pure x diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 116f22a2ec..94087594c5 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -171,6 +171,7 @@ module Pantry import RIO import Conduit +import Control.Arrow (right) import Control.Monad.State.Strict (State, execState, get, modify') import qualified RIO.Map as Map import qualified RIO.Set as Set @@ -908,7 +909,7 @@ loadSnapshotRaw loc = do , rsPackages = mempty , rsDrop = mempty } - Right rsl -> do + Right (rsl, _) -> do snap0 <- loadSnapshotRaw $ rslParent rsl (packages, unused) <- addPackagesToSnapshot @@ -944,7 +945,7 @@ loadSnapshot loc = do , rsPackages = mempty , rsDrop = mempty } - Right (rsl, _sha) -> do + Right rsl -> do snap0 <- loadSnapshotRaw $ rslParent rsl (packages, unused) <- addPackagesToSnapshot @@ -965,6 +966,7 @@ loadSnapshot loc = do } type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) +type CompletedSL = (RawSnapshotLocation, SnapshotLocation) -- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting -- any incomplete package locations @@ -973,10 +975,11 @@ type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) loadAndCompleteSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation - -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file - -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshot loc cachedPL = - loadAndCompleteSnapshotRaw (toRawSL loc) cachedPL + -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file + -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) +loadAndCompleteSnapshot loc cachedSL cachedPL = + loadAndCompleteSnapshotRaw (toRawSL loc) cachedSL cachedPL -- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing -- any incomplete package locations @@ -985,10 +988,13 @@ loadAndCompleteSnapshot loc cachedPL = loadAndCompleteSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation - -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file - -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshotRaw loc cachePL = do - eres <- loadRawSnapshotLayer loc + -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file + -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) +loadAndCompleteSnapshotRaw rawLoc cacheSL cachePL = do + eres <- case Map.lookup rawLoc cacheSL of + Just loc -> right (\rsl -> (rsl, (rawLoc, loc))) <$> loadSnapshotLayer loc + Nothing -> loadRawSnapshotLayer rawLoc case eres of Left wc -> let snapshot = Snapshot @@ -996,12 +1002,12 @@ loadAndCompleteSnapshotRaw loc cachePL = do , snapshotPackages = mempty , snapshotDrop = mempty } - in pure (snapshot, []) - Right rsl -> do - (snap0, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cachePL + in pure (snapshot, [(RSLCompiler wc, SLCompiler wc)], []) + Right (rsl, sloc) -> do + (snap0, slocs, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cacheSL cachePL (packages, completed, unused) <- addAndCompletePackagesToSnapshot - loc + rawLoc cachePL (rslLocations rsl) AddPackagesConfig @@ -1011,13 +1017,13 @@ loadAndCompleteSnapshotRaw loc cachePL = do , apcGhcOptions = rslGhcOptions rsl } (snapshotPackages snap0) - warnUnusedAddPackagesConfig (display loc) unused + warnUnusedAddPackagesConfig (display rawLoc) unused let snapshot = Snapshot { snapshotCompiler = fromMaybe (snapshotCompiler snap0) (rslCompiler rsl) , snapshotPackages = packages , snapshotDrop = apcDrop unused } - return (snapshot, completed0 ++ completed) + return (snapshot, sloc : slocs,completed0 ++ completed) data SingleOrNot a = Single !a @@ -1217,19 +1223,19 @@ addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig dro loadRawSnapshotLayer :: (HasPantryConfig env, HasLogFunc env) => RawSnapshotLocation - -> RIO env (Either WantedCompiler RawSnapshotLayer) + -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)) loadRawSnapshotLayer (RSLCompiler compiler) = pure $ Left compiler -loadRawSnapshotLayer sl@(RSLUrl url blob) = - handleAny (throwIO . InvalidSnapshot sl) $ do +loadRawSnapshotLayer rsl@(RSLUrl url blob) = + handleAny (throwIO . InvalidSnapshot rsl) $ do bs <- loadFromURL url blob value <- Yaml.decodeThrow bs - snapshot <- warningsParserHelperRaw sl value Nothing - pure $ Right snapshot -loadRawSnapshotLayer sl@(RSLFilePath fp) = - handleAny (throwIO . InvalidSnapshot sl) $ do + snapshot <- warningsParserHelperRaw rsl value Nothing + pure $ Right (snapshot, (rsl, SLUrl url (bsToBlobKey bs))) +loadRawSnapshotLayer rsl@(RSLFilePath fp) = + handleAny (throwIO . InvalidSnapshot rsl) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - snapshot <- warningsParserHelperRaw sl value $ Just $ parent $ resolvedAbsolute fp - pure $ Right snapshot + snapshot <- warningsParserHelperRaw rsl value $ Just $ parent $ resolvedAbsolute fp + pure $ Right (snapshot, (rsl, SLFilePath fp)) -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- @@ -1241,20 +1247,19 @@ loadRawSnapshotLayer sl@(RSLFilePath fp) = loadSnapshotLayer :: (HasPantryConfig env, HasLogFunc env) => SnapshotLocation - -> RIO env (Either WantedCompiler (RawSnapshotLayer, SHA256)) -- FIXME remove SHA? Be smart? + -> RIO env (Either WantedCompiler RawSnapshotLayer) loadSnapshotLayer (SLCompiler compiler) = pure $ Left compiler loadSnapshotLayer sl@(SLUrl url blob) = handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do bs <- loadFromURL url (Just blob) value <- Yaml.decodeThrow bs snapshot <- warningsParserHelper sl value Nothing - pure $ Right (snapshot, SHA256.hashBytes bs) + pure $ Right snapshot loadSnapshotLayer sl@(SLFilePath fp) = handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - sha <- SHA256.hashFile $ toFilePath $ resolvedAbsolute fp snapshot <- warningsParserHelper sl value $ Just $ parent $ resolvedAbsolute fp - pure $ Right (snapshot, sha) + pure $ Right snapshot loadFromURL :: (HasPantryConfig env, HasLogFunc env) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index dce0f40c5c..5c7f1b5e5e 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -2004,6 +2004,27 @@ instance NFData SnapshotLocation instance ToJSON SnapshotLocation where toJSON sl = toJSON (toRawSL sl) +instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where + parseJSON v = file v <|> url v <|> compiler v + where + file = withObjectWarnings "SLFilepath" $ \o -> do + ufp <- o ..: "filepath" + pure $ Unresolved $ \mdir -> + case mdir of + Nothing -> throwIO $ InvalidFilePathSnapshot ufp + Just dir -> do + absolute <- resolveFile dir (T.unpack ufp) + let fp = ResolvedPath (RelFilePath ufp) absolute + pure $ SLFilePath fp + url = withObjectWarnings "SLUrl" $ \o -> do + url' <- o ..: "url" + sha <- o ..: "sha256" + size <- o ..: "size" + pure $ Unresolved $ \_ -> pure $ SLUrl url' (BlobKey sha size) + compiler = withObjectWarnings "SLCompiler" $ \o -> do + c <- o ..: "compiler" + pure $ Unresolved $ \_ -> pure $ SLCompiler c + -- | Convert snapshot location to its "raw" equivalent. -- -- @since 0.1.0.0 From f20c46707afead28fcfd0a9dc83e6d23aea0da97 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Mon, 29 Apr 2019 15:23:57 +0300 Subject: [PATCH 53/65] Update docs to new lock files design --- doc/lock_files.md | 99 ++++++++++------------------------------------- 1 file changed, 21 insertions(+), 78 deletions(-) diff --git a/doc/lock_files.md b/doc/lock_files.md index ff559ffc88..173c387aec 100644 --- a/doc/lock_files.md +++ b/doc/lock_files.md @@ -18,11 +18,12 @@ set of input files. There are a few problems with making this work: To address this, we follow the (fairly standard) approach of having a _lock file_. The goal of the lock file is to cache completed -information about all packages and snapshot files so that: +locations of project, snapshot packages and snapshots themselves so that: * These files can be stored in source control * Users on other machines can reuse these lock files and get identical - build plans + build plans given that the used local packages and local snapshots are + the same on those machines * Rerunning `stack build` in the future is deterministic in the build plan, not depending on mutable state in the world like Hackage revisions @@ -31,8 +32,6 @@ information about all packages and snapshot files so that: to perform the build. However, by deterministic, we mean it either performs the same build or fails, never accidentally doing something different. -* Stack can quickly determine the build plan in the common case of no - changes to `stack.yaml` or snapshot files This document explains the contents of a lock file, how they are used, and how they are created and updated. @@ -42,11 +41,7 @@ and how they are created and updated. Relevant to this discussion, the `stack.yaml` file specifies: * Resolver (the parent snapshot) -* Compiler override * `extra-deps` -* Flags -* GHC options -* Hidden packages The resolver can either specify a compiler version or another snapshot file. This snapshot file can contain the same information referenced @@ -55,12 +50,7 @@ above for a `stack.yaml`, with the following differences: * The `extra-deps` are called `packages` * Drop packages can be included -Some of this information is, by its nature, complete. For example, the -"flags" field cannot be influenced by anything outside of the file -itself. - -On the other hand, some information in these files can be -incomplete. Consider: +Some information in these files can be incomplete. Consider: ```yaml resolver: lts-13.9 @@ -128,24 +118,16 @@ parsing of the additional files in the common case of no changes. The lock file contains the following information: -* The full snapshot definition information, including completed - package locations for both `extra-deps` and packages in +* Completed package locations for both `extra-deps` and packages in snapshot files * **NOTE** This only applies to _immutable_ packages. Mutable packages are not included in the lock file. * Completed information for the snapshot locations -* A hash of the `stack.yaml` file -* The snapshot hash, to bypass the need to recalculate this on each - run of Stack It looks like the following: ```yaml # Lock file, some message about the file being auto-generated -stack-yaml: - sha256: XXXX - size: XXXX # in bytes - snapshots: # Starts with the snapshot specified in stack.yaml, # then continues with the snapshot specified in each @@ -163,33 +145,22 @@ snapshots: url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/9.yaml sha256: 83de9017d911cf7795f19353dba4d04bd24cd40622b7567ff61fc3f7223aa3ea -compiler: ghc-X.Y.Z - packages: - acme-missiles: - location: - # QUESTION: any reason we need to specify which snapshot file it came from? I don't think so... - original: https://hackage.haskell.org/package/acme-missiles-0.3.tar.gz - completed: - size: 1442 - url: https://hackage.haskell.org/package/acme-missiles-0.3.tar.gz - cabal-file: - size: 613 - sha256: 2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1 - name: acme-missiles - version: '0.3' - sha256: e563d8b524017a06b32768c4db8eff1f822f3fb22a90320b7e414402647b735b - pantry-tree: - size: 226 - sha256: 614bc0cca76937507ea0a5ccc17a504c997ce458d7f2f9e43b15a10c8eaeb033 - flags: ... - hidden: true/false - ghc-options: [...] +- original: https://hackage.haskell.org/package/acme-missiles-0.3.tar.gz + completed: + size: 1442 + url: https://hackage.haskell.org/package/acme-missiles-0.3.tar.gz + cabal-file: + size: 613 + sha256: 2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1 + name: acme-missiles + version: '0.3' + sha256: e563d8b524017a06b32768c4db8eff1f822f3fb22a90320b7e414402647b735b + pantry-tree: + size: 226 + sha256: 614bc0cca76937507ea0a5ccc17a504c997ce458d7f2f9e43b15a10c8eaeb033 ``` -**NOTE** The `original` fields may seem superfluous at first. See the -update procedure below for an explanation. - ## Creation Whenever a `stack.yaml` file is loaded, Stack checks for a lock file @@ -206,36 +177,8 @@ If the lock file does not exist, it will be created by: * Completing all missing information * Writing out the new `stack.yaml.lock` file -## Dirtiness checking - -If the `stack.yaml.lock` file exists, its last modification time is -compared against the last modification time of the `stack.yaml` file -and any local snapshot files. If any of those files is more recent -than the `stack.yaml.lock` file, and the file hashes in the lock file -do not match the files on the filesystem, then the update procedure is -triggered. Otherwise, the `stack.yaml.lock` file can be used as the -definition of the snapshot. - ## Update procedure -The simplest possible implementation is: ignore the lock file entirely -and create a new one followign the creation steps above. There's a -significant downside to this, however: it may cause a larger delta in -the lock file than intended, by causing more packages to be -updates. For example, many packages from Hackage may have their -Hackage revision information updated unnecessarily. - -The more complicated update procedure is described below. **QUESTION** -Do we want to go the easy way at first and later implement the more -complicated update procedure? - -1. Create a map from original package location to completed package - location in the lock file -2. Load up each snapshot file -3. For each incomplete package location: - * Lookup the value in the map created in (1) - * If present: use that completed information - * Otherwise: complete the information using the same completion - procedure from Pantry as in "creation" - -This should minimize the number of changes to packages incurred. +When loading a Stack project all completed package or snapshot locations +(even when they were completed using information from a lock file) get +collected to form a new lock file. From 47cf7da7a7f6dd89db9acbb07068d98314fbd3b2 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Mon, 29 Apr 2019 15:24:23 +0300 Subject: [PATCH 54/65] Lock files test --- test/integration/tests/lock-files/Main.hs | 17 +++++++++++++++++ test/integration/tests/lock-files/files/Lib.hs | 2 ++ .../tests/lock-files/files/package.yaml | 4 ++++ .../tests/lock-files/files/stack-1-extra | 3 +++ .../tests/lock-files/files/stack-2-extras | 4 ++++ 5 files changed, 30 insertions(+) create mode 100644 test/integration/tests/lock-files/Main.hs create mode 100644 test/integration/tests/lock-files/files/Lib.hs create mode 100644 test/integration/tests/lock-files/files/package.yaml create mode 100644 test/integration/tests/lock-files/files/stack-1-extra create mode 100644 test/integration/tests/lock-files/files/stack-2-extras diff --git a/test/integration/tests/lock-files/Main.hs b/test/integration/tests/lock-files/Main.hs new file mode 100644 index 0000000000..8f7c89700f --- /dev/null +++ b/test/integration/tests/lock-files/Main.hs @@ -0,0 +1,17 @@ +import Control.Monad (unless, when) +import Data.List (isInfixOf) +import StackTest +import System.Directory + +main :: IO () +main = do + copyFile "stack-2-extras" "stack.yaml" + stack ["build"] + lock1 <- readFile "stack.yaml.lock" + unless ("acme-dont" `isInfixOf` lock1) $ + error "Package acme-dont wasn't found in Stack lock file" + copyFile "stack-1-extra" "stack.yaml" + stack ["build"] + lock2 <- readFile "stack.yaml.lock" + when ("acme-dont" `isInfixOf` lock2) $ + error "Package acme-dont shouldn't be in Stack lock file anymore" diff --git a/test/integration/tests/lock-files/files/Lib.hs b/test/integration/tests/lock-files/files/Lib.hs new file mode 100644 index 0000000000..a3b82e6e83 --- /dev/null +++ b/test/integration/tests/lock-files/files/Lib.hs @@ -0,0 +1,2 @@ +foo :: Int +foo = 42 diff --git a/test/integration/tests/lock-files/files/package.yaml b/test/integration/tests/lock-files/files/package.yaml new file mode 100644 index 0000000000..36e02ec5e7 --- /dev/null +++ b/test/integration/tests/lock-files/files/package.yaml @@ -0,0 +1,4 @@ +name: example +library: + dependencies: + - base diff --git a/test/integration/tests/lock-files/files/stack-1-extra b/test/integration/tests/lock-files/files/stack-1-extra new file mode 100644 index 0000000000..94527115ec --- /dev/null +++ b/test/integration/tests/lock-files/files/stack-1-extra @@ -0,0 +1,3 @@ +resolver: lts-11.22 +extra-deps: +- acme-cuteboy-0.1.0.0 diff --git a/test/integration/tests/lock-files/files/stack-2-extras b/test/integration/tests/lock-files/files/stack-2-extras new file mode 100644 index 0000000000..5415f52ee4 --- /dev/null +++ b/test/integration/tests/lock-files/files/stack-2-extras @@ -0,0 +1,4 @@ +resolver: lts-11.22 +extra-deps: +- acme-cuteboy-0.1.0.0 +- acme-dont-1.1 From 92512df2be765476ccac2224508266da4de6f9f4 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Mon, 29 Apr 2019 16:06:21 +0300 Subject: [PATCH 55/65] No null compiler in output --- subs/pantry/src/Pantry/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 15e97f7489..2beb03c2de 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -2118,7 +2118,7 @@ data SnapshotLayer = SnapshotLayer instance ToJSON SnapshotLayer where toJSON snap = object $ concat [ ["resolver" .= slParent snap] - , ["compiler" .= slCompiler snap] + , maybe [] (\compiler -> ["compiler" .= compiler]) (slCompiler snap) , ["packages" .= slLocations snap] , if Set.null (slDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (slDropPackages snap)] , if Map.null (slFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (slFlags snap))] From 26606d07f926ca19535184fcecac7b2ae8f17039 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 29 Apr 2019 19:37:09 +0300 Subject: [PATCH 56/65] Remove excess space to extra-deps recommendations --- src/Stack/Build/ConstructPlan.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index a11efadb57..18de09371b 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -1057,7 +1057,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDe pprintExtra (name, (version, BlobKey cabalHash cabalSize)) = let cfInfo = CFIHash cabalHash (Just cabalSize) packageIdRev = PackageIdentifierRevision name version cfInfo - in "- " <+> fromString (T.unpack (utf8BuilderToText (RIO.display packageIdRev))) + in fromString ("- " ++ T.unpack (utf8BuilderToText (RIO.display packageIdRev))) allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions' toNotInBuildPlan (DependencyPlanFailures _ pDeps) = From 0448f2acc1dc9aaac42f91958a0968e77d7ccc52 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 30 Apr 2019 06:42:28 +0300 Subject: [PATCH 57/65] Share the companion code --- src/Stack/Build/Execute.hs | 34 ++++----- subs/pantry/package.yaml | 3 + subs/pantry/src/Pantry/Internal/Companion.hs | 76 ++++++++++++++++++++ subs/pantry/src/Pantry/SQLite.hs | 72 ++----------------- 4 files changed, 97 insertions(+), 88 deletions(-) create mode 100644 subs/pantry/src/Pantry/Internal/Companion.hs diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 49a812112f..9b38ebf3bf 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -91,6 +91,7 @@ import System.PosixCompat.Files (createLink, modificationTime, getFile import System.PosixCompat.Time (epochTime) import RIO.PrettyPrint import RIO.Process +import Pantry.Internal.Companion -- | Has an executable been built or not? data ExecutableBuildStatus @@ -951,26 +952,19 @@ withLockedDistDir announce root inner = do case mres of Just res -> pure res Nothing -> do - announce $ "blocking for directory lock on " <> fromString (toFilePath lockFP) - stopYellingVar <- newTVarIO False - let yell = do - doneDelayingVar <- registerDelay 30000000 -- 30 seconds - join $ atomically $ - (do stopYelling' <- readTVar stopYellingVar - checkSTM stopYelling' - pure $ pure ()) <|> - (do doneDelaying <- readTVar doneDelayingVar - checkSTM doneDelaying - pure $ do - announce $ "still blocking for directory lock on " <> - fromString (toFilePath lockFP) <> - "; maybe another Stack process is running?" - yell) - stopYelling = atomically $ writeTVar stopYellingVar True - block = withRunInIO $ \run -> - withFileLock (toFilePath lockFP) Exclusive (\_ -> stopYelling *> run inner) - `finally` stopYelling - runConcurrently $ Concurrently yell *> Concurrently block + let complainer delay = do + delay 5000000 -- 5 seconds + announce $ "blocking for directory lock on " <> fromString (toFilePath lockFP) + forever $ do + delay 30000000 -- 30 seconds + announce $ "still blocking for directory lock on " <> + fromString (toFilePath lockFP) <> + "; maybe another Stack process is running?" + withCompanion complainer $ + \stopComplaining -> + withRunInIO $ \run -> + withFileLock (toFilePath lockFP) Exclusive $ \_ -> + run $ stopComplaining *> inner -- | How we deal with output from GHC, either dumping to a log file or the -- console (with some prefix). diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 57ad825507..28732663e1 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -110,6 +110,9 @@ library: # For stackage-server - Pantry.Internal.Stackage + # For stack + - Pantry.Internal.Companion + # FIXME must be removed from pantry! - Data.Aeson.Extended diff --git a/subs/pantry/src/Pantry/Internal/Companion.hs b/subs/pantry/src/Pantry/Internal/Companion.hs new file mode 100644 index 0000000000..53b9ec33ef --- /dev/null +++ b/subs/pantry/src/Pantry/Internal/Companion.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | Companion threads, such as for printing messages saying we're +-- still busy. Ultimately this could be put into its own package. +module Pantry.Internal.Companion + ( withCompanion + , onCompanionDone + , Companion + , Delay + , StopCompanion + ) where + +import RIO + +-- | A companion thread which can perform arbitrary actions as well as delay +type Companion m = Delay -> m () + +-- | Delay the given number of microseconds. If 'StopCompanion' is +-- triggered before the timer completes, a 'CompanionDone' exception +-- will be thrown (which is caught internally by 'withCompanion'). +type Delay = forall mio. MonadIO mio => Int -> mio () + +-- | Tell the 'Companion' to stop. The next time 'Delay' is +-- called, or if a 'Delay' is currently blocking, the 'Companion' thread +-- will exit with a 'CompanionDone' exception. +type StopCompanion m = m () + +-- | When a delay was interrupted because we're told to stop, perform +-- this action. +onCompanionDone + :: MonadUnliftIO m + => m () -- ^ the delay + -> m () -- ^ action to perform + -> m () +onCompanionDone theDelay theAction = + theDelay `withException` \CompanionDone -> theAction + +-- | Internal exception used by 'withCompanion' to allow short-circuiting +-- of the 'Companion'. Should not be used outside of this module. +data CompanionDone = CompanionDone + deriving (Show, Typeable) +instance Exception CompanionDone + +-- | Keep running the 'Companion' action until either the inner action +-- completes or calls the 'StopCompanion' action. This can be used to +-- give the user status information while running a long running +-- operations. +withCompanion + :: forall m a. MonadUnliftIO m + => Companion m + -> (StopCompanion m -> m a) + -> m a +withCompanion companion inner = do + -- Variable to indicate 'Delay'ing should result in a 'CompanionDone' + -- exception. + shouldStopVar <- newTVarIO False + let -- Relatively simple: set shouldStopVar to True + stopCompanion = atomically $ writeTVar shouldStopVar True + + delay :: Delay + delay usec = do + -- Register a delay with the runtime system + delayDoneVar <- registerDelay usec + join $ atomically $ + -- Delay has triggered, keep going + (pure () <$ (readTVar delayDoneVar >>= checkSTM)) <|> + -- Time to stop the companion, throw a 'CompanionDone' exception immediately + (throwIO CompanionDone <$ (readTVar shouldStopVar >>= checkSTM)) + + -- Run the 'Companion' and inner action together + runConcurrently $ + -- Ignore a 'CompanionDone' exception from the companion, that's expected behavior + Concurrently (companion delay `catch` \CompanionDone -> pure ()) *> + -- Run the inner action, giving it the 'StopCompanion' action, and + -- ensuring it is called regardless of exceptions. + Concurrently (inner stopCompanion `finally` stopCompanion) diff --git a/subs/pantry/src/Pantry/SQLite.hs b/subs/pantry/src/Pantry/SQLite.hs index fc3a9701f0..9a37922da9 100644 --- a/subs/pantry/src/Pantry/SQLite.hs +++ b/subs/pantry/src/Pantry/SQLite.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} module Pantry.SQLite ( Storage (..) , initStorage @@ -14,6 +13,7 @@ import Path (Path, Abs, File, toFilePath, parent) import Path.IO (ensureDir) import Pantry.Types (PantryException (MigrationFailure), Storage (..)) import System.FileLock (withFileLock, withTryFileLock, SharedExclusive (..)) +import Pantry.Internal.Companion initStorage :: HasLogFunc env @@ -82,7 +82,7 @@ withWriteLock desc dbFile inner = do case mres of Just res -> pure res Nothing -> do - let complainer :: Talker IO + let complainer :: Companion IO complainer delay = run $ do -- Wait five seconds before giving the first message to -- avoid spamming the user for uninteresting file locks @@ -92,73 +92,9 @@ withWriteLock desc dbFile inner = do -- Now loop printing a message every 1 minute forever $ do delay (60 * 1000 * 1000) -- 1 minute - `onDoneTalking` logInfo ("Acquired the " <> desc <> " database write lock") + `onCompanionDone` logInfo ("Acquired the " <> desc <> " database write lock") logWarn ("Still waiting on the " <> desc <> " database write lock...") - talkUntil complainer $ \stopComplaining -> + withCompanion complainer $ \stopComplaining -> withFileLock lockFile Exclusive $ const $ do stopComplaining run inner - --- | A thread which can send some information to the user and delay. -type Talker m = Delay -> m () - --- | Delay the given number of microseconds. If 'StopTalking' is --- triggered before the timer completes, a 'DoneTalking' exception --- will be thrown (which is caught internally by 'talkUntil'). -type Delay = forall mio. MonadIO mio => Int -> mio () - --- | Tell the 'Talker' to stop talking. The next time 'Delay' is --- called, or if a 'Delay' is currently blocking, the 'Talker' thread --- will exit with an exception. -type StopTalking m = m () - --- | When a delay was interrupted because we're done talking, perform --- this action. -onDoneTalking - :: MonadUnliftIO m - => m () -- ^ the delay - -> m () -- ^ action to perform - -> m () -onDoneTalking theDelay theAction = - theDelay `withException` \DoneTalking -> theAction - --- | Internal exception used by 'talkUntil' to allow short-circuiting --- of the 'Talker'. Should not be used outside of the 'talkUntil' --- function. -data DoneTalking = DoneTalking - deriving (Show, Typeable) -instance Exception DoneTalking - --- | Keep running the 'Talker' action until either the inner action --- completes or calls the 'StopTalking' action. This can be used to --- give the user status information while running a long running --- operations. -talkUntil - :: forall m a. MonadUnliftIO m - => Talker m - -> (StopTalking m -> m a) - -> m a -talkUntil talker inner = do - -- Variable to indicate 'Delay'ing should result in a 'DoneTalking' - -- exception. - shouldStopVar <- newTVarIO False - let -- Relatively simple: set shouldStopVar to True - stopTalking = atomically $ writeTVar shouldStopVar True - - delay :: Delay - delay usec = do - -- Register a delay with the runtime system - delayDoneVar <- registerDelay usec - join $ atomically $ - -- Delay has triggered, keep going - (pure () <$ (readTVar delayDoneVar >>= checkSTM)) <|> - -- Time to stop talking, throw a 'DoneTalking' exception immediately - (throwIO DoneTalking <$ (readTVar shouldStopVar >>= checkSTM)) - - -- Run the 'Talker' and inner action together - runConcurrently $ - -- Ignore a 'DoneTalking' exception from the talker, that's expected behavior - Concurrently (talker delay `catch` \DoneTalking -> pure ()) *> - -- Run the inner action, giving it the 'StopTalking' action, and - -- ensuring it is called regardless of exceptions. - Concurrently (inner stopTalking `finally` stopTalking) From 7dc60018b02314a77d86b59491af4107e048d8b7 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 30 Apr 2019 09:28:43 +0300 Subject: [PATCH 58/65] Remove some unused imports --- subs/pantry/test/Pantry/TypesSpec.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index 010049df5e..2de9e75ee0 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -12,11 +12,6 @@ module Pantry.TypesSpec import Data.Aeson.Extended import qualified Data.ByteString.Char8 as S8 -import qualified Data.List as List -import qualified Data.List.NonEmpty as NonEmpty -import Data.List.NonEmpty hiding (map) -import Data.Semigroup -import qualified Data.Vector as Vector import qualified Data.Yaml as Yaml import Distribution.Types.PackageName (mkPackageName) import Distribution.Types.Version (mkVersion) @@ -32,9 +27,7 @@ import Pantry.Internal , renderTree ) import qualified Pantry.SHA256 as SHA256 -import qualified Path as Path import RIO -import qualified RIO.HashMap as HM import qualified RIO.Text as T import Test.Hspec import Text.RawString.QQ From 43425d89c2a4e9956920ba99691f2596fa36eccc Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 30 Apr 2019 12:35:27 +0300 Subject: [PATCH 59/65] Minor doc fix --- doc/lock_files.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/lock_files.md b/doc/lock_files.md index 173c387aec..fee779ccd5 100644 --- a/doc/lock_files.md +++ b/doc/lock_files.md @@ -181,4 +181,5 @@ If the lock file does not exist, it will be created by: When loading a Stack project all completed package or snapshot locations (even when they were completed using information from a lock file) get -collected to form a new lock file. +collected to form a new lock file in memory and compare against the one +on disk, writing if there are any differences. From 6f853b87eb9aa899df28c6739ed1e2338d2ce5df Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 30 Apr 2019 12:41:45 +0300 Subject: [PATCH 60/65] Use patched filelock with CLOEXEC Specifically, we're adding in this commit: https://github.com/snoyberg/filelock/commit/4f080496d8bf153fbe26e64d1f52cf73c7db25f6 Without this change, very often on large builds we end up in a situation where: * Multiple threads are working in parallel * Thread A needs to work with the database * Thread A takes a file lock on the database * Thread B forks a child process, which inherits the database lock * Thread A releases the file lock * Thread C attempts to take the file lock, but is blocked by B's child As a demonstration, lsof showed me this on my system: COMMAND PID USER FD TYPE DEVICE SIZE/OFF NODE NAME stack 20216 michael 12w REG 1,4 0 8613331527 stack.sqlite3.pantry-write-lock Cabal-sim 22736 michael 12w REG 1,4 0 8613331527 stack.sqlite3.pantry-write-lock ghc 22800 michael 12w REG 1,4 0 8613331527 stack.sqlite3.pantry-write-lock With this change in place, I witnessed 0 cases of the file lock not acquired message from Stack on a large build. --- snapshot-lts-12.yaml | 4 ++-- snapshot-nightly.yaml | 4 ++-- snapshot.yaml | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/snapshot-lts-12.yaml b/snapshot-lts-12.yaml index c148cc3a9e..9e8fa9b40e 100644 --- a/snapshot-lts-12.yaml +++ b/snapshot-lts-12.yaml @@ -10,8 +10,8 @@ packages: - yaml-0.10.4.0@rev:0 #for hpack-0.31 - persistent-2.9.2@rev:0 - persistent-sqlite-2.9.3@rev:0 -- github: nh2/filelock - commit: 7008cde39887131c7ca91ad1bad19e2c528c5ced +- github: snoyberg/filelock + commit: 97e83ecc133cd60a99df8e1fa5a3c2739ad007dc drop-packages: # See https://github.com/commercialhaskell/stack/pull/4712 diff --git a/snapshot-nightly.yaml b/snapshot-nightly.yaml index 9c72aebb09..9935e3db81 100644 --- a/snapshot-nightly.yaml +++ b/snapshot-nightly.yaml @@ -4,8 +4,8 @@ name: snapshot-for-building-stack-with-ghc-8.6.2 packages: - persistent-2.9.2@rev:0 - persistent-sqlite-2.9.3@rev:0 -- github: nh2/filelock - commit: 7008cde39887131c7ca91ad1bad19e2c528c5ced +- github: snoyberg/filelock + commit: 97e83ecc133cd60a99df8e1fa5a3c2739ad007dc drop-packages: # See https://github.com/commercialhaskell/stack/pull/4712 diff --git a/snapshot.yaml b/snapshot.yaml index 3d595ea9e8..9a512aac30 100644 --- a/snapshot.yaml +++ b/snapshot.yaml @@ -19,8 +19,8 @@ packages: - process-1.6.3.0@sha256:fc77cfe75a9653b8c54ae455ead8c06cb8adc4d7a340984d84d8ca880b579919,2370 #because of https://github.com/haskell/process/pull/101 - persistent-2.9.2@rev:0 - persistent-sqlite-2.9.3@rev:0 -- github: nh2/filelock - commit: 7008cde39887131c7ca91ad1bad19e2c528c5ced +- github: snoyberg/filelock + commit: 97e83ecc133cd60a99df8e1fa5a3c2739ad007dc drop-packages: # See https://github.com/commercialhaskell/stack/pull/4712 From 3f0544366f87f18aa5e4a536c0b334d0969bd1a5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 30 Apr 2019 22:46:32 +0300 Subject: [PATCH 61/65] Fix some misplaced parse warnings #4789 Instead of FromJSON instances for Repo and PackageMetadata, use the Data.Aeson.Extended mechanisms to properly track which fields are used. --- subs/pantry/src/Pantry/Types.hs | 63 +++++++++++++--------------- subs/pantry/test/Pantry/TypesSpec.hs | 19 +++------ 2 files changed, 34 insertions(+), 48 deletions(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 3dd8be058a..cdfab7b860 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -506,15 +506,6 @@ instance Display Repo where (if T.null subdir then mempty else " in subdirectory " <> display subdir) -instance FromJSON Repo where - parseJSON = - withObject "Repo" $ \o -> do - repoSubdir <- o .: "subdir" - repoCommit <- o .: "commit" - (repoType, repoUrl) <- - (o .: "git" >>= \url -> pure (RepoGit, url)) <|> - (o .: "hg" >>= \url -> pure (RepoHg, url)) - pure Repo {..} -- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains @@ -1411,16 +1402,15 @@ instance Display PackageMetadata where , "cabal file == " <> display (pmCabal pm) ] -instance FromJSON PackageMetadata where - parseJSON = - withObject "PackageMetadata" $ \o -> do - pmCabal :: BlobKey <- o .: "cabal-file" - pantryTree :: BlobKey <- o .: "pantry-tree" - CabalString pkgName <- o .: "name" - CabalString pkgVersion <- o .: "version" - let pmTreeKey = TreeKey pantryTree - pmIdent = PackageIdentifier {..} - pure PackageMetadata {..} +parsePackageMetadata :: Object -> WarningParser PackageMetadata +parsePackageMetadata o = do + pmCabal :: BlobKey <- o ..: "cabal-file" + pantryTree :: BlobKey <- o ..: "pantry-tree" + CabalString pkgName <- o ..: "name" + CabalString pkgVersion <- o ..: "version" + let pmTreeKey = TreeKey pantryTree + pmIdent = PackageIdentifier {..} + pure PackageMetadata {..} -- | Conver package metadata to its "raw" equivalent. @@ -1540,14 +1530,18 @@ instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) where repoObject :: Value -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable)) - repoObject value = do - pm <- parseJSON value - repo <- parseJSON value - pure $ noJSONWarnings $ pure $ PLIRepo repo pm - - archiveObject value = do - pm <- parseJSON value - withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" (\o -> do + repoObject = withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do + pm <- parsePackageMetadata o + repoSubdir <- o ..: "subdir" + repoCommit <- o ..: "commit" + (repoType, repoUrl) <- + (o ..: "git" >>= \url -> pure (RepoGit, url)) <|> + (o ..: "hg" >>= \url -> pure (RepoHg, url)) + pure $ pure $ PLIRepo Repo {..} pm + + archiveObject = + withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" $ \o -> do + pm <- parsePackageMetadata o Unresolved mkArchiveLocation <- parseArchiveLocationObject o archiveHash <- o ..: "sha256" archiveSize <- o ..: "size" @@ -1555,20 +1549,19 @@ instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where pure $ Unresolved $ \mdir -> do archiveLocation <- mkArchiveLocation mdir pure $ PLIArchive Archive {..} pm - ) value - hackageObject value = - withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" (\o -> do + hackageObject = + withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" $ \o -> do treeKey <- o ..: "pantry-tree" htxt <- o ..: "hackage" case parseHackageText htxt of Left e -> fail $ show e Right (pkgIdentifier, blobKey) -> - pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey)) value + pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey) - github value = do - pm <- parseJSON value + github value = withObjectWarnings "UnresolvedPackagelocationimmutable.PLIArchive:github" (\o -> do + pm <- parsePackageMetadata o GitHubRepo ghRepo <- o ..: "github" commit <- o ..: "commit" let archiveLocation = ALUrl $ T.concat @@ -1594,7 +1587,7 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmu <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v) where http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) - http = withText "UnresolvedPackageLocationImmutable.UPLIArchive (Text)" $ \t -> + http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t -> case parseArchiveLocationText t of Nothing -> fail $ "Invalid archive location: " ++ T.unpack t Just (Unresolved mkArchiveLocation) -> @@ -1640,7 +1633,7 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmu os <- optionalSubdirs o pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os) - archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIArchive" $ \o -> do + archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.RPLIArchive" $ \o -> do Unresolved mkArchiveLocation <- parseArchiveLocationObject o raHash <- o ..:? "sha256" raSize <- o ..:? "size" diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index 2de9e75ee0..7f00e3c085 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -140,11 +140,10 @@ spec = do liftIO $ Yaml.toJSON (nightlySnapshotLocation day) `shouldBe` Yaml.String (T.pack $ "nightly-" ++ show day) - it "FromJSON instance for Repo" $ do - repValue <- - case Yaml.decodeThrow samplePLIRepo of - Just x -> pure x - Nothing -> fail "Can't parse Repo" + it "FromJSON instance for PLIRepo" $ do + WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo + warnings `shouldBe` [] + pli <- resolvePaths Nothing unresolvedPli let repoValue = Repo { repoSubdir = "wai" @@ -153,13 +152,7 @@ spec = do "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" , repoUrl = "https://github.com/yesodweb/wai.git" } - repValue `shouldBe` repoValue - it "FromJSON instance for PackageMetadata" $ do - pkgMeta <- - case Yaml.decodeThrow samplePLIRepo of - Just x -> pure x - Nothing -> fail "Can't parse Repo" - let cabalSha = + cabalSha = SHA256.fromHexBytes "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" pantrySha = @@ -177,7 +170,7 @@ spec = do , pmTreeKey = TreeKey (BlobKey psha (FileSize 714)) , pmCabal = BlobKey csha (FileSize 1765) } - pkgMeta `shouldBe` pkgValue + pli `shouldBe` PLIRepo repoValue pkgValue it "parseHackageText parses" $ do let txt = "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058" From 38826df905752a9c708c085f021c3c3b6d592879 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 1 May 2019 11:17:47 +0300 Subject: [PATCH 62/65] Get package name from completed information #4789 The completed package information already contains the package name, bypassing the need for a package completion call if the cache (lock file) already contains that information. This bypasses a spurious warning about lacking cryptographic hashes, and likely improves performance, for the repo and archive cases. This wasn't discovered initially because the Hackage use case never had an overhead: the specification of a RPLIHackage already contains the package name in all cases. --- subs/pantry/src/Pantry.hs | 4 ++-- subs/pantry/src/Pantry/Types.hs | 9 ++++++++- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 94087594c5..88b48eaaf8 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -1175,9 +1175,9 @@ addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig dro -> RawPackageLocationImmutable -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) addPackage (ps, completed) rawLoc = do - name <- getPackageLocationName rawLoc complLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc - let p = (name, SnapshotPackage + let PackageIdentifier name _ = pliIdent complLoc + p = (name, SnapshotPackage { spLocation = complLoc , spFlags = Map.findWithDefault mempty name flags , spHidden = Map.findWithDefault False name hiddens diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 3dd8be058a..0020243e7c 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -107,6 +107,7 @@ module Pantry.Types , SnapshotCacheHash (..) , getGlobalHintsFile , bsToBlobKey + , pliIdent ) where import RIO @@ -2269,7 +2270,13 @@ getGlobalHintsFile = do -- | Creates BlobKey for an input ByteString -- --- @sinc 0.1.0.0 +-- @since 0.1.0.0 bsToBlobKey :: ByteString -> BlobKey bsToBlobKey bs = BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) + +-- | Identifier from a 'PackageLocationImmutable' +pliIdent :: PackageLocationImmutable -> PackageIdentifier +pliIdent (PLIHackage ident _ _) = ident +pliIdent (PLIArchive _ pm) = pmIdent pm +pliIdent (PLIRepo _ pm) = pmIdent pm From 34ad96f043a78e41a92365f267cabcd3c505b89b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 1 May 2019 11:03:16 +0300 Subject: [PATCH 63/65] Remove CPP and TH in Main module This reduces the amount of recompilation that has to happen when iterating on the code base. --- src/main/BuildInfo.hs | 83 +++++++++++++++++++++++++++++++++++++++++++ src/main/Main.hs | 63 ++------------------------------ 2 files changed, 86 insertions(+), 60 deletions(-) create mode 100644 src/main/BuildInfo.hs diff --git a/src/main/BuildInfo.hs b/src/main/BuildInfo.hs new file mode 100644 index 0000000000..8cb480d469 --- /dev/null +++ b/src/main/BuildInfo.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +#ifdef USE_GIT_INFO +{-# LANGUAGE TemplateHaskell #-} +#endif + +-- Extracted from Main so that the Main module does not use CPP or TH, +-- and therefore doesn't need to be recompiled as often. +module BuildInfo + ( versionString' + , maybeGitHash + , hpackVersion + ) where + +import Stack.Prelude +import qualified Paths_stack as Meta +import qualified Distribution.Text as Cabal (display) +import Distribution.System (buildArch) + +#ifndef HIDE_DEP_VERSIONS +import qualified Build_stack +#endif + +#ifdef USE_GIT_INFO +import GitHash (giCommitCount, giHash, tGitInfoCwdTry) +#endif + +#ifdef USE_GIT_INFO +import Options.Applicative.Simple (simpleVersion) +#endif + +versionString' :: String +#ifdef USE_GIT_INFO +versionString' = concat $ concat + [ [$(simpleVersion Meta.version)] + -- Leave out number of commits for --depth=1 clone + -- See https://github.com/commercialhaskell/stack/issues/792 + , case giCommitCount <$> $$tGitInfoCwdTry of + Left _ -> [] + Right 1 -> [] + Right count -> [" (", show count, " commits)"] + , [" ", Cabal.display buildArch] + , [depsString, warningString] + ] +#else +versionString' = + showVersion Meta.version + ++ ' ' : Cabal.display buildArch + ++ depsString + ++ warningString +#endif + where +#ifdef HIDE_DEP_VERSIONS + depsString = " hpack-" ++ VERSION_hpack +#else + depsString = "\nCompiled with:\n" ++ unlines (map ("- " ++) Build_stack.deps) +#endif +#ifdef SUPPORTED_BUILD + warningString = "" +#else + warningString = unlines + [ "" + , "Warning: this is an unsupported build that may use different versions of" + , "dependencies and GHC than the officially released binaries, and therefore may" + , "not behave identically. If you encounter problems, please try the latest" + , "official build by running 'stack upgrade --force-download'." + ] +#endif + +-- | If USE_GIT_INFO is enabled, the Git hash in the build directory, otherwise Nothing. +maybeGitHash :: Maybe String +maybeGitHash = +#ifdef USE_GIT_INFO + (either (const Nothing) (Just . giHash) $$tGitInfoCwdTry) +#else + Nothing +#endif + +-- | Hpack version we're compiled against +hpackVersion :: String +hpackVersion = VERSION_hpack diff --git a/src/main/Main.hs b/src/main/Main.hs index e45ea7d7bf..c26d881511 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -7,17 +6,11 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} -#ifdef USE_GIT_INFO -{-# LANGUAGE TemplateHaskell #-} -#endif - -- | Main stack tool entry point. module Main (main) where -#ifndef HIDE_DEP_VERSIONS -import qualified Build_stack -#endif +import BuildInfo import Stack.Prelude hiding (Display (..)) import Control.Monad.Reader (local) import Control.Monad.Trans.Except (ExceptT) @@ -31,20 +24,12 @@ import qualified Data.Set as Set import qualified Data.Text as T import Data.Version (showVersion) import RIO.Process -#ifdef USE_GIT_INFO -import GitHash (giCommitCount, giHash, tGitInfoCwdTry) -#endif -import Distribution.System (buildArch) -import qualified Distribution.Text as Cabal (display) import Distribution.Version (mkVersion') import GHC.IO.Encoding (mkTextEncoding, textEncodingName) import Options.Applicative import Options.Applicative.Help (errorHelp, stringChunk, vcatChunks) import Options.Applicative.Builder.Extra import Options.Applicative.Complicated -#ifdef USE_GIT_INFO -import Options.Applicative.Simple (simpleVersion) -#endif import Options.Applicative.Types (ParserHelp(..)) import Pantry (loadSnapshot) import Path @@ -120,44 +105,6 @@ hSetTranslit h = do hSetEncoding h enc' _ -> return () -versionString' :: String -#ifdef USE_GIT_INFO -versionString' = concat $ concat - [ [$(simpleVersion Meta.version)] - -- Leave out number of commits for --depth=1 clone - -- See https://github.com/commercialhaskell/stack/issues/792 - , case giCommitCount <$> $$tGitInfoCwdTry of - Left _ -> [] - Right 1 -> [] - Right count -> [" (", show count, " commits)"] - , [" ", Cabal.display buildArch] - , [depsString, warningString] - ] -#else -versionString' = - showVersion Meta.version - ++ ' ' : Cabal.display buildArch - ++ depsString - ++ warningString -#endif - where -#ifdef HIDE_DEP_VERSIONS - depsString = " hpack-" ++ VERSION_hpack -#else - depsString = "\nCompiled with:\n" ++ unlines (map ("- " ++) Build_stack.deps) -#endif -#ifdef SUPPORTED_BUILD - warningString = "" -#else - warningString = unlines - [ "" - , "Warning: this is an unsupported build that may use different versions of" - , "dependencies and GHC than the officially released binaries, and therefore may" - , "not behave identically. If you encounter problems, please try the latest" - , "official build by running 'stack upgrade --force-download'." - ] -#endif - main :: IO () main = do -- Line buffer the output by default, particularly for non-terminal runs. @@ -218,7 +165,7 @@ commandLineHandler commandLineHandler currentDir progName isInterpreter = complicatedOptions (mkVersion' Meta.version) (Just versionString') - VERSION_hpack + hpackVersion "stack - The Haskell Tool Stack" "" "stack's documentation is available at https://docs.haskellstack.org/" @@ -675,11 +622,7 @@ upgradeCmd upgradeOpts' = do Nothing -> withGlobalProject $ upgrade -#ifdef USE_GIT_INFO - (either (const Nothing) (Just . giHash) $$tGitInfoCwdTry) -#else - Nothing -#endif + maybeGitHash upgradeOpts' -- | Upload to Hackage From a22adeeec295ffb84c94b834a1368d82653e4797 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 1 May 2019 11:57:37 +0300 Subject: [PATCH 64/65] Support symlinks to directories (fixes #4776) --- subs/pantry/attic/symlink-to-dir.tar.gz | Bin 0 -> 260 bytes subs/pantry/src/Pantry/Archive.hs | 34 +++++++++++++++++------- subs/pantry/src/Pantry/Internal.hs | 12 ++++++--- subs/pantry/test/Pantry/ArchiveSpec.hs | 6 +++++ subs/pantry/test/Pantry/InternalSpec.hs | 6 +++-- 5 files changed, 43 insertions(+), 15 deletions(-) create mode 100644 subs/pantry/attic/symlink-to-dir.tar.gz diff --git a/subs/pantry/attic/symlink-to-dir.tar.gz b/subs/pantry/attic/symlink-to-dir.tar.gz new file mode 100644 index 0000000000000000000000000000000000000000..64871ee4c544d0b0660e9db98a0ede3211060711 GIT binary patch literal 260 zcmV+f0sH0i_7Zz!F|rpajpMEHRtd8VLJHmF<&IuBfbwd=0W~OU-CE1bN-|hWkM$C z<;KeM?_KA&q8^6)+lR3k`mIofF3LP_n_Y0>nE!Q$kkWGgWBkS5?cDvZ|0U1Qe`bpF zUnibRi pure (at, Map.fromList $ map (mePath &&& id) $ files []) (at :: ArchiveType, files :: Map FilePath MetaEntry) <- getFiles [minBound..maxBound] - let toSimple :: MetaEntry -> Either String SimpleEntry - toSimple me = + let toSimple :: FilePath -> MetaEntry -> Either String (Map FilePath SimpleEntry) + toSimple key me = case meType me of - METNormal -> Right $ SimpleEntry (mePath me) FTNormal - METExecutable -> Right $ SimpleEntry (mePath me) FTExecutable + METNormal -> Right $ Map.singleton key $ SimpleEntry (mePath me) FTNormal + METExecutable -> Right $ Map.singleton key $ SimpleEntry (mePath me) FTExecutable METLink relDest -> do case relDest of '/':_ -> Left $ concat @@ -393,17 +393,22 @@ parseArchive rpli archive fp = do , e ] Right x -> Right x + -- Check if it's a symlink to a file case Map.lookup dest files of - Nothing -> Left $ "Symbolic link dest not found from " ++ mePath me ++ " to " ++ relDest ++ ", looking for " ++ dest ++ ".\n" - ++ "This may indicate that the source is a git archive which uses git-annex.\n" - ++ "See https://github.com/commercialhaskell/stack/issues/4579 for further information." + Nothing -> + -- Check if it's a symlink to a directory + case findWithPrefix dest files of + [] -> Left $ "Symbolic link dest not found from " ++ mePath me ++ " to " ++ relDest ++ ", looking for " ++ dest ++ ".\n" + ++ "This may indicate that the source is a git archive which uses git-annex.\n" + ++ "See https://github.com/commercialhaskell/stack/issues/4579 for further information." + pairs -> fmap fold $ for pairs $ \(suffix, me') -> toSimple (key ++ '/' : suffix) me' Just me' -> case meType me' of - METNormal -> Right $ SimpleEntry dest FTNormal - METExecutable -> Right $ SimpleEntry dest FTExecutable + METNormal -> Right $ Map.singleton key $ SimpleEntry dest FTNormal + METExecutable -> Right $ Map.singleton key $ SimpleEntry dest FTExecutable METLink _ -> Left $ "Symbolic link dest cannot be a symbolic link, from " ++ mePath me ++ " to " ++ relDest - case traverse toSimple files of + case fold <$> Map.traverseWithKey toSimple files of Left e -> throwIO $ UnsupportedTarball loc $ T.pack e Right files1 -> do let files2 = stripCommonPrefix $ Map.toList files1 @@ -464,6 +469,15 @@ parseArchive rpli archive fp = do , packageIdent = ident } +-- | Find all of the files in the Map with the given directory as a +-- prefix. Directory is given without trailing slash. Returns the +-- suffix after stripping the given prefix. +findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)] +findWithPrefix dir = mapMaybe go . Map.toList + where + prefix = dir ++ "/" + go (x, y) = (, y) <$> List.stripPrefix prefix x + findCabalOrHpackFile :: MonadThrow m => RawPackageLocationImmutable -- ^ for exceptions diff --git a/subs/pantry/src/Pantry/Internal.hs b/subs/pantry/src/Pantry/Internal.hs index d536f5fc75..0ec4f118ad 100644 --- a/subs/pantry/src/Pantry/Internal.hs +++ b/subs/pantry/src/Pantry/Internal.hs @@ -15,27 +15,33 @@ module Pantry.Internal import Control.Exception (assert) import Pantry.Types import qualified Data.Text as T +import Data.Maybe (fromMaybe) -- | Like @System.FilePath.normalise@, however: -- -- * Only works on relative paths, absolute paths fail -- --- * May not point to directories +-- * Strips trailing slashes -- -- * Only works on forward slashes, even on Windows -- -- * Normalizes parent dirs @foo/../@ get stripped -- +-- * Cannot begin with a parent directory (@../@) +-- -- * Spelled like an American, sorry normalizeParents :: FilePath -> Either String FilePath normalizeParents "" = Left "empty file path" normalizeParents ('/':_) = Left "absolute path" +normalizeParents ('.':'.':'/':_) = Left "absolute path" normalizeParents fp = do - let t = T.pack fp + -- Strip a single trailing, but not multiple + let t0 = T.pack fp + t = fromMaybe t0 $ T.stripSuffix "/" t0 case T.unsnoc t of - Just (_, '/') -> Left "trailing slash" + Just (_, '/') -> Left "multiple trailing slashes" _ -> Right () let c1 = T.split (== '/') t diff --git a/subs/pantry/test/Pantry/ArchiveSpec.hs b/subs/pantry/test/Pantry/ArchiveSpec.hs index 2ba99d4479..86fd49e3ef 100644 --- a/subs/pantry/test/Pantry/ArchiveSpec.hs +++ b/subs/pantry/test/Pantry/ArchiveSpec.hs @@ -96,3 +96,9 @@ spec = do , testSubdir = "subs/pant" } `shouldThrow` treeWithoutCabalFile + it "follows symlinks to directories" $ do + ident <- getRawPackageLocationIdent' TestArchive + { testLocation = TLFilePath "attic/symlink-to-dir.tar.gz" + , testSubdir = "symlink" + } + ident `shouldBe` parsePackageIdentifier' "foo-1.2.3" diff --git a/subs/pantry/test/Pantry/InternalSpec.hs b/subs/pantry/test/Pantry/InternalSpec.hs index 9b7dcaee46..689f441567 100644 --- a/subs/pantry/test/Pantry/InternalSpec.hs +++ b/subs/pantry/test/Pantry/InternalSpec.hs @@ -17,15 +17,17 @@ spec = do "file/\\test" ! Just "file/\\test" "/file/////\\test" ! Nothing "file/////\\test" ! Just "file/\\test" + "file/test/" ! Just "file/test" "/file/\\test////" ! Nothing "/file/./test" ! Nothing "file/./test" ! Just "file/test" "/test/file/../bob/fred/" ! Nothing "/test/file/../bob/fred" ! Nothing - "test/file/../bob/fred/" ! Nothing + "test/file/../bob/fred/" ! Just "test/bob/fred" "test/file/../bob/fred" ! Just "test/bob/fred" + "../bob/fred" ! Nothing "../bob/fred/" ! Nothing - "./bob/fred/" ! Nothing + "./bob/fred/" ! Just "bob/fred" "./bob/fred" ! Just "bob/fred" "./" ! Nothing "./." ! Nothing From bd647ff3571534a8e5377c0ef17e58328906a212 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 1 May 2019 12:16:38 +0300 Subject: [PATCH 65/65] Make subdir field optional #4793 --- subs/pantry/src/Pantry/Types.hs | 4 ++-- subs/pantry/test/Pantry/TypesSpec.hs | 28 ++++++++++++++++++++++++++++ 2 files changed, 30 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index cdfab7b860..641bbf5b7e 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1532,7 +1532,7 @@ instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where repoObject :: Value -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable)) repoObject = withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do pm <- parsePackageMetadata o - repoSubdir <- o ..: "subdir" + repoSubdir <- o ..:? "subdir" ..!= "" repoCommit <- o ..: "commit" (repoType, repoUrl) <- (o ..: "git" >>= \url -> pure (RepoGit, url)) <|> @@ -1573,7 +1573,7 @@ instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where ] archiveHash <- o ..: "sha256" archiveSize <- o ..: "size" - archiveSubdir <- o ..: "subdir" + archiveSubdir <- o ..:? "subdir" ..!= "" pure $ pure $ PLIArchive Archive {..} pm) value instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index 7f00e3c085..70fcba5865 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -60,6 +60,21 @@ pantry-tree: commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 |] +samplePLIRepo2 :: ByteString +samplePLIRepo2 = + [r| +cabal-file: + size: 1863 + sha256: 5ebffc39e75ea1016adcc8426dc31d2040d2cc8a5f4bbce228592ef35e233da2 +name: merkle-log +version: 0.1.0.0 +git: https://github.com/kadena-io/merkle-log.git +pantry-tree: + size: 615 + sha256: 5a99e5e41ccd675a7721a733714ba2096f4204d9010f867c5fb7095b78e2959d +commit: a7ae61d7082afe3aa1a0fd0546fc1351a2f7c376 +|] + spec :: Spec spec = do describe "WantedCompiler" $ do @@ -171,6 +186,11 @@ spec = do , pmCabal = BlobKey csha (FileSize 1765) } pli `shouldBe` PLIRepo repoValue pkgValue + + WithJSONWarnings reparsed warnings2 <- Yaml.decodeThrow $ Yaml.encode pli + warnings2 `shouldBe` [] + reparsed' <- resolvePaths Nothing reparsed + reparsed' `shouldBe` pli it "parseHackageText parses" $ do let txt = "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058" @@ -186,3 +206,11 @@ spec = do PackageIdentifier (mkPackageName "persistent") (mkVersion [2, 8, 2]) + it "roundtripping a PLIRepo" $ do + WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo2 + warnings `shouldBe` [] + pli <- resolvePaths Nothing unresolvedPli + WithJSONWarnings unresolvedPli2 warnings2 <- Yaml.decodeThrow $ Yaml.encode pli + warnings2 `shouldBe` [] + pli2 <- resolvePaths Nothing unresolvedPli2 + pli2 `shouldBe` (pli :: PackageLocationImmutable)