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 })