content: {-# 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
  