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