server/src/Cookie.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56

{-# LANGUAGE OverloadedStrings #-}

module Cookie
  ( makeSimpleCookie
  , setCookie
  , setSimpleCookie
  , getCookie
  , getCookies
  , deleteCookie
  ) where

import           Control.Monad            (liftM)

import qualified Data.Text                as TS
import qualified Data.Text.Encoding       as TS
import qualified Data.Text.Lazy.Encoding  as TL

import           Conf                     (Conf)
import qualified Conf

import qualified Data.Map                 as Map

import qualified Data.ByteString.Lazy     as BSL

import           Data.Time.Clock.POSIX    (posixSecondsToUTCTime)

import           Blaze.ByteString.Builder (toLazyByteString)

import           Web.Cookie
import           Web.Scotty.Trans

makeSimpleCookie :: Conf -> TS.Text -> TS.Text -> SetCookie
makeSimpleCookie conf name value =
  def
    { setCookieName  = TS.encodeUtf8 name
    , setCookieValue = TS.encodeUtf8 value
    , setCookiePath = Just $ TS.encodeUtf8 "/"
    , setCookieSecure = Conf.https conf
    }

setCookie :: (Monad m) => SetCookie -> ActionT e m ()
setCookie name = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie name)

setSimpleCookie :: (Monad m) => Conf -> TS.Text -> TS.Text -> ActionT e m ()
setSimpleCookie conf name value = setCookie $ makeSimpleCookie conf name value

getCookie :: (Monad m, ScottyError e) => TS.Text -> ActionT e m (Maybe TS.Text)
getCookie name = liftM (Map.lookup name) getCookies

getCookies :: (Monad m, ScottyError e) => ActionT e m (Map.Map TS.Text TS.Text)
getCookies =
  liftM (Map.fromList . maybe [] parse) $ header "Cookie"
  where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8

deleteCookie :: (Monad m) => Conf -> TS.Text -> ActionT e m ()
deleteCookie conf name = setCookie $ (makeSimpleCookie conf name "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 }