    {-# 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
                , CT.threadName = "TLS ticket manager"
                }

    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 = LazyByteString -> Ticket
    L.toStrict (LazyByteString -> Ticket) -> LazyByteString -> Ticket
    forall a b. (a -> b) -> a -> b
    $ SessionData -> LazyByteString
    forall a. Serialise a => a -> LazyByteString
    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
            msdb <- TokenManager -> Ticket -> IO (Maybe Ticket)
    CT.decryptToken TokenManager
    ctmgr Ticket
    ticket
            case 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 LazyByteString -> Either DeserialiseFailure SessionData
    forall a.
    Serialise a =>
    LazyByteString -> Either DeserialiseFailure a
    deserialiseOrFail (LazyByteString -> Either DeserialiseFailure SessionData)
    -> LazyByteString -> Either DeserialiseFailure SessionData
    forall a b. (a -> b) -> a -> b
    $ Ticket -> LazyByteString
    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