1 {-# LANGUAGE OverloadedStrings #-}
    2 module HTTP.Cookie
    3   ( getSignedCookie
    4   , setSignedCookie
    5   , clearCookie
    6   ) where
    7 
    8 import qualified Data.ByteString as BS
    9 import qualified Data.ByteString.Builder as BSB
   10 import qualified Data.ByteString.Lazy as BSL
   11 import Network.HTTP.Types (Header, hCookie)
   12 import qualified Network.Wai as Wai
   13 import qualified Web.Cookie as Cook
   14 
   15 import Ops
   16 import Has
   17 import Service.Crypto
   18 import Service.Types
   19 import Model.Time
   20 import HTTP.Request
   21 
   22 getCookies :: Request -> Cook.Cookies
   23 getCookies = maybe [] Cook.parseCookies . lookupRequestHeader hCookie
   24 
   25 getSignedCookie :: (MonadHas Secret c m, MonadHasRequest c m) => BS.ByteString -> m (Maybe BS.ByteString)
   26 getSignedCookie c = flatMapM unSign . lookup c =<< peeks getCookies
   27 
   28 -- | sign the value, generate cookie, and provide set cookie response header
   29 setSignedCookie
   30     :: (MonadSign c m, MonadHasRequest c m)
   31     => BS.ByteString -- ^ cookie name
   32     -> BS.ByteString -- ^ cookie value (unsigned)
   33     -> Timestamp     -- ^ expiration for this cookie value
   34     -> m Header
   35 setSignedCookie c val ex  = do
   36   val' <- sign val
   37   sec <- peeks Wai.isSecure
   38   return ("set-cookie", BSL.toStrict $ BSB.toLazyByteString $ Cook.renderSetCookie $ Cook.def
   39     { Cook.setCookieName = c
   40     , Cook.setCookieValue = val'
   41     , Cook.setCookiePath = Just "/"
   42     , Cook.setCookieExpires = Just ex
   43     , Cook.setCookieSecure = sec
   44     , Cook.setCookieHttpOnly = True
   45     })
   46 
   47 clearCookie :: BS.ByteString -> Header
   48 clearCookie c = ("set-cookie", BSL.toStrict $ BSB.toLazyByteString $ Cook.renderSetCookie $ Cook.def
   49   { Cook.setCookieName = c
   50   , Cook.setCookiePath = Just "/"
   51   })