    -- |
    -- Module      : Network.TLS.Context.Internal
    -- License     : BSD-style
    -- Maintainer  : Vincent Hanquez <vincent@snarc.org>
    -- Stability   : experimental
    -- Portability : unknown
    --
    module Network.TLS.Context.Internal
        (
        -- * Context configuration
          ClientParams(..)
        , ServerParams(..)
        , defaultParamsClient
        , SessionID
        , SessionData(..)
        , MaxFragmentEnum(..)
        , Measurement(..)

        -- * Context object and accessor
        , Context(..)
        , Hooks(..)
        , ctxEOF
        , ctxHasSSLv2ClientHello
        , ctxDisableSSLv2ClientHello
        , ctxEstablished
        , withLog
        , ctxWithHooks
        , contextModifyHooks
        , setEOF
        , setEstablished
        , contextFlush
        , contextClose
        , contextSend
        , contextRecv
        , updateMeasure
        , withMeasure
        , withReadLock
        , withWriteLock
        , withStateLock
        , withRWLock

        -- * information
        , Information(..)
        , contextGetInformation

        -- * Using context states
        , throwCore
        , usingState
        , usingState_
        , runTxState
        , runRxState
        , usingHState
        , getHState
        , getStateRNG
        ) where

    import Network.TLS.Backend
    import Network.TLS.Extension
    import Network.TLS.Cipher
    import Network.TLS.Credentials (Credentials)
    import Network.TLS.Struct
    import Network.TLS.Compression (Compression)
    import Network.TLS.State
    import Network.TLS.Handshake.State
    import Network.TLS.Hooks
    import Network.TLS.Record.State
    import Network.TLS.Parameters
    import Network.TLS.Measurement
    import qualified Data.ByteString as B

    import Control.Concurrent.MVar
    import Control.Monad.State
    import Control.Exception (throwIO, Exception())
    import Data.IORef
    import Data.Tuple

    -- | Information related to a running context, e.g. current cipher
    data Information = Information
        { infoVersion      :: Version
        , infoCipher       :: Cipher
        , infoCompression  :: Compression
        , infoMasterSecret :: Maybe Bytes
        , infoClientRandom :: Maybe ClientRandom
        , infoServerRandom :: Maybe ServerRandom
        } deriving (Show,Eq)

    -- | A TLS Context keep tls specific state, parameters and backend information.
    data Context = Context
        { ctxConnection       :: Backend   -- ^ return the backend object associated with this context
        , ctxSupported        :: Supported
        , ctxShared           :: Shared
        , ctxCiphers          :: Credentials -> [Cipher]  -- ^ list of allowed ciphers according to parameters
                                                          -- and additional credentials
        , ctxState            :: MVar TLSState
        , ctxMeasurement      :: IORef Measurement
        , ctxEOF_             :: IORef Bool    -- ^ has the handle EOFed or not.
        , ctxEstablished_     :: IORef Bool    -- ^ has the handshake been done and been successful.
        , ctxNeedEmptyPacket  :: IORef Bool    -- ^ empty packet workaround for CBC guessability.
        , ctxSSLv2ClientHello :: IORef Bool    -- ^ enable the reception of compatibility SSLv2 client hello.
                                               -- the flag will be set to false regardless of its initial value
                                               -- after the first packet received.
        , ctxTxState          :: MVar RecordState -- ^ current tx state
        , ctxRxState          :: MVar RecordState -- ^ current rx state
        , ctxHandshake        :: MVar (Maybe HandshakeState) -- ^ optional handshake state
        , ctxDoHandshake      :: Context -> IO ()
        , ctxDoHandshakeWith  :: Context -> Handshake -> IO ()
        , ctxHooks            :: IORef Hooks   -- ^ hooks for this context
        , ctxLockWrite        :: MVar ()       -- ^ lock to use for writing data (including updating the state)
        , ctxLockRead         :: MVar ()       -- ^ lock to use for reading data (including updating the state)
        , ctxLockState        :: MVar ()       -- ^ lock used during read/write when receiving and sending packet.
                                               -- it is usually nested in a write or read lock.
        }

    updateMeasure :: Context -> (Measurement -> Measurement) -> IO ()
    updateMeasure ctx f = do
        x <- readIORef (ctxMeasurement ctx)
        writeIORef (ctxMeasurement ctx) $! f x

    withMeasure :: Context -> (Measurement -> IO a) -> IO a
    withMeasure ctx f = readIORef (ctxMeasurement ctx) >>= f

    contextFlush :: Context -> IO ()
    contextFlush = backendFlush . ctxConnection

    contextClose :: Context -> IO ()
    contextClose = backendClose . ctxConnection

    -- | Information about the current context
    contextGetInformation :: Context -> IO (Maybe Information)
    contextGetInformation ctx = do
        ver    <- usingState_ ctx $ gets stVersion
        hstate <- getHState ctx
        let (ms, cr, sr) = case hstate of
                               Just st -> (hstMasterSecret st,
                                           Just (hstClientRandom st),
                                           hstServerRandom st)
                               Nothing -> (Nothing, Nothing, Nothing)
        (cipher,comp) <- failOnEitherError $ runRxState ctx $ gets $ \st -> (stCipher st, stCompression st)
        case (ver, cipher) of
            (Just v, Just c) -> return $ Just $ Information v c comp ms cr sr
            _                -> return Nothing

    contextSend :: Context -> Bytes -> IO ()
    contextSend c b = updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxConnection c) b

    contextRecv :: Context -> Int -> IO Bytes
    contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxConnection c) sz

    ctxEOF :: Context -> IO Bool
    ctxEOF ctx = readIORef $ ctxEOF_ ctx

    ctxHasSSLv2ClientHello :: Context -> IO Bool
    ctxHasSSLv2ClientHello ctx = readIORef $ ctxSSLv2ClientHello ctx

    ctxDisableSSLv2ClientHello :: Context -> IO ()
    ctxDisableSSLv2ClientHello ctx = writeIORef (ctxSSLv2ClientHello ctx) False

    setEOF :: Context -> IO ()
    setEOF ctx = writeIORef (ctxEOF_ ctx) True

    ctxEstablished :: Context -> IO Bool
    ctxEstablished ctx = readIORef $ ctxEstablished_ ctx

    ctxWithHooks :: Context -> (Hooks -> IO a) -> IO a
    ctxWithHooks ctx f = readIORef (ctxHooks ctx) >>= f

    contextModifyHooks :: Context -> (Hooks -> Hooks) -> IO ()
    contextModifyHooks ctx f = modifyIORef (ctxHooks ctx) f

    setEstablished :: Context -> Bool -> IO ()
    setEstablished ctx v = writeIORef (ctxEstablished_ ctx) v

    withLog :: Context -> (Logging -> IO ()) -> IO ()
    withLog ctx f = ctxWithHooks ctx (f . hookLogging)

    throwCore :: (MonadIO m, Exception e) => e -> m a
    throwCore = liftIO . throwIO

    failOnEitherError :: MonadIO m => m (Either TLSError a) -> m a
    failOnEitherError f = do
        ret <- f
        case ret of
            Left err -> throwCore err
            Right r  -> return r

    usingState :: Context -> TLSSt a -> IO (Either TLSError a)
    usingState ctx f =
        modifyMVar (ctxState ctx) $ \st ->
                let (a, newst) = runTLSState f st
                 in newst `seq` return (newst, a)

    usingState_ :: Context -> TLSSt a -> IO a
    usingState_ ctx f = failOnEitherError $ usingState ctx f

    usingHState :: Context -> HandshakeM a -> IO a
    usingHState ctx f = liftIO $ modifyMVar (ctxHandshake ctx) $ \mst ->
        case mst of
            Nothing -> throwCore $ Error_Misc "missing handshake"
            Just st -> return $ swap (Just `fmap` runHandshake st f)

    getHState :: Context -> IO (Maybe HandshakeState)
    getHState ctx = liftIO $ readMVar (ctxHandshake ctx)

    runTxState :: Context -> RecordM a -> IO (Either TLSError a)
    runTxState ctx f = do
        ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx)
        modifyMVar (ctxTxState ctx) $ \st ->
            case runRecordM f ver st of
                Left err         -> return (st, Left err)
                Right (a, newSt) -> return (newSt, Right a)

    runRxState :: Context -> RecordM a -> IO (Either TLSError a)
    runRxState ctx f = do
        ver <- usingState_ ctx getVersion
        modifyMVar (ctxRxState ctx) $ \st ->
            case runRecordM f ver st of
                Left err         -> return (st, Left err)
                Right (a, newSt) -> return (newSt, Right a)

    getStateRNG :: Context -> Int -> IO Bytes
    getStateRNG ctx n = usingState_ ctx $ genRandom n

    withReadLock :: Context -> IO a -> IO a
    withReadLock ctx f = withMVar (ctxLockRead ctx) (const f)

    withWriteLock :: Context -> IO a -> IO a
    withWriteLock ctx f = withMVar (ctxLockWrite ctx) (const f)

    withRWLock :: Context -> IO a -> IO a
    withRWLock ctx f = withReadLock ctx $ withWriteLock ctx f

    withStateLock :: Context -> IO a -> IO a
    withStateLock ctx f = withMVar (ctxLockState ctx) (const f)