{-# LANGUAGE RecordWildCards #-}

-- | A manager for TLS 1.2/1.3 session ticket.
--
--   Tracking client hello is not implemented yet.
--   So, if this is used for TLS 1.3 0-RTT,
--   replay attack is possible.
--   If your application data in 0-RTT changes the status of server side,
--   use 'Network.TLS.SessionManager' instead.
--
--   A dedicated thread is running repeatedly to replece
--   secret keys. So, energy saving is not achieved.
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

-- | Configuration for session tickets.
data Config = Config
    { Config -> Int
ticketLifetime :: Int
    -- ^ Ticket lifetime in seconds.
    , Config -> Int
secretKeyInterval :: Int
    }

-- | ticketLifetime: 2 hours (7200 seconds), secretKeyInterval: 30 minutes (1800 seconds)
defaultConfig :: Config
defaultConfig :: Config
defaultConfig =
    Config
        { ticketLifetime :: Int
ticketLifetime = Int
7200 -- 2 hours
        , secretKeyInterval :: Int
secretKeyInterval = Int
1800 -- 30 minites
        }

-- | Creating a session ticket manager.
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
noSessionManager
        { sessionResume = resume ctmgr
        , sessionResumeOnlyOnce = resume ctmgr
        , sessionEstablish = establish ctmgr
        , sessionInvalidate = \Ticket
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        , sessionUseTicket = True
        }

establish :: CT.TokenManager -> SessionID -> SessionData -> IO (Maybe Ticket)
establish :: TokenManager -> Ticket -> SessionData -> IO (Maybe Ticket)
establish TokenManager
ctmgr Ticket
_ SessionData
sd = Ticket -> Maybe Ticket
forall a. a -> Maybe a
Just (Ticket -> Maybe Ticket) -> IO Ticket -> IO (Maybe Ticket)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TokenManager -> Ticket -> IO Ticket
CT.encryptToken TokenManager
ctmgr Ticket
b
  where
    b :: Ticket
b = ByteString -> Ticket
L.toStrict (ByteString -> Ticket) -> ByteString -> Ticket
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 -> Ticket -> IO (Maybe SessionData)
resume TokenManager
ctmgr Ticket
ticket
    | Ticket -> Bool
isTicket Ticket
ticket = do
        Maybe Ticket
msdb <- TokenManager -> Ticket -> IO (Maybe Ticket)
CT.decryptToken TokenManager
ctmgr Ticket
ticket
        case Maybe Ticket
msdb of
            Maybe Ticket
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 Ticket
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
$ Ticket -> ByteString
L.fromStrict Ticket
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