module Snap.Snaplet.Session.SecureCookie where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Data.ByteString (ByteString)
import Data.Time
import Data.Time.Clock.POSIX
import Data.Serialize
import Snap.Core
import Web.ClientSession
instance Serialize UTCTime where
put t = put (round (utcTimeToPOSIXSeconds t) :: Integer)
get = posixSecondsToUTCTime . fromInteger <$> get
type SecureCookie t = (UTCTime, t)
getSecureCookie :: (MonadSnap m, Serialize t)
=> ByteString
-> Key
-> Maybe Int
-> m (Maybe t)
getSecureCookie name key timeout = do
rqCookie <- getCookie name
rspCookie <- getResponseCookie name <$> getResponse
let ck = rspCookie `mplus` rqCookie
let val = fmap cookieValue ck >>= decrypt key >>= return . decode
let val' = val >>= either (const Nothing) Just
case val' of
Nothing -> return Nothing
Just (ts, t) -> do
to <- checkTimeout timeout ts
return $ case to of
True -> Nothing
False -> Just t
setSecureCookie :: (MonadSnap m, Serialize t)
=> ByteString
-> Key
-> Maybe Int
-> t
-> m ()
setSecureCookie name key to val = do
t <- liftIO getCurrentTime
let expire = to >>= Just . flip addUTCTime t . fromIntegral
val' <- liftIO . encryptIO key . encode $ (t, val)
let nc = Cookie name val' expire Nothing (Just "/") False True
modifyResponse $ addResponseCookie nc
checkTimeout :: (MonadSnap m) => Maybe Int -> UTCTime -> m Bool
checkTimeout Nothing _ = return False
checkTimeout (Just x) t0 = do
t1 <- liftIO getCurrentTime
return $ t1 > addUTCTime (fromIntegral x) t0