Skip to content

Commit fe0ad5b

Browse files
snoybergsnoyberg
committed
Use decodeFileOrFailDeep everywhere (fixes commercialhaskell#554)
1 parent 8462e90 commit fe0ad5b

9 files changed

Lines changed: 83 additions & 47 deletions

File tree

‎src/Data/Binary/VersionTagged.hs‎

Lines changed: 43 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,28 @@
1+
{-# LANGUAGE DeriveDataTypeable #-}
2+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
13
{-# LANGUAGE OverloadedStrings #-}
24
{-# LANGUAGE ScopedTypeVariables #-}
35
-- | Tag a Binary instance with the stack version number to ensure we're
46
-- reading a compatible format.
57
module Data.Binary.VersionTagged
68
( taggedDecodeOrLoad
79
, taggedEncodeFile
10+
, Binary (..)
811
, BinarySchema (..)
12+
, decodeFileOrFailDeep
13+
, encodeFile
14+
, NFData (..)
15+
, genericRnf
916
) where
1017

18+
import Control.DeepSeq.Generics (NFData (..), genericRnf)
19+
import Control.Exception (Exception)
20+
import Control.Monad.Catch (MonadThrow (..))
1121
import Control.Monad.IO.Class (MonadIO, liftIO)
1222
import Data.Binary (Binary (..), encodeFile, decodeFileOrFail, putWord8, getWord8)
13-
import Control.Exception.Enclosed (tryIO)
23+
import Data.Binary.Get (ByteOffset)
24+
import Data.Typeable (Typeable)
25+
import Control.Exception.Enclosed (tryAnyDeep)
1426
import System.FilePath (takeDirectory)
1527
import System.Directory (createDirectoryIfMissing)
1628
import qualified Data.ByteString as S
@@ -22,10 +34,11 @@ magic :: ByteString
2234
magic = "stack"
2335

2436
-- | A @Binary@ instance that also has a schema version
25-
class Binary a => BinarySchema a where
37+
class (Binary a, NFData a) => BinarySchema a where
2638
binarySchema :: Proxy a -> Int
2739

2840
newtype WithTag a = WithTag a
41+
deriving NFData
2942
instance forall a. BinarySchema a => Binary (WithTag a) where
3043
get = do
3144
forM_ (S.unpack magic) $ \w -> do
@@ -58,10 +71,35 @@ taggedDecodeOrLoad :: (BinarySchema a, MonadIO m)
5871
-> m a
5972
-> m a
6073
taggedDecodeOrLoad fp mx = do
61-
eres <- liftIO $ tryIO $ decodeFileOrFail fp
74+
eres <- decodeFileOrFailDeep fp
6275
case eres of
63-
Right (Right (WithTag x)) -> return x
64-
_ -> do
76+
Left _ -> do
6577
x <- mx
6678
taggedEncodeFile fp x
6779
return x
80+
Right (WithTag x) -> return x
81+
82+
-- | Ensure that there are no lurking exceptions deep inside the parsed
83+
-- value... because that happens unfortunately. See
84+
-- https://github.com/commercialhaskell/stack/issues/554
85+
decodeFileOrFailDeep :: (Binary a, NFData a, MonadIO m, MonadThrow n)
86+
=> FilePath
87+
-> m (n a)
88+
decodeFileOrFailDeep fp = liftIO $ fmap (either throwM return) $ tryAnyDeep $ do
89+
eres <- decodeFileOrFail fp
90+
case eres of
91+
Left (offset, str) -> throwM $ DecodeFileFailure fp offset str
92+
Right x -> return x
93+
94+
data DecodeFileFailure = DecodeFileFailure FilePath ByteOffset String
95+
deriving Typeable
96+
instance Show DecodeFileFailure where
97+
show (DecodeFileFailure fp offset str) = concat
98+
[ "Decoding of "
99+
, fp
100+
, " failed at offset "
101+
, show offset
102+
, ": "
103+
, str
104+
]
105+
instance Exception DecodeFileFailure

‎src/Stack/Build/Cache.hs‎

Lines changed: 10 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -33,8 +33,7 @@ import Control.Monad.Catch (MonadThrow, catch, throwM)
3333
import Control.Monad.IO.Class
3434
import Control.Monad.Logger (MonadLogger)
3535
import Control.Monad.Reader
36-
import Data.Binary (Binary)
37-
import qualified Data.Binary as Binary
36+
import Data.Binary.VersionTagged
3837
import qualified Data.ByteString as S
3938
import qualified Data.ByteString.Lazy as L
4039
import Data.Map (Map)
@@ -90,6 +89,8 @@ data BuildCache = BuildCache
9089
}
9190
deriving (Generic)
9291
instance Binary BuildCache
92+
instance NFData BuildCache where
93+
rnf = genericRnf
9394

9495
-- | Try to read the dirtiness cache for the given package directory.
9596
tryGetBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
@@ -107,21 +108,11 @@ tryGetCabalMod :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, Mo
107108
tryGetCabalMod = tryGetCache configCabalMod
108109

109110
-- | Try to load a cache.
110-
tryGetCache :: (MonadIO m, Binary a, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
111+
tryGetCache :: (MonadIO m, Binary a, NFData a)
111112
=> (Path Abs Dir -> m (Path Abs File))
112113
-> Path Abs Dir
113114
-> m (Maybe a)
114-
tryGetCache get' dir = do
115-
fp <- get' dir
116-
liftIO
117-
(catch
118-
(fmap (decodeMaybe . L.fromStrict) (S.readFile (toFilePath fp)))
119-
(\e -> if isDoesNotExistError e
120-
then return Nothing
121-
else throwM e))
122-
where decodeMaybe =
123-
either (const Nothing) (Just . thd) . Binary.decodeOrFail
124-
where thd (_,_,x) = x
115+
tryGetCache get' dir = get' dir >>= decodeFileOrFailDeep . toFilePath
125116

126117
-- | Write the dirtiness cache for this package's files.
127118
writeBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
@@ -160,17 +151,14 @@ deleteCaches dir = do
160151
removeFileIfExists cfp
161152

162153
-- | Write to a cache.
163-
writeCache :: (Binary a, MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
154+
writeCache :: (Binary a, MonadIO m)
164155
=> Path Abs Dir
165156
-> (Path Abs Dir -> m (Path Abs File))
166157
-> a
167158
-> m ()
168159
writeCache dir get' content = do
169160
fp <- get' dir
170-
liftIO
171-
(L.writeFile
172-
(toFilePath fp)
173-
(Binary.encode content))
161+
liftIO $ encodeFile (toFilePath fp) content
174162

175163
flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)
176164
=> Installed
@@ -187,12 +175,8 @@ flagCacheFile installed = do
187175
tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)
188176
=> Installed
189177
-> m (Maybe ConfigCache)
190-
tryGetFlagCache gid = do
191-
file <- flagCacheFile gid
192-
eres <- liftIO $ tryIO $ Binary.decodeFileOrFail $ toFilePath file
193-
case eres of
194-
Right (Right x) -> return $ Just x
195-
_ -> return Nothing
178+
tryGetFlagCache gid =
179+
flagCacheFile gid >>= decodeFileOrFailDeep . toFilePath
196180

197181
writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m)
198182
=> Installed
@@ -202,7 +186,7 @@ writeFlagCache gid cache = do
202186
file <- flagCacheFile gid
203187
liftIO $ do
204188
createTree (parent file)
205-
Binary.encodeFile (toFilePath file) cache
189+
encodeFile (toFilePath file) cache
206190

207191
-- | Mark a test suite as having succeeded
208192
setTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)

‎src/Stack/Build/Types.hs‎

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,7 @@ module Stack.Build.Types
3838
import Control.DeepSeq
3939
import Control.Exception
4040

41-
import Data.Binary (Binary(..))
41+
import Data.Binary.VersionTagged
4242
import qualified Data.ByteString as S
4343
import Data.Char (isSpace)
4444
import Data.Data
@@ -393,6 +393,8 @@ data ConfigCache = ConfigCache
393393
}
394394
deriving (Generic,Eq,Show)
395395
instance Binary ConfigCache
396+
instance NFData ConfigCache where
397+
rnf = genericRnf
396398

397399
-- | A task to perform when building
398400
data Task = Task
@@ -527,8 +529,7 @@ wantedLocalPackages = Set.fromList . map (packageName . lpPackage) . filter lpWa
527529

528530
-- | Used for storage and comparison.
529531
newtype ModTime = ModTime (Integer,Rational)
530-
deriving (Ord,Show,Generic,Eq)
531-
instance Binary ModTime
532+
deriving (Ord,Show,Generic,Eq,NFData,Binary)
532533

533534
-- | One-way conversion to serialized time.
534535
modTime :: UTCTime -> ModTime
@@ -549,3 +550,5 @@ data FileCacheInfo = FileCacheInfo
549550
}
550551
deriving (Generic, Show)
551552
instance Binary FileCacheInfo
553+
instance NFData FileCacheInfo where
554+
rnf = genericRnf

‎src/Stack/PackageDump.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -33,8 +33,7 @@ import Control.Monad.Logger (MonadLogger)
3333
import Control.Monad.Trans.Control
3434
import Data.Attoparsec.Args
3535
import Data.Attoparsec.Text as P
36-
import Data.Binary (Binary)
37-
import Data.Binary.VersionTagged (taggedDecodeOrLoad, taggedEncodeFile, BinarySchema (..))
36+
import Data.Binary.VersionTagged
3837
import Data.ByteString (ByteString)
3938
import qualified Data.ByteString as S
4039
import qualified Data.ByteString.Char8 as S8
@@ -62,7 +61,7 @@ import System.Process.Read
6261
-- | Cached information on whether package have profiling libraries and haddocks.
6362
newtype InstalledCache = InstalledCache (IORef InstalledCacheInner)
6463
newtype InstalledCacheInner = InstalledCacheInner (Map GhcPkgId InstalledCacheEntry)
65-
deriving Binary
64+
deriving (Binary, NFData)
6665
instance BinarySchema InstalledCacheInner where
6766
-- Don't forget to update this if you change the datatype in any way!
6867
binarySchema _ = 1
@@ -73,6 +72,8 @@ data InstalledCacheEntry = InstalledCacheEntry
7372
, installedCacheHaddock :: !Bool }
7473
deriving (Eq, Generic)
7574
instance Binary InstalledCacheEntry
75+
instance NFData InstalledCacheEntry where
76+
rnf = genericRnf
7677

7778
-- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database
7879
ghcPkgDump

‎src/Stack/PackageIndex.hs‎

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -35,7 +35,7 @@ import Control.Monad.Trans.Control
3535

3636
import Data.Aeson.Extended
3737
import qualified Data.Binary as Binary
38-
import Data.Binary.VersionTagged (taggedDecodeOrLoad, BinarySchema (..))
38+
import Data.Binary.VersionTagged
3939
import Data.ByteString (ByteString)
4040
import qualified Data.Word8 as Word8
4141
import qualified Data.ByteString as S
@@ -89,9 +89,11 @@ data PackageCache = PackageCache
8989
}
9090
deriving Generic
9191
instance Binary.Binary PackageCache
92+
instance NFData PackageCache where
93+
rnf = genericRnf
9294

9395
newtype PackageCacheMap = PackageCacheMap (Map PackageIdentifier PackageCache)
94-
deriving Binary.Binary
96+
deriving (Binary.Binary, NFData)
9597
instance BinarySchema PackageCacheMap where
9698
-- Don't forget to update this if you change the datatype in any way!
9799
binarySchema _ = 1
@@ -353,6 +355,8 @@ data PackageDownload = PackageDownload
353355
}
354356
deriving (Show, Generic)
355357
instance Binary.Binary PackageDownload
358+
instance NFData PackageDownload where
359+
rnf = genericRnf
356360
instance FromJSON PackageDownload where
357361
parseJSON = withObject "Package" $ \o -> do
358362
hashes <- o .: "package-hashes"

‎src/Stack/Types/BuildPlan.hs‎

Lines changed: 8 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -32,8 +32,7 @@ import Control.Monad.Catch (MonadThrow, throwM)
3232
import Data.Aeson (FromJSON (..), ToJSON (..),
3333
object, withObject, withText,
3434
(.!=), (.:), (.:?), (.=))
35-
import Data.Binary as Binary (Binary)
36-
import Data.Binary.VersionTagged (BinarySchema (..))
35+
import Data.Binary.VersionTagged
3736
import Data.ByteString (ByteString)
3837
import qualified Data.ByteString.Char8 as S8
3938
import Data.Hashable (Hashable)
@@ -241,7 +240,7 @@ newtype Maintainer = Maintainer { unMaintainer :: Text }
241240

242241
-- | Name of an executable.
243242
newtype ExeName = ExeName { unExeName :: ByteString }
244-
deriving (Show, Eq, Ord, Hashable, IsString, Generic)
243+
deriving (Show, Eq, Ord, Hashable, IsString, Generic, NFData)
245244
instance Binary ExeName
246245
instance ToJSON ExeName where
247246
toJSON = toJSON . S8.unpack . unExeName
@@ -365,7 +364,9 @@ data MiniBuildPlan = MiniBuildPlan
365364
, mbpPackages :: !(Map PackageName MiniPackageInfo)
366365
}
367366
deriving (Generic, Show, Eq)
368-
instance Binary.Binary MiniBuildPlan
367+
instance Binary MiniBuildPlan
368+
instance NFData MiniBuildPlan where
369+
rnf = genericRnf
369370
instance BinarySchema MiniBuildPlan where
370371
-- Don't forget to update this if you change the datatype in any way!
371372
binarySchema _ = 1
@@ -386,7 +387,9 @@ data MiniPackageInfo = MiniPackageInfo
386387
-- ^ Is there a library present?
387388
}
388389
deriving (Generic, Show, Eq)
389-
instance Binary.Binary MiniPackageInfo
390+
instance Binary MiniPackageInfo
391+
instance NFData MiniPackageInfo where
392+
rnf = genericRnf
390393

391394

392395
isWindows :: OS -> Bool

‎src/Stack/Types/FlagName.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,7 @@ import Control.Monad.Catch
2626
import Data.Aeson.Extended
2727
import Data.Attoparsec.ByteString.Char8
2828
import Data.Attoparsec.Combinators
29-
import Data.Binary (Binary)
29+
import Data.Binary.VersionTagged
3030
import qualified Data.ByteString as S
3131
import Data.ByteString.Char8 (ByteString)
3232
import qualified Data.ByteString.Char8 as S8
@@ -54,7 +54,7 @@ instance Show FlagNameParseFail where
5454
-- | A flag name.
5555
newtype FlagName =
5656
FlagName ByteString
57-
deriving (Typeable,Data,Generic,Hashable,Binary)
57+
deriving (Typeable,Data,Generic,Hashable,Binary,NFData)
5858
instance Eq FlagName where
5959
x == y = (compare x y) == EQ
6060
instance Ord FlagName where

‎src/Stack/Types/GhcPkgId.hs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ import Control.Applicative
1616
import Control.Monad.Catch
1717
import Data.Aeson.Extended
1818
import Data.Attoparsec.ByteString.Char8
19-
import Data.Binary (Binary)
19+
import Data.Binary.VersionTagged
2020
import Data.ByteString.Char8 (ByteString)
2121
import qualified Data.ByteString.Char8 as S8
2222
import Data.Char (isLetter)
@@ -43,6 +43,8 @@ data GhcPkgId =
4343

4444
instance Hashable GhcPkgId
4545
instance Binary GhcPkgId
46+
instance NFData GhcPkgId where
47+
rnf = genericRnf
4648

4749
instance Show GhcPkgId where
4850
show = show . ghcPkgIdString

‎stack.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -119,6 +119,7 @@ library
119119
, containers >= 0.5.5.1
120120
, cryptohash >= 0.11.6
121121
, cryptohash-conduit
122+
, deepseq-generics
122123
, directory >= 1.2.1.0
123124
, enclosed-exceptions
124125
, exceptions >= 0.8.0.2

0 commit comments

Comments
 (0)