src/server/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.Scotty.Trans
import Web.Cookie

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, ScottyError e) => SetCookie -> ActionT e m ()
setCookie name = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie name)

setSimpleCookie :: (Monad m, ScottyError e) => 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, ScottyError e) => Conf -> TS.Text -> ActionT e m ()
deleteCookie conf name = setCookie $ (makeSimpleCookie conf name "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 }