{-# LANGUAGE RecordWildCards #-}
module Network.TLS.SessionTicket (
newSessionTicketManager,
Config,
defaultConfig,
ticketLifetime,
secretKeyInterval,
) where
import Codec.Serialise
import qualified Crypto.Token as CT
import qualified Data.ByteString.Lazy as L
import Network.TLS
import Network.TLS.Internal
data Config = Config
{ Config -> Int
ticketLifetime :: Int
, Config -> Int
secretKeyInterval :: Int
}
defaultConfig :: Config
defaultConfig :: Config
defaultConfig =
Config
{ ticketLifetime :: Int
ticketLifetime = Int
7200
, secretKeyInterval :: Int
secretKeyInterval = Int
1800
}
newSessionTicketManager :: Config -> IO SessionManager
newSessionTicketManager :: Config -> IO SessionManager
newSessionTicketManager Config{Int
ticketLifetime :: Config -> Int
secretKeyInterval :: Config -> Int
ticketLifetime :: Int
secretKeyInterval :: Int
..} =
TokenManager -> SessionManager
sessionTicketManager (TokenManager -> SessionManager)
-> IO TokenManager -> IO SessionManager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> IO TokenManager
CT.spawnTokenManager Config
conf
where
conf :: Config
conf =
Config
CT.defaultConfig
{ CT.interval = secretKeyInterval
, CT.tokenLifetime = ticketLifetime
}
sessionTicketManager :: CT.TokenManager -> SessionManager
sessionTicketManager :: TokenManager -> SessionManager
sessionTicketManager TokenManager
ctmgr =
SessionManager
{ sessionResume :: SessionIDorTicket -> IO (Maybe SessionData)
sessionResume = TokenManager -> SessionIDorTicket -> IO (Maybe SessionData)
resume TokenManager
ctmgr
, sessionResumeOnlyOnce :: SessionIDorTicket -> IO (Maybe SessionData)
sessionResumeOnlyOnce = TokenManager -> SessionIDorTicket -> IO (Maybe SessionData)
resume TokenManager
ctmgr
, sessionEstablish :: SessionIDorTicket -> SessionData -> IO (Maybe SessionIDorTicket)
sessionEstablish = TokenManager
-> SessionIDorTicket -> SessionData -> IO (Maybe SessionIDorTicket)
establish TokenManager
ctmgr
, sessionInvalidate :: SessionIDorTicket -> IO ()
sessionInvalidate = \SessionIDorTicket
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
, sessionUseTicket :: Bool
sessionUseTicket = Bool
True
}
establish :: CT.TokenManager -> SessionID -> SessionData -> IO (Maybe Ticket)
establish :: TokenManager
-> SessionIDorTicket -> SessionData -> IO (Maybe SessionIDorTicket)
establish TokenManager
ctmgr SessionIDorTicket
_ SessionData
sd = SessionIDorTicket -> Maybe SessionIDorTicket
forall a. a -> Maybe a
Just (SessionIDorTicket -> Maybe SessionIDorTicket)
-> IO SessionIDorTicket -> IO (Maybe SessionIDorTicket)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TokenManager -> SessionIDorTicket -> IO SessionIDorTicket
CT.encryptToken TokenManager
ctmgr SessionIDorTicket
b
where
b :: SessionIDorTicket
b = ByteString -> SessionIDorTicket
L.toStrict (ByteString -> SessionIDorTicket)
-> ByteString -> SessionIDorTicket
forall a b. (a -> b) -> a -> b
$ SessionData -> ByteString
forall a. Serialise a => a -> ByteString
serialise SessionData
sd
resume :: CT.TokenManager -> Ticket -> IO (Maybe SessionData)
resume :: TokenManager -> SessionIDorTicket -> IO (Maybe SessionData)
resume TokenManager
ctmgr SessionIDorTicket
ticket
| SessionIDorTicket -> Bool
isTicket SessionIDorTicket
ticket = do
Maybe SessionIDorTicket
msdb <- TokenManager -> SessionIDorTicket -> IO (Maybe SessionIDorTicket)
CT.decryptToken TokenManager
ctmgr SessionIDorTicket
ticket
case Maybe SessionIDorTicket
msdb of
Maybe SessionIDorTicket
Nothing -> Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
forall a. Maybe a
Nothing
Just SessionIDorTicket
sdb -> case ByteString -> Either DeserialiseFailure SessionData
forall a. Serialise a => ByteString -> Either DeserialiseFailure a
deserialiseOrFail (ByteString -> Either DeserialiseFailure SessionData)
-> ByteString -> Either DeserialiseFailure SessionData
forall a b. (a -> b) -> a -> b
$ SessionIDorTicket -> ByteString
L.fromStrict SessionIDorTicket
sdb of
Left DeserialiseFailure
_ -> Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
forall a. Maybe a
Nothing
Right SessionData
sd -> Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SessionData -> IO (Maybe SessionData))
-> Maybe SessionData -> IO (Maybe SessionData)
forall a b. (a -> b) -> a -> b
$ SessionData -> Maybe SessionData
forall a. a -> Maybe a
Just SessionData
sd
| Bool
otherwise = Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
forall a. Maybe a
Nothing