content: {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE KindSignatures #-}
  {-# LANGUAGE Rank2Types #-}
  {-# LANGUAGE LambdaCase #-}
  
  module Web.Apiary.Session.ClientSession
      ( ClientSessionConfig(..)
      , initClientSession
      , module Web.Apiary.Session
      ) where
  
  import Web.Apiary(MonadIO(..))
  import Web.Apiary.Session
  import Web.Apiary.Session.Internal
      (Session(Session), SessionBackend(backendMiddleware', genBackendModify))
  import Web.Apiary.Cookie(getCookies, deleteCookie, SetCookie(..), setCookie)
  import Data.Apiary.Extension(Initializer', initializer')
  
  import Control.Monad.Apiary.Action(insertVault, lookupVault, deleteVault)
  import Control.Applicative ((<$))
  
  import Foreign.C.Types(CTime(..))
  
  import System.PosixCompat.Time(epochTime)
  
  import Data.Time(DiffTime, addUTCTime)
  import Data.Time.Clock.POSIX(posixSecondsToUTCTime)
  import qualified Data.ByteString as S
  import qualified Data.Serialize as Serialize
  import qualified Data.Vault.Lazy as Vault
  import Data.Default.Class(Default(def))
  
  import qualified Web.ClientSession as CS
  
  data ClientSessionConfig = ClientSessionConfig
      { csCookieName     :: S.ByteString
      , csCookiePath     :: Maybe S.ByteString
      , csCookieDomain   :: Maybe S.ByteString
      , csCookieHttpOnly :: Bool
      , csCookieSecure   :: Bool
      , csTTL            :: Maybe DiffTime
      , csSessionKey     :: IO CS.Key
      }
  
  data ClientSessionBackend sess (m :: * -> *) = ClientSessionBackend
      { clientSessionEncryptKey :: CS.Key
      , clientSessionVaultKey   :: Vault.Key sess
      , clientSessionConfig     :: ClientSessionConfig
      }
  
  instance Default ClientSessionConfig where
      def = ClientSessionConfig "_sess" (Just "/") Nothing True True
          (Just $ 7 * 24 * 60 * 60) (liftIO CS.getDefaultKey)
  
  initClientSession :: (MonadIO m, Serialize.Serialize sess)
                    => proxy sess -- ^ session type to initialize.
                    -> ClientSessionConfig
                    -> Initializer' m (Session sess m)
  initClientSession _ cfg = initializer' $ do
      eKey <- liftIO $ csSessionKey cfg
      vKey <- liftIO Vault.newKey
      return $ Session (ClientSessionBackend eKey vKey cfg)
  
  instance (Serialize.Serialize sess, MonadIO m) => SessionBackend (ClientSessionBackend sess m) sess m where
      backendMiddleware' ClientSessionBackend{clientSessionConfig = ClientSessionConfig{..}, ..} m = do
          cs  <- getCookies
          mbNow <- case lookup csCookieName cs >>= CS.decrypt clientSessionEncryptKey >>=
              either (const Nothing) Just . Serialize.decode of
                  Nothing     -> return Nothing
                  Just (t, v) -> do
                      case csTTL of
                          Nothing  -> Nothing <$ insertVault clientSessionVaultKey v
                          Just ttl -> do
                              CTime now <- liftIO epochTime
                              if t + round ttl < now
                              then return (Just now)
                              else Just now <$ insertVault clientSessionVaultKey v
          m
          lookupVault clientSessionVaultKey >>= \case
              Nothing -> deleteCookie csCookieName
              Just v  -> do
                  now <- maybe (liftIO epochTime >>= \(CTime i) -> return i) return mbNow
                  v'  <- liftIO . CS.encryptIO clientSessionEncryptKey $ Serialize.encode (now, v)
                  let cCookie = def
                          { setCookieName     = csCookieName
                          , setCookieValue    = v'
                          , setCookiePath     = csCookiePath
                          , setCookieDomain   = csCookieDomain
                          , setCookieHttpOnly = csCookieHttpOnly
                          , setCookieSecure   = csCookieSecure
                          }
                  case csTTL of
                      Nothing -> setCookie cCookie
                      Just d  -> do
                          let now' = posixSecondsToUTCTime $ realToFrac now
                          setCookie cCookie
                              { setCookieMaxAge  = Just d
                              , setCookieExpires = Just (addUTCTime (realToFrac d) now')
                              }
  
      genBackendModify ClientSessionBackend{clientSessionConfig = ClientSessionConfig{..}, ..} f = do
          sess       <- lookupVault clientSessionVaultKey
          (sess', a) <- f sess
          maybe (deleteVault clientSessionVaultKey) (insertVault clientSessionVaultKey) sess'
          return a
  