78 lines
2.7 KiB
Haskell
78 lines
2.7 KiB
Haskell
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
|