45f6459 · typeable/yaml

git.iko.soy/typeable/yaml

Properly handle asynchronous exceptions (fixes #52)

And Data.Yaml.decodeFileEither and Data.Yaml.Include.decodeFileEither behave the same.

commit45f645923827bfbcc4c05383ecc81e61a186c443 authorSönke Hahn <soenke.hahn@zalora.com> dateWed 3 Dec 2014, 18:19 (12 years ago) parent5b9cc0a

6 files changed+40−28

compare with master

unifiedsplit

Data/Yaml.hs+4−23 Data/Yaml/Include.hs+2−3 Data/Yaml/Internal.hs+18−1 test/Data/Yaml/IncludeSpec.hs+7 test/Data/YamlSpec.hs+7−1 yaml.cabal+2

Data/Yaml.hs+4−23

@@ -62,10 +62,8 @@ import Data.Aeson

6262import Data.Aeson.Types (Pair, parseMaybe, parseEither, Parser)

6363import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)

6464import Data.ByteString (ByteString)

65−import qualified Data.Map as Map

6665import System.IO.Unsafe (unsafePerformIO)

67−import Control.Exception (try, throwIO, fromException, AsyncException)

68−import Control.Monad.Trans.State

66+import Control.Exception

6967import qualified Data.Conduit as C

7068import qualified Data.Conduit.List as CL

7169import qualified Data.Vector as V

@@ -164,8 +162,8 @@ decode :: FromJSON a

164162 => ByteString

165163 -> Maybe a

166164decode bs = unsafePerformIO

167− $ fmap (either (const Nothing) (either (const Nothing) Just))

168− $ decodeHelper (Y.decode bs)

165+ $ fmap (either (const Nothing) id)

166+ $ decodeHelper_ (Y.decode bs)

169167

170168decodeFile :: FromJSON a

171169 => FilePath

@@ -179,24 +177,7 @@ decodeFileEither

179177 :: FromJSON a

180178 => FilePath

181179 -> IO (Either ParseException a)

182−decodeFileEither fp = do

183− x <- try $ runResourceT $ flip evalStateT Map.empty $ Y.decodeFile fp C.$$ parse

184− case x of

185− Left e

186− | Just pe <- fromException e -> return $ Left pe

187− | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)

188− | shouldBeCaught e -> return $ Left $ OtherParseException e

189− | otherwise -> throwIO e

190− Right y ->

191− return $ case parseEither parseJSON y of

192− Left s -> Left $ AesonException s

193− Right v -> Right v

194− where

195− -- FIXME this function needs more thought

196− shouldBeCaught e

197− | Just (_ :: AsyncException) <- fromException e = False

198− -- Would be nice... | Just (_ :: Timeout) <- fromException e = False

199− | otherwise = True

180+decodeFileEither = decodeHelper_ . Y.decodeFile

200181

201182decodeEither :: FromJSON a => ByteString -> Either String a

202183decodeEither bs = unsafePerformIO

Data/Yaml/Include.hs+2−3

@@ -1,7 +1,6 @@

11{-# LANGUAGE RankNTypes #-}

22module Data.Yaml.Include (decodeFile, decodeFileEither) where

4−import Control.Applicative

54import Control.Monad (when)

65import Control.Exception (throwIO)

76import Control.Monad.IO.Class (liftIO)

@@ -13,7 +12,7 @@ import Data.Text.Encoding (decodeUtf8)

1312import Data.Aeson (FromJSON)

1413import Data.Conduit

1514import qualified Data.Conduit.List as CL

16−import Data.Yaml (ParseException(..), decodeHelper)

15+import Data.Yaml.Internal (ParseException(..), decodeHelper_, decodeHelper)

1716import Text.Libyaml hiding (decodeFile)

1817import qualified Text.Libyaml as Y

1918

@@ -59,4 +58,4 @@ decodeFileEither

5958 :: FromJSON a

6059 => FilePath

6160 -> IO (Either ParseException a)

62−decodeFileEither fp = either Left (either (Left . AesonException) Right) <$> decodeHelper (eventsFromFile fp)

61+decodeFileEither = decodeHelper_ . eventsFromFile

Data/Yaml/Internal.hs+18−1

@@ -7,6 +7,7 @@ module Data.Yaml.Internal

77 ParseException(..)

88 , parse

99 , decodeHelper

10+ , decodeHelper_

1011 ) where

1112

1213import qualified Text.Libyaml as Y

@@ -16,6 +17,7 @@ import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)

1617import Data.ByteString (ByteString)

1718import qualified Data.Map as Map

1819import Control.Exception

20+import Control.Exception.Enclosed

1921import Control.Monad.Trans.State

2022import qualified Data.Conduit as C

2123import qualified Data.Conduit.List as CL

@@ -193,10 +195,25 @@ decodeHelper :: FromJSON a

193195 => C.Source Parse Y.Event

194196 -> IO (Either ParseException (Either String a))

195197decodeHelper src = do

196− x <- try $ runResourceT $ flip evalStateT Map.empty $ src C.$$ parse

198+ x <- tryAny $ runResourceT $ flip evalStateT Map.empty $ src C.$$ parse

197199 case x of

198200 Left e

199201 | Just pe <- fromException e -> return $ Left pe

200202 | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)

201203 | otherwise -> throwIO e

202204 Right y -> return $ Right $ parseEither parseJSON y

205+

206+decodeHelper_ :: FromJSON a

207+ => C.Source Parse Event

208+ -> IO (Either ParseException a)

209+decodeHelper_ src = do

210+ x <- tryAny $ runResourceT $ flip evalStateT Map.empty $ src C.$$ parse

211+ return $ case x of

212+ Left e

213+ | Just pe <- fromException e -> Left pe

214+ | Just ye <- fromException e -> Left $ InvalidYaml $ Just (ye :: YamlException)

215+ | otherwise -> Left $ OtherParseException e

216+ Right y -> either

217+ (Left . AesonException)

218+ Right

219+ (parseEither parseJSON y)

test/Data/Yaml/IncludeSpec.hs+7

@@ -2,8 +2,10 @@

22module Data.Yaml.IncludeSpec (main, spec) where

44import Test.Hspec

5+import Test.Hspec.Expectations.Contrib

56import Data.Aeson

67import Data.Aeson.QQ

8+import Data.Yaml (ParseException)

810import Data.Yaml.Include

911

@@ -35,3 +37,8 @@ spec = do

3537

3638 it "aborts on cyclic includes" $ do

3739 (decodeFile "test/resources/loop/foo.yaml" :: IO (Maybe Value)) `shouldThrow` anyException

40+

41+ describe "decodeFileEither" $ do

42+ context "when file does not exist" $ do

43+ it "returns Left" $ do

44+ (decodeFileEither "./does_not_exist.yaml" :: IO (Either ParseException Value)) >>= (`shouldSatisfy` isLeft)

test/Data/YamlSpec.hs+7−1

@@ -19,6 +19,7 @@ import System.Directory

1919import Control.Monad

2020import Control.Exception (try, SomeException)

2121import Test.Hspec

22+import Test.Hspec.Expectations.Contrib

2223

2324import qualified Data.Yaml as D

2425import Data.Yaml (object, array, (.=))

@@ -114,7 +115,7 @@ spec = do

114115 in D.decode (D.encode value') `shouldBe` Just value'

115116 mapM_ tester specialStrings

116117

117− describe "yamlFileJSONparse" $

118+ describe "decodeFileEither" $ do

118119 it "loads YAML through JSON into Haskell data" $ do

119120 tj <- either (error . show) id `fmap` D.decodeFileEither "test/json.yaml"

120121 tj `shouldBe` TestJSON

@@ -125,6 +126,11 @@ spec = do

125126 , extrastring = "1234-foo"

126127 }

127128

129+ context "when file does not exist" $ do

130+ it "returns Left" $ do

131+ (D.decodeFileEither "./does_not_exist.yaml" :: IO (Either D.ParseException D.Value)) >>= (`shouldSatisfy` isLeft)

132+

133+

128134 describe "round-tripping of special scalars" $ do

129135 let special = words "y Y On ON false 12345 12345.0 12345a 12e3"

130136 forM_ special $ \w -> it w $

yaml.cabal+2

@@ -52,6 +52,7 @@ library

5252 , scientific

5353 , filepath

5454 , directory

55+ , enclosed-exceptions

5556 exposed-modules: Text.Libyaml

5657 Data.Yaml

5758 Data.Yaml.Aeson

@@ -113,6 +114,7 @@ test-suite spec

113114 Data.Yaml.IncludeSpec

114115 cpp-options: -DTEST

115116 build-depends: hspec >= 1.3

117+ , hspec-expectations

116118 , HUnit

117119 , directory

118120 , base >= 4 && < 5