1import Test.Tasty (defaultMain, testGroup) 2import Test.Tasty.QuickCheck (testProperty) 3import Test.Tasty.HUnit (testCase) 4import Test.QuickCheck 5import Test.HUnit ((@=?), Assertion) 6 7import Web.Cookie 8import Data.ByteString.Builder (Builder, word8, toLazyByteString) 9import qualified Data.ByteString as S 10import qualified Data.ByteString.Char8 as S8 11import qualified Data.ByteString.Lazy as L 12import Data.Word (Word8) 13import Data.Monoid (mconcat) 14import Control.Arrow ((***)) 15import Control.Applicative ((<$>), (<*>)) 16import Data.Time (UTCTime (UTCTime), toGregorian) 17import qualified Data.Text as T 18 19main :: IO () 20main = defaultMain $ testGroup "cookie" 21 [ testProperty "parse/render cookies" propParseRenderCookies 22 , testProperty "parse/render SetCookie" propParseRenderSetCookie 23 , testProperty "parse/render cookies text" propParseRenderCookiesText 24 , testCase "parseCookies" caseParseCookies 25 , twoDigit 24 2024 26 , twoDigit 69 2069 27 , twoDigit 70 1970 28 ] 29 30propParseRenderCookies :: Cookies' -> Bool 31propParseRenderCookies cs' = 32 parseCookies (builderToBs $ renderCookies cs) == cs 33 where 34 cs = map (fromUnChars *** fromUnChars) cs' 35 36propParseRenderCookiesText :: Cookies' -> Bool 37propParseRenderCookiesText cs' = 38 parseCookiesText (builderToBs $ renderCookiesText cs) == cs 39 where 40 cs = map (T.pack . map unChar'' *** T.pack . map unChar'') cs' 41 unChar'' = toEnum . fromEnum . unChar' 42 43fromUnChars :: [Char'] -> S.ByteString 44fromUnChars = S.pack . map unChar' 45 46builderToBs :: Builder -> S.ByteString 47builderToBs = S.concat . L.toChunks . toLazyByteString 48 49type Cookies' = [([Char'], [Char'])] 50newtype Char' = Char' { unChar' :: Word8 } 51instance Show Char' where 52 show (Char' w) = [toEnum $ fromEnum w] 53 showList = (++) . show . concatMap show 54instance Arbitrary Char' where 55 arbitrary = fmap (Char' . toEnum) $ choose (62, 125) 56newtype SameSiteOption' = SameSiteOption' { unSameSiteOption' :: SameSiteOption } 57instance Arbitrary SameSiteOption' where 58 arbitrary = fmap SameSiteOption' (elements [sameSiteLax, sameSiteStrict, sameSiteNone]) 59 60propParseRenderSetCookie :: SetCookie -> Bool 61propParseRenderSetCookie sc = 62 parseSetCookie (builderToBs $ renderSetCookie sc) == sc 63 64instance Arbitrary SetCookie where 65 arbitrary = do 66 name <- fmap fromUnChars arbitrary 67 value <- fmap fromUnChars arbitrary 68 path <- fmap (fmap fromUnChars) arbitrary 69 expires <- fmap (parseCookieExpires . formatCookieExpires) 70 (UTCTime <$> fmap toEnum arbitrary <*> return 0) 71 domain <- fmap (fmap fromUnChars) arbitrary 72 httponly <- arbitrary 73 secure <- arbitrary 74 sameSite <- fmap (fmap unSameSiteOption') arbitrary 75 return def 76 { setCookieName = name 77 , setCookieValue = value 78 , setCookiePath = path 79 , setCookieExpires = expires 80 , setCookieDomain = domain 81 , setCookieHttpOnly = httponly 82 , setCookieSecure = secure 83 , setCookieSameSite = sameSite 84 } 85 86caseParseCookies :: Assertion 87caseParseCookies = do 88 let input = S8.pack "a=a1;b=b2; c=c3" 89 expected = [("a", "a1"), ("b", "b2"), ("c", "c3")] 90 map (S8.pack *** S8.pack) expected @=? parseCookies input 91 92-- Tests for two digit years, see: 93-- 94-- https://github.com/snoyberg/cookie/issues/5 95twoDigit x y = 96 testCase ("year " ++ show x) (y @=? year) 97 where 98 (year, _, _) = toGregorian day 99 day = 100 case setCookieExpires sc of 101 Just (UTCTime day _) -> day 102 Nothing -> error $ "setCookieExpires == Nothing for: " ++ show str 103 sc = parseSetCookie str 104 str = S8.pack $ concat 105 [ "foo=bar; Expires=Mon, 29-Jul-" 106 , show x 107 , " 04:52:08 GMT" 108 ] 109