SecureCookie.hs

{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
------------------------------------------------------------------------------
-- | This is a support module meant to back all session back-end
-- implementations.
--
-- It gives us an encrypted and timestamped cookie that can store an arbitrary
-- serializable payload. For security, it will:
--
--   * Encrypt its payload together with a timestamp.
--
--   * Check the timestamp for session expiration everytime you read from the
--     cookie. This will limit intercept-and-replay attacks by disallowing
--     cookies older than the timeout threshold.

module Snap.Snaplet.Session.SecureCookie
       ( SecureCookie
       , getSecureCookie
       , setSecureCookie
       , expireSecureCookie
       -- ** Helper functions
       , encodeSecureCookie
       , decodeSecureCookie
       , checkTimeout
       ) where

------------------------------------------------------------------------------
import           Control.Monad
import           Control.Monad.Trans
import           Data.ByteString       (ByteString)
import           Data.Serialize
import           Data.Time
import           Data.Time.Clock.POSIX
import           Snap.Core
import           Web.ClientSession

#if !MIN_VERSION_base(4,8,0)
import           Control.Applicative
#endif

------------------------------------------------------------------------------
-- | Arbitrary payload with timestamp.
type SecureCookie t = (UTCTime, t)


------------------------------------------------------------------------------
-- | Get the cookie payload.
getSecureCookie :: (MonadSnap m, Serialize t)
                => ByteString       -- ^ Cookie name
                -> Key              -- ^ Encryption key
                -> Maybe Int        -- ^ Timeout in seconds
                -> 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 >>= decodeSecureCookie key
    case val of
      Nothing -> return Nothing
      Just (ts, t) -> do
          to <- checkTimeout timeout ts
          return $ case to of
            True -> Nothing
            False -> Just t


------------------------------------------------------------------------------
-- | Decode secure cookie payload wih key.
decodeSecureCookie  :: Serialize a
                     => Key                     -- ^ Encryption key
                     -> ByteString              -- ^ Encrypted payload
                     -> Maybe (SecureCookie a)
decodeSecureCookie key value = do
    cv <- decrypt key value
    (i, val) <- either (const Nothing) Just $ decode cv
    return $ (posixSecondsToUTCTime (fromInteger i), val)


------------------------------------------------------------------------------
-- | Inject the payload.
setSecureCookie :: (MonadSnap m, Serialize t)
                => ByteString       -- ^ Cookie name
                -> Maybe ByteString -- ^ Cookie domain
                -> Key              -- ^ Encryption key
                -> Maybe Int        -- ^ Max age in seconds
                -> t                -- ^ Serializable payload
                -> m ()
setSecureCookie name domain key to val = do
    t <- liftIO getCurrentTime
    val' <- encodeSecureCookie key (t, val)
    let expire = to >>= Just . flip addUTCTime t . fromIntegral
    let nc = Cookie name val' expire domain (Just "/") False True
    modifyResponse $ addResponseCookie nc


------------------------------------------------------------------------------
-- | Encode SecureCookie with key into injectable payload
encodeSecureCookie :: (MonadIO m, Serialize t)
                    => Key            -- ^ Encryption key
                    -> SecureCookie t -- ^ Payload
                    -> m ByteString
encodeSecureCookie key (t, val) =
    liftIO $ encryptIO key . encode $ (seconds, val)
  where
    seconds = round (utcTimeToPOSIXSeconds t) :: Integer


------------------------------------------------------------------------------
-- | Expire secure cookie
expireSecureCookie :: MonadSnap m
                   => ByteString       -- ^ Cookie name
                   -> Maybe ByteString -- ^ Cookie domain
                   -> m ()
expireSecureCookie name domain = expireCookie cookie
  where
    cookie = Cookie name "" Nothing domain (Just "/") False False


------------------------------------------------------------------------------
-- | Validate session against timeout policy.
--
-- * If timeout is set to 'Nothing', never trigger a time-out.
--
-- * Otherwise, do a regular time-out check based on current time and given
--   timestamp.
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