module Model.Tokens.Session
  ( SessionToken(..)
  , _sessionIdentifier, _sessionId, _sessionIssuedBy, _sessionIssuedAt, _sessionExpiresAt, _sessionStartsAt
  ) where

import ClassyPrelude.Yesod

import Model.Tokens.Lens
import Model
import Utils.Lens
  
import Web.ServerSession.Core
  
import Jose.Jwt (IntDate(..))
import qualified Jose.Jwt as Jose

import Data.Time.Clock.POSIX

import Control.Monad.Fail


data SessionToken sess = SessionToken
  { sessionIdentifier :: TokenId
  , sessionId         :: SessionId sess
  , sessionIssuedAt   :: UTCTime
  , sessionIssuedBy   :: InstanceId
  , sessionIssuedFor  :: ClusterId
  , sessionExpiresAt
  , sessionStartsAt   :: Maybe UTCTime
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)

makeLenses_ ''SessionToken
instance HasTokenIdentifier (SessionToken sess) TokenId where
  _tokenIdentifier = _sessionIdentifier
instance HasTokenIssuedBy (SessionToken sess) InstanceId where
  _tokenIssuedBy = _sessionIssuedBy
instance HasTokenIssuedFor (SessionToken sess) ClusterId where
  _tokenIssuedFor = _sessionIssuedFor
instance HasTokenIssuedAt (SessionToken sess) UTCTime where
  _tokenIssuedAt = _sessionIssuedAt
instance HasTokenExpiresAt (SessionToken sess) (Maybe UTCTime) where
  _tokenExpiresAt = _sessionExpiresAt
instance HasTokenStartsAt (SessionToken sess) (Maybe UTCTime) where
  _tokenStartsAt = _sessionStartsAt

instance ToJSON (SessionToken sess) where
  toJSON SessionToken{..} = toJSON Jose.JwtClaims{..}
    where jwtIss = Just $ toPathPiece sessionIssuedBy
          jwtSub = Just $ toPathPiece sessionId
          jwtAud = Just . pure $ toPathPiece sessionIssuedFor
          jwtExp = IntDate . utcTimeToPOSIXSeconds <$> sessionExpiresAt
          jwtNbf = IntDate . utcTimeToPOSIXSeconds <$> sessionStartsAt
          jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds sessionIssuedAt
          jwtJti = Just $ toPathPiece sessionIdentifier

instance FromJSON (SessionToken sess) where
  parseJSON val = do
    Jose.JwtClaims{..} <- parseJSON val

    sessionIdentifier <- parseMaybe "sessionIdentfier" $
      fromPathPiece =<< jwtIss
    sessionId <- parseMaybe "sessionId" $
      fromPathPiece =<< jwtSub
    sessionIssuedAt <- parseMaybe "sessionIssuedAt" $
      unIntDate <$> jwtIat
    sessionIssuedBy <- parseMaybe "sessionIssuedBy" $
      fromPathPiece =<< jwtIss
    sessionIssuedFor <- parseMaybe "sessionIssuedFor" $ do
      [aud] <- jwtAud
      fromPathPiece aud
    let sessionExpiresAt = unIntDate <$> jwtExp
        sessionStartsAt = unIntDate <$> jwtNbf
  
    return SessionToken{..}
    where
      parseMaybe errId = maybe (fail $ "Could not parse " <> errId) return
      unIntDate (IntDate posix) = posixSecondsToUTCTime posix