Make toHeader total (instead of failing when decoding)

fizruk · Jul 23, 2016 · 5391e54 · 5391e54
1 parent d08ae5f
commit 5391e54
Show file tree

Hide file tree

Showing 3 changed files with 11 additions and 3 deletions.
diff --git a/Web/HttpApiData/Internal.hs b/Web/HttpApiData/Internal.hs
@@ -14,6 +14,8 @@ import Control.Applicative
 import Data.Traversable (Traversable(traverse))
 #endif
 import Control.Arrow ((&&&))
+import Control.Monad ((<=<))
+import Data.Either.Combinators (mapLeft)
 
 import Data.Monoid
 import Data.ByteString (ByteString)
@@ -23,7 +25,7 @@ import Data.Int
 import Data.Word
 
 import Data.Text (Text)
-import Data.Text.Encoding (encodeUtf8, decodeUtf8)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8')
 import Data.Text.Read (signed, decimal, rational, Reader)
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as L
@@ -73,7 +75,7 @@ class FromHttpApiData a where
 
   -- | Parse HTTP header value.
   parseHeader :: ByteString -> Either Text a
-  parseHeader = parseUrlPiece . decodeUtf8
+  parseHeader = parseUrlPiece <=< (mapLeft (T.pack . show) . decodeUtf8')
 
   -- | Parse query param value.
   parseQueryParam :: Text -> Either Text a
@@ -331,7 +333,7 @@ parseBoundedQueryParam = parseBoundedEnumOfI toQueryParam
 -- Uses @'toHeader'@ to get possible values.
 parseBoundedHeader :: (ToHttpApiData a, Bounded a, Enum a) => ByteString -> Either Text a
 parseBoundedHeader bs = case lookupBoundedEnumOf toHeader bs of
-  Nothing -> defaultParseError (decodeUtf8 bs)
+  Nothing -> defaultParseError $ T.pack $ show bs
   Just x  -> return x
 
 -- | Parse URL piece using @'Read'@ instance.

diff --git a/http-api-data.cabal b/http-api-data.cabal
@@ -26,6 +26,7 @@ library
                    , bytestring
                    , time
                    , time-locale-compat >=0.1.1.0 && <0.2
+                   , either
     if flag(use-text-show)
       cpp-options: -DUSE_TEXT_SHOW
       build-depends: text-show        >= 2
@@ -46,6 +47,7 @@ test-suite spec
                    , http-api-data
                    , text
                    , time
+                   , bytestring
 
 test-suite doctest
     build-depends:    base, doctest, Glob

diff --git a/test/Spec.hs b/test/Spec.hs
@@ -10,6 +10,7 @@ import Data.Word
 import Data.Time
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as L
+import qualified Data.ByteString as BS
 import Data.Version
 
 import Test.Hspec
@@ -126,3 +127,6 @@ spec = do
     parseUrlPieceMaybe (T.pack "256") `shouldBe` (Nothing :: Maybe Int8)
     parseUrlPieceMaybe (T.pack "-10") `shouldBe` (Nothing :: Maybe Word)
 
+  it "invalid utf8 is handled" $ do
+    parseHeaderMaybe (BS.pack [128]) `shouldBe` (Nothing :: Maybe T.Text)
+