{-# 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
        { 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