-- | Internal module exposing the guts of the package.  Use at
-- your own risk.  No API stability guarantees apply.
module Web.ServerSession.Frontend.Wai.Internal
  ( withServerSession
  , sessionStore
  , mkSession
  , KeyValue(..)
  , createCookieTemplate
  , calculateMaxAge
  , forceInvalidate
  ) where

import Control.Applicative as A
import Control.Monad (guard)
import Control.Monad.IO.Class (MonadIO(..))
import Data.ByteString (ByteString)
import Data.Default (def)
import Data.Kind (Type)
import Data.Text (Text)
import Web.PathPieces (toPathPiece)
import Web.ServerSession.Core
import Web.ServerSession.Core.Internal (absoluteTimeout, idleTimeout, persistentCookies)

import qualified Data.ByteString.Char8 as B8
import qualified Data.HashMap.Strict as HM
import qualified Data.IORef as I
import qualified Data.Text.Encoding as TE
import qualified Data.Time as TI
import qualified Data.Vault.Lazy as V
import qualified Network.Wai as W
import qualified Network.Wai.Session as WS
import qualified Web.Cookie as C


-- | Construct the @wai-session@ middleware using the given
-- storage backend and options.  This is a convenient function
-- that uses 'WS.withSession', 'createState', 'sessionStore',
-- 'getCookieName' and 'createCookieTemplate'.
withServerSession
  :: (Functor m, MonadIO m, MonadIO n, Storage sto, SessionData sto ~ SessionMap)
  => V.Key (WS.Session m Text ByteString) -- ^ 'V.Vault' key to use when passing the session through.
  -> (State sto -> State sto)             -- ^ Set any options on the @serversession@ state.
  -> sto                                  -- ^ Storage backend.
  -> n W.Middleware
withServerSession key opts storage = liftIO $ do
  st <- opts <$> createState storage
  return $
    WS.withSession
      (sessionStore st)
      (TE.encodeUtf8 $ getCookieName st)
      (createCookieTemplate st)
      key


-- | Construct the @wai-session@ session store using the given
-- state.  Note that keys and values types are fixed.
--
-- As @wai-session@ always requires a value to be provided, we
-- return an empty @ByteString@ when the empty session was not
-- saved.
sessionStore
  :: (Functor m, MonadIO m, Storage sto, KeyValue (SessionData sto))
  => State sto -- ^ @serversession@ state, incl. storage backend.
  -> WS.SessionStore m (Key (SessionData sto)) (Value (SessionData sto))
     -- ^ @wai-session@ session store.
sessionStore state =
  \mcookieVal -> do
    (data1, saveSessionToken) <- loadSession state mcookieVal
    sessionRef <- I.newIORef data1
    let save = do
          data2 <- I.atomicModifyIORef' sessionRef $ \a -> (a, a)
          msession <- saveSession state saveSessionToken data2
          return $ maybe "" (TE.encodeUtf8 . toPathPiece . sessionKey) msession
    return (mkSession sessionRef, save)


-- | Build a 'WS.Session' from an 'I.IORef' containing the
-- session data.
mkSession :: (Functor m, MonadIO m, KeyValue sess) => I.IORef sess -> WS.Session m (Key sess) (Value sess)
mkSession sessionRef =
  -- We need to use atomicModifyIORef instead of readIORef
  -- because latter may be reordered (cf. "Memory Model" on
  -- Data.IORef's documentation).
  ( \k   -> kvLookup k A.<$> liftIO (I.atomicModifyIORef' sessionRef $ \a -> (a, a))
  , \k v -> liftIO (I.atomicModifyIORef' sessionRef $ flip (,) () . kvInsert k v)
  )


----------------------------------------------------------------------


-- | Class for session data types that can be used as key-value
-- stores.
class IsSessionData sess => KeyValue sess where
  type Key   sess :: Type
  type Value sess :: Type
  kvLookup :: Key sess -> sess -> Maybe (Value sess)
  kvInsert :: Key sess -> Value sess -> sess -> sess


instance KeyValue SessionMap where
  type Key   SessionMap = Text
  type Value SessionMap = ByteString
  kvLookup k = HM.lookup k . unSessionMap
  kvInsert k v (SessionMap m) = SessionMap (HM.insert k v m)


----------------------------------------------------------------------


-- | Create a cookie template given a state.
--
-- Since we don't have access to the 'Session', we can't fill the
-- @Expires@ field.  Besides, as the template is constant,
-- eventually the @Expires@ field would become outdated.  This is
-- a limitation of @wai-session@'s interface, not a
-- @serversession@ limitation.  Other frontends support the
-- @Expires@ field.
--
-- Instead, we fill only the @Max-age@ field.  It works fine for
-- modern browsers, but many don't support it and will treat the
-- cookie as non-persistent (notably IE 6, 7 and 8).
createCookieTemplate :: State sto -> C.SetCookie
createCookieTemplate state =
  -- Generate a cookie with the final session ID.
  def
    { C.setCookiePath     = Just "/"
    , C.setCookieMaxAge   = calculateMaxAge state
    , C.setCookieDomain   = Nothing
    , C.setCookieHttpOnly = getHttpOnlyCookies state
    , C.setCookieSecure   = getSecureCookies state
    }


-- | Calculate the @Max-age@ of a cookie template for the given
-- state.
--
--   * If the state asks for non-persistent sessions, the result
--   is @Nothing@.
--
--   * If no timeout is defined, the result is 10 years.
--
--   * Otherwise, the max age is set as the maximum timeout.
calculateMaxAge :: State sto -> Maybe TI.DiffTime
calculateMaxAge st = do
  guard (persistentCookies st)
  return $ maybe (60*60*24*3652) realToFrac
         $ idleTimeout st `max` absoluteTimeout st


-- | Invalidate the current session ID (and possibly more, check
-- 'ForceInvalidate').  This is useful to avoid session fixation
-- attacks (cf. <http://www.acrossecurity.com/papers/session_fixation.pdf>).
forceInvalidate :: WS.Session m Text ByteString -> ForceInvalidate -> m ()
forceInvalidate (_, insert) = insert forceInvalidateKey . B8.pack . show