1 {-# LANGUAGE OverloadedStrings #-}
    2 module Databrary.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 Databrary.Ops
   16 import Databrary.Has
   17 import Databrary.Service.Crypto
   18 import Databrary.Service.Types
   19 import Databrary.Model.Time
   20 import Databrary.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   })