module Yesod.Core.Internal.Session
    ( encodeClientSession
    , decodeClientSession
    , clientSessionDateCacher
    , ClientSessionDateCache(..)
    , SaveSession
    , SessionBackend(..)
    ) where

import qualified Web.ClientSession as CS
import Data.Serialize
import Data.Time
import Data.ByteString (ByteString)
import Control.Monad (guard)
import Yesod.Core.Types
import Yesod.Core.Internal.Util
import Control.AutoUpdate

encodeClientSession :: CS.Key
                    -> CS.IV
                    -> ClientSessionDateCache  -- ^ expire time
                    -> ByteString -- ^ remote host
                    -> SessionMap -- ^ session
                    -> ByteString -- ^ cookie value
encodeClientSession :: Key
-> IV
-> ClientSessionDateCache
-> ByteString
-> SessionMap
-> ByteString
encodeClientSession Key
key IV
iv ClientSessionDateCache
date ByteString
rhost SessionMap
session' =
    Key -> IV -> ByteString -> ByteString
CS.encrypt Key
key IV
iv (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ SessionCookie -> ByteString
forall a. Serialize a => a -> ByteString
encode (SessionCookie -> ByteString) -> SessionCookie -> ByteString
forall a b. (a -> b) -> a -> b
$ Either UTCTime ByteString
-> ByteString -> SessionMap -> SessionCookie
SessionCookie Either UTCTime ByteString
forall {a}. Either a ByteString
expires ByteString
rhost SessionMap
session'
      where expires :: Either a ByteString
expires = ByteString -> Either a ByteString
forall a b. b -> Either a b
Right (ClientSessionDateCache -> ByteString
csdcExpiresSerialized ClientSessionDateCache
date)

decodeClientSession :: CS.Key
                    -> ClientSessionDateCache  -- ^ current time
                    -> ByteString -- ^ remote host field
                    -> ByteString -- ^ cookie value
                    -> Maybe SessionMap
decodeClientSession :: Key
-> ClientSessionDateCache
-> ByteString
-> ByteString
-> Maybe SessionMap
decodeClientSession Key
key ClientSessionDateCache
date ByteString
rhost ByteString
encrypted = do
    decrypted <- Key -> ByteString -> Maybe ByteString
CS.decrypt Key
key ByteString
encrypted
    SessionCookie (Left expire) rhost' session' <-
        either (const Nothing) Just $ decode decrypted
    guard $ expire > csdcNow date
    guard $ rhost' == rhost
    return session'


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


-- Originally copied from Kazu's date-cache, but now using mkAutoUpdate.
--
-- The cached date is updated every 10s, we don't need second
-- resolution for session expiration times.
--
-- The second component of the returned tuple used to be an action that
-- killed the updater thread, but is now a no-op that's just there
-- to preserve the type.

clientSessionDateCacher ::
     NominalDiffTime -- ^ Inactive session validity.
  -> IO (IO ClientSessionDateCache, IO ())
clientSessionDateCacher :: NominalDiffTime -> IO (IO ClientSessionDateCache, IO ())
clientSessionDateCacher NominalDiffTime
validity = do
    getClientSessionDateCache <- UpdateSettings ClientSessionDateCache
-> IO (IO ClientSessionDateCache)
forall a. UpdateSettings a -> IO (IO a)
mkAutoUpdate UpdateSettings ()
defaultUpdateSettings
      { updateAction = getUpdated
      , updateFreq   = 10000000 -- 10s
      }

    return (getClientSessionDateCache, return ())
  where
    getUpdated :: IO ClientSessionDateCache
getUpdated = do
      now <- IO UTCTime
getCurrentTime
      let expires  = NominalDiffTime
validity NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
now
          expiresS = Put -> ByteString
runPut (UTCTime -> Put
putTime UTCTime
expires)
      return $! ClientSessionDateCache now expires expiresS