From a0c30b76d36ddb1735a89ec4a9355b716825f110 Mon Sep 17 00:00:00 2001 From: "Paolo G. Giarrusso" Date: Sun, 14 Aug 2016 17:50:05 +0200 Subject: [PATCH 1/2] Workaround #2491 at all call sites --- src/Data/Yaml/Extra.hs | 23 +++++++++++++++++++++++ src/Stack/BuildPlan.hs | 2 +- src/Stack/Config.hs | 2 +- src/Stack/ConfigCmd.hs | 2 +- src/Stack/Solver.hs | 2 +- stack.cabal | 1 + 6 files changed, 28 insertions(+), 4 deletions(-) create mode 100644 src/Data/Yaml/Extra.hs diff --git a/src/Data/Yaml/Extra.hs b/src/Data/Yaml/Extra.hs new file mode 100644 index 0000000000..d667604dc4 --- /dev/null +++ b/src/Data/Yaml/Extra.hs @@ -0,0 +1,23 @@ +-- | Wrappers for Yaml functions to workaround +-- https://github.com/commercialhaskell/stack/issues/2491. +-- Import Data.Yaml.Extra in place of Data.Yaml to use this workaround. +-- Beware these functions construct/deconstruct the entire file at once! +module Data.Yaml.Extra (decodeFileEither, encodeFile, module Data.Yaml) where + +import Data.Yaml hiding (decodeFileEither, encodeFile) +import qualified Data.ByteString as B +import System.IO + +-- Note: we refrain from using 'B.readFile' and 'B.writeFile', as they open +-- the file in binary mode rather than text mode. +decodeFileEither :: FromJSON a => FilePath -> IO (Either ParseException a) +decodeFileEither path = withFile path ReadMode $ + \hnd -> do + fileContent <- B.hGetContents hnd + return $ decodeEither' fileContent + +encodeFile :: ToJSON a => FilePath -> a -> IO () +encodeFile path v = withFile path WriteMode $ + \hnd -> do + let fileContent = encode v + B.hPut hnd fileContent diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index afa7c50b7b..331b61a8ac 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -66,7 +66,7 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import qualified Data.Traversable as Tr import Data.Typeable (Typeable) -import Data.Yaml (decodeEither', decodeFileEither) +import Data.Yaml.Extra (decodeEither', decodeFileEither) import qualified Distribution.Package as C import Distribution.PackageDescription (GenericPackageDescription, flagDefault, flagManual, diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 0a4af9cd79..7cc1936585 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -63,7 +63,7 @@ import Data.Monoid.Extra import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) -import qualified Data.Yaml as Yaml +import qualified Data.Yaml.Extra as Yaml import Distribution.System (OS (..), Platform (..), buildPlatform) import qualified Distribution.Text import Distribution.Version (simplifyVersionRange) diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index c5e16478f8..37097d3b7b 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -17,7 +17,7 @@ import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.ByteString as S import qualified Data.HashMap.Strict as HMap -import qualified Data.Yaml as Yaml +import qualified Data.Yaml.Extra as Yaml import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Stack.BuildPlan diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 4aba9391a3..2e35796eb9 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -53,7 +53,7 @@ import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Encoding (decodeUtf8With) import Data.Tuple (swap) -import qualified Data.Yaml as Yaml +import qualified Data.Yaml.Extra as Yaml import qualified Distribution.Package as C import qualified Distribution.PackageDescription as C import qualified Distribution.Text as C diff --git a/stack.cabal b/stack.cabal index 222b838592..ede4d7c0e0 100644 --- a/stack.cabal +++ b/stack.cabal @@ -66,6 +66,7 @@ library Data.Maybe.Extra Data.Monoid.Extra Data.Store.VersionTagged + Data.Yaml.Extra Distribution.Version.Extra Network.HTTP.Download Network.HTTP.Download.Verified From e217cfb36db9c187c706d3c574af31264aac2410 Mon Sep 17 00:00:00 2001 From: "Paolo G. Giarrusso" Date: Mon, 15 Aug 2016 01:51:07 +0200 Subject: [PATCH 2/2] decodeFileEither: propagate IOExceptions correctly The interface we wrap expects only Yaml.ParseException to be thrown, and to be wrapped inside Either. Conform to that. --- src/Data/Yaml/Extra.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Data/Yaml/Extra.hs b/src/Data/Yaml/Extra.hs index d667604dc4..af88d4ef8d 100644 --- a/src/Data/Yaml/Extra.hs +++ b/src/Data/Yaml/Extra.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE ScopedTypeVariables #-} -- | Wrappers for Yaml functions to workaround -- https://github.com/commercialhaskell/stack/issues/2491. -- Import Data.Yaml.Extra in place of Data.Yaml to use this workaround. -- Beware these functions construct/deconstruct the entire file at once! module Data.Yaml.Extra (decodeFileEither, encodeFile, module Data.Yaml) where +import Control.Exception import Data.Yaml hiding (decodeFileEither, encodeFile) import qualified Data.ByteString as B import System.IO @@ -11,7 +13,9 @@ import System.IO -- Note: we refrain from using 'B.readFile' and 'B.writeFile', as they open -- the file in binary mode rather than text mode. decodeFileEither :: FromJSON a => FilePath -> IO (Either ParseException a) -decodeFileEither path = withFile path ReadMode $ +decodeFileEither path = + handle (\(e :: IOException) -> return . Left . OtherParseException . SomeException $ e) $ + withFile path ReadMode $ \hnd -> do fileContent <- B.hGetContents hnd return $ decodeEither' fileContent