Try to fix SetCooke instances

fizruk · Oct 5, 2018 · 48d8552 · 48d8552
1 parent af01cff
commit 48d8552
Show file tree

Hide file tree

Showing 3 changed files with 29 additions and 7 deletions.
diff --git a/http-api-data.cabal b/http-api-data.cabal
@@ -99,6 +99,7 @@ test-suite spec
                    , time
                    , bytestring
                    , uuid-types
+                   , cookie
 
     build-depends:   HUnit                >= 1.6.0.0 && <1.7
                    , hspec                >= 2.5.5   && <2.6

diff --git a/src/Web/Internal/HttpApiData.hs b/src/Web/Internal/HttpApiData.hs
@@ -24,6 +24,7 @@ import           Control.Monad                ((<=<))
 
 import           Data.ByteString              (ByteString)
 import qualified Data.ByteString              as BS
+import qualified Data.ByteString.Lazy         as LBS
 import           Data.Monoid
 
 import qualified Data.Fixed                   as F
@@ -32,7 +33,8 @@ import           Data.Word
 
 import           Data.Text                    (Text)
 import qualified Data.Text                    as T
-import           Data.Text.Encoding           (decodeUtf8', encodeUtf8)
+import           Data.Text.Encoding           (decodeUtf8With, decodeUtf8', encodeUtf8)
+import           Data.Text.Encoding.Error     (lenientDecode)
 import qualified Data.Text.Lazy               as L
 import           Data.Text.Read               (Reader, decimal, rational,
                                                signed)
@@ -539,13 +541,19 @@ instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where
   toUrlPiece (Left x)  = "left " <> toUrlPiece x
   toUrlPiece (Right x) = "right " <> toUrlPiece x
 
--- |
+-- | /Note:/ this instance works correctly for alphanumeric name and value
+--
 -- >>> let Right c = parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie
 -- >>> toUrlPiece c
--- "\"SESSID=r2t5uvjq435r4q7ib3vtdjq120\""
+-- "SESSID=r2t5uvjq435r4q7ib3vtdjq120"
+--
+-- >>> toHeader c
+-- "SESSID=r2t5uvjq435r4q7ib3vtdjq120"
+--
 instance ToHttpApiData SetCookie where
-  toUrlPiece = showt . BS.toLazyByteString . renderSetCookie
-  toEncodedUrlPiece = renderSetCookie
+  toUrlPiece = decodeUtf8With lenientDecode . toHeader
+  toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie
+  -- toEncodedUrlPiece = renderSetCookie -- doesn't do things.
 
 -- |
 -- >>> parseUrlPiece "_" :: Either Text ()
@@ -681,12 +689,14 @@ instance FromHttpApiData a => FromHttpApiData (LenientData a) where
     parseHeader     = Right . LenientData . parseHeader
     parseQueryParam = Right . LenientData . parseQueryParam
 
--- |
+-- | /Note:/ this instance works correctly for alphanumeric name and value
+--
 -- >>> parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie
 -- Right (SetCookie {setCookieName = "SESSID", setCookieValue = "r2t5uvjq435r4q7ib3vtdjq120", setCookiePath = Nothing, setCookieExpires = Nothing, setCookieMaxAge = Nothing, setCookieDomain = Nothing, setCookieHttpOnly = False, setCookieSecure = False, setCookieSameSite = Nothing})
 instance FromHttpApiData SetCookie where
   parseUrlPiece = parseHeader  . encodeUtf8
   parseHeader   = Right . parseSetCookie
+
 -------------------------------------------------------------------------------
 -- Attoparsec helpers
 -------------------------------------------------------------------------------

diff --git a/test/Web/Internal/HttpApiDataSpec.hs b/test/Web/Internal/HttpApiDataSpec.hs
@@ -5,14 +5,17 @@ module Web.Internal.HttpApiDataSpec (spec) where
 import Control.Applicative
 import qualified Data.Fixed as F
 import Data.Int
+import Data.Char
 import Data.Word
 import Data.Time
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
 import qualified Data.Text.Lazy as L
 import qualified Data.ByteString as BS
 import Data.ByteString.Builder (toLazyByteString)
 import Data.Version
 import qualified Data.UUID.Types as UUID
+import Web.Cookie (SetCookie, defaultSetCookie, setCookieName, setCookieValue)
 
 import Data.Proxy
 
@@ -56,7 +59,7 @@ checkUrlPieceI _ = checkUrlPiece (Proxy :: Proxy (RandomCase a))
 checkEncodedUrlPiece :: forall a. (Show a, ToHttpApiData a, Arbitrary a) => Proxy a -> String -> Spec
 checkEncodedUrlPiece _ = checkEncodedUrlPiece' (arbitrary :: Gen a)
 
--- | Check that 'toEncodedUrlPiece' is equivallent to default implementation.
+-- | Check that 'toEncodedUrlPiece' is equivalent to default implementation.
 -- Use a given generator.
 checkEncodedUrlPiece' :: forall a. (Show a, ToHttpApiData a) => Gen a -> String -> Spec
 checkEncodedUrlPiece' gen name = prop name $ forAll gen encodedUrlPieceProp
@@ -90,6 +93,7 @@ spec = do
     checkUrlPiece' nominalDiffTimeGen         "NominalDiffTime"
     checkUrlPiece  (Proxy :: Proxy Version)   "Version"
     checkUrlPiece' uuidGen                    "UUID"
+    checkUrlPiece' setCookieGen               "Cookie"
 
     checkUrlPiece  (Proxy :: Proxy (Maybe String))            "Maybe String"
     checkUrlPieceI (Proxy :: Proxy (Maybe Integer))           "Maybe Integer"
@@ -127,6 +131,7 @@ spec = do
     checkEncodedUrlPiece' nominalDiffTimeGen         "NominalDiffTime"
     checkEncodedUrlPiece  (Proxy :: Proxy Version)   "Version"
     checkEncodedUrlPiece' uuidGen                    "UUID"
+    checkEncodedUrlPiece' setCookieGen               "SetCookie"
 
     checkEncodedUrlPiece  (Proxy :: Proxy (Maybe String))            "Maybe String"
     checkEncodedUrlPiece  (Proxy :: Proxy (Maybe Integer))           "Maybe Integer"
@@ -179,3 +184,9 @@ utcTimeGen = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))
 
 nominalDiffTimeGen :: Gen NominalDiffTime
 nominalDiffTimeGen = fromInteger <$> arbitrary
+
+setCookieGen :: Gen SetCookie
+setCookieGen = do
+    n <- TE.encodeUtf8 . T.pack . filter isAlphaNum <$> arbitrary
+    v <- TE.encodeUtf8 . T.pack . filter isAlphaNum <$> arbitrary
+    return $ defaultSetCookie { setCookieName = n, setCookieValue = v }