2011-12-06 00:15:00 +00:00
-- |
-- Module : Network.TLS.Context
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
2013-12-11 07:50:35 +00:00
-- extension RecordWildCards only needed because of some GHC bug
-- relative to insufficient polymorphic field
2012-07-12 07:59:59 +00:00
{- # LANGUAGE RecordWildCards # -}
2011-12-06 00:15:00 +00:00
module Network.TLS.Context
2013-07-10 06:13:10 +00:00
(
-- * Context configuration
Params ( .. )
, RoleParams ( .. )
, ClientParams ( .. )
, ServerParams ( .. )
, updateClientParams
, updateServerParams
, Logging ( .. )
, SessionID
, SessionData ( .. )
, MaxFragmentEnum ( .. )
, Measurement ( .. )
, CertificateUsage ( .. )
, CertificateRejectReason ( .. )
, defaultLogging
, defaultParamsClient
, defaultParamsServer
, withSessionManager
, setSessionManager
, getClientParams
, getServerParams
-- * Context object and accessor
, Backend ( .. )
, Context
, Hooks ( .. )
, ctxParams
, ctxConnection
, ctxEOF
, ctxHasSSLv2ClientHello
, ctxDisableSSLv2ClientHello
, ctxEstablished
, ctxLogging
, ctxWithHooks
2013-07-30 07:58:58 +00:00
, ctxRxState
2013-08-01 07:05:03 +00:00
, ctxTxState
2013-08-01 07:47:40 +00:00
, ctxHandshake
2013-08-01 07:05:03 +00:00
, ctxNeedEmptyPacket
2013-07-10 06:13:10 +00:00
, setEOF
, setEstablished
, contextFlush
, contextClose
, contextSend
, contextRecv
, updateMeasure
, withMeasure
2013-07-11 08:06:10 +00:00
, withReadLock
, withWriteLock
, withStateLock
2013-09-01 06:36:08 +00:00
, withRWLock
2013-07-10 06:13:10 +00:00
-- * deprecated types
, TLSParams
, TLSLogging
, TLSCertificateUsage
, TLSCertificateRejectReason
, TLSCtx
-- * deprecated values
, defaultParams
-- * New contexts
, contextNew
, contextNewOnHandle
2013-10-11 07:01:38 +00:00
, contextNewOnSocket
2013-07-10 06:13:10 +00:00
-- * Context hooks
, contextHookSetHandshakeRecv
-- * Using context states
, throwCore
, usingState
, usingState_
2013-08-01 07:05:03 +00:00
, runTxState
2013-07-30 07:58:58 +00:00
, runRxState
2013-07-19 06:47:33 +00:00
, usingHState
2013-08-01 07:47:40 +00:00
, getHState
2013-07-10 06:13:10 +00:00
, getStateRNG
) where
2011-12-06 00:15:00 +00:00
2012-10-20 08:00:30 +00:00
import Network.BSD ( HostName )
2013-10-11 07:01:38 +00:00
import Network.Socket ( Socket , sClose )
import qualified Network.Socket.ByteString as Socket
2012-10-20 08:00:30 +00:00
import Network.TLS.Extension
2011-12-06 00:15:00 +00:00
import Network.TLS.Struct
2012-07-18 20:19:11 +00:00
import qualified Network.TLS.Struct as Struct
2012-07-12 07:59:59 +00:00
import Network.TLS.Session
2011-12-06 00:15:00 +00:00
import Network.TLS.Cipher
import Network.TLS.Compression
import Network.TLS.Crypto
import Network.TLS.State
2013-07-19 06:47:33 +00:00
import Network.TLS.Handshake.State
2013-12-11 07:55:24 +00:00
import Network.TLS.Hooks
2013-07-30 07:58:58 +00:00
import Network.TLS.Record.State
2011-12-06 00:15:00 +00:00
import Network.TLS.Measurement
2013-05-26 07:02:06 +00:00
import Network.TLS.X509
2013-07-21 09:16:01 +00:00
import Network.TLS.Types ( Role ( .. ) )
2011-12-06 00:15:00 +00:00
import Data.List ( intercalate )
2012-03-12 08:48:03 +00:00
import Data.ByteString ( ByteString )
2011-12-06 00:15:00 +00:00
import qualified Data.ByteString as B
2013-12-11 07:53:11 +00:00
import Crypto.Random
2012-03-15 08:16:48 +00:00
2011-12-06 00:15:00 +00:00
import Control.Concurrent.MVar
import Control.Monad.State
2012-03-10 19:39:55 +00:00
import Control.Exception ( throwIO , Exception ( ) )
2011-12-06 00:15:00 +00:00
import Data.IORef
2013-08-01 07:47:40 +00:00
import Data.Tuple
2012-03-28 07:08:33 +00:00
import System.IO ( Handle , hSetBuffering , BufferMode ( .. ) , hFlush , hClose )
2011-12-06 00:15:00 +00:00
2012-03-15 08:04:16 +00:00
data ClientParams = ClientParams
2013-07-10 06:13:10 +00:00
{ clientUseMaxFragmentLength :: Maybe MaxFragmentEnum
, clientUseServerName :: Maybe HostName
, clientWantSessionResume :: Maybe ( SessionID , SessionData ) -- ^ try to establish a connection using this session.
-- | This action is called when the server sends a
-- certificate request. The parameter is the information
-- from the request. The action should select a certificate
-- chain of one of the given certificate types where the
-- last certificate in the chain should be signed by one of
-- the given distinguished names. Each certificate should
-- be signed by the following one, except for the last. At
-- least the first of the certificates in the chain must
-- have a corresponding private key, because that is used
-- for signing the certificate verify message.
--
-- Note that is is the responsibility of this action to
-- select a certificate matching one of the requested
-- certificate types. Returning a non-matching one will
-- lead to handshake failure later.
--
-- Returning a certificate chain not matching the
-- distinguished names may lead to problems or not,
-- depending whether the server accepts it.
, onCertificateRequest :: ( [ CertificateType ] ,
Maybe [ HashAndSignatureAlgorithm ] ,
[ DistinguishedName ] ) -> IO ( Maybe ( CertificateChain , PrivKey ) )
, onNPNServerSuggest :: Maybe ( [ B . ByteString ] -> IO B . ByteString )
}
2012-07-12 08:02:10 +00:00
2012-03-15 08:04:16 +00:00
data ServerParams = ServerParams
2013-07-10 06:13:10 +00:00
{ serverWantClientCert :: Bool -- ^ request a certificate from client.
-- | This is a list of certificates from which the
-- disinguished names are sent in certificate request
-- messages. For TLS1.0, it should not be empty.
, serverCACertificates :: [ SignedCertificate ]
-- | This action is called when a client certificate chain
-- is received from the client. When it returns a
-- CertificateUsageReject value, the handshake is aborted.
, onClientCertificate :: CertificateChain -> IO CertificateUsage
-- | This action is called when the client certificate
-- cannot be verified. A 'Nothing' argument indicates a
-- wrong signature, a 'Just e' message signals a crypto
-- error.
, onUnverifiedClientCert :: IO Bool
-- | Allow the server to choose the cipher relative to the
-- the client version and the client list of ciphers.
--
-- This could be useful with old clients and as a workaround
-- to the BEAST (where RC4 is sometimes prefered with TLS < 1.1)
--
-- The client cipher list cannot be empty.
, onCipherChoosing :: Version -> [ Cipher ] -> Cipher
-- | suggested next protocols accoring to the next protocol negotiation extension.
, onSuggestNextProtocols :: IO ( Maybe [ B . ByteString ] )
}
2012-03-15 08:04:16 +00:00
data RoleParams = Client ClientParams | Server ServerParams
2013-05-15 05:41:47 +00:00
data Params = Params
2013-07-10 06:13:10 +00:00
{ pConnectVersion :: Version -- ^ version to use on client connection.
, pAllowedVersions :: [ Version ] -- ^ allowed versions that we can use.
, pCiphers :: [ Cipher ] -- ^ all ciphers supported ordered by priority.
, pCompressions :: [ Compression ] -- ^ all compression supported ordered by priority.
, pHashSignatures :: [ HashAndSignatureAlgorithm ] -- ^ All supported hash/signature algorithms pair for client certificate verification, ordered by decreasing priority.
, pUseSecureRenegotiation :: Bool -- ^ notify that we want to use secure renegotation
, pUseSession :: Bool -- ^ generate new session if specified
, pCertificates :: Maybe ( CertificateChain , Maybe PrivKey ) -- ^ the cert chain for this context with the associated keys if any.
, pLogging :: Logging -- ^ callback for logging
, onHandshake :: Measurement -> IO Bool -- ^ callback on a beggining of handshake
, onCertificatesRecv :: CertificateChain -> IO CertificateUsage -- ^ callback to verify received cert chain.
, pSessionManager :: SessionManager
, roleParams :: RoleParams
}
2011-12-06 00:15:00 +00:00
2012-07-12 07:59:59 +00:00
-- | Set a new session manager in a parameters structure.
2013-05-15 05:41:47 +00:00
setSessionManager :: SessionManager -> Params -> Params
2012-07-12 07:59:59 +00:00
setSessionManager manager ( Params { .. } ) = Params { pSessionManager = manager , .. }
2013-05-15 05:41:47 +00:00
withSessionManager :: Params -> ( SessionManager -> a ) -> a
2012-07-12 07:59:59 +00:00
withSessionManager ( Params { pSessionManager = man } ) f = f man
2012-03-14 08:56:28 +00:00
defaultLogging :: Logging
2013-06-03 07:37:56 +00:00
getClientParams :: Params -> ClientParams
getClientParams params =
case roleParams params of
Client clientParams -> clientParams
_ -> error " server params in client context "
getServerParams :: Params -> ServerParams
getServerParams params =
case roleParams params of
Server serverParams -> serverParams
_ -> error " client params in server context "
2012-03-15 08:04:16 +00:00
defaultParamsClient :: Params
defaultParamsClient = Params
2013-07-10 06:13:10 +00:00
{ pConnectVersion = TLS10
, pAllowedVersions = [ TLS10 , TLS11 , TLS12 ]
, pCiphers = []
, pCompressions = [ nullCompression ]
, pHashSignatures = [ ( Struct . HashSHA512 , SignatureRSA )
, ( Struct . HashSHA384 , SignatureRSA )
, ( Struct . HashSHA256 , SignatureRSA )
, ( Struct . HashSHA224 , SignatureRSA )
]
, pUseSecureRenegotiation = True
, pUseSession = True
, pCertificates = Nothing
, pLogging = defaultLogging
, onHandshake = ( \ _ -> return True )
, onCertificatesRecv = ( \ _ -> return CertificateUsageAccept )
, pSessionManager = noSessionManager
, roleParams = Client $ ClientParams
{ clientWantSessionResume = Nothing
, clientUseMaxFragmentLength = Nothing
, clientUseServerName = Nothing
, onCertificateRequest = \ _ -> return Nothing
, onNPNServerSuggest = Nothing
}
}
2011-12-06 00:15:00 +00:00
2012-03-15 08:04:16 +00:00
defaultParamsServer :: Params
2012-08-05 06:15:32 +00:00
defaultParamsServer = defaultParamsClient { roleParams = Server role }
2013-07-10 06:13:10 +00:00
where role = ServerParams
2012-08-05 06:12:07 +00:00
{ serverWantClientCert = False
, onCipherChoosing = \ _ -> head
, serverCACertificates = []
, onClientCertificate = \ _ -> return $ CertificateUsageReject $ CertificateRejectOther " no client certificates expected "
2012-12-30 15:31:13 +00:00
, onUnverifiedClientCert = return False
2013-06-03 07:37:56 +00:00
, onSuggestNextProtocols = return Nothing
2012-08-05 06:12:07 +00:00
}
2012-03-15 08:04:16 +00:00
2012-07-12 07:54:34 +00:00
updateRoleParams :: ( ClientParams -> ClientParams ) -> ( ServerParams -> ServerParams ) -> Params -> Params
updateRoleParams fc fs params = case roleParams params of
Client c -> params { roleParams = Client ( fc c ) }
Server s -> params { roleParams = Server ( fs s ) }
updateClientParams :: ( ClientParams -> ClientParams ) -> Params -> Params
updateClientParams f = updateRoleParams f id
updateServerParams :: ( ServerParams -> ServerParams ) -> Params -> Params
updateServerParams f = updateRoleParams id f
2012-03-15 08:04:16 +00:00
defaultParams :: Params
defaultParams = defaultParamsClient
{- # DEPRECATED defaultParams "use defaultParamsClient" # -}
2012-03-14 08:56:28 +00:00
instance Show Params where
2013-07-10 06:13:10 +00:00
show p = " Params { " ++ ( intercalate " , " $ map ( \ ( k , v ) -> k ++ " = " ++ v )
[ ( " connectVersion " , show $ pConnectVersion p )
, ( " allowedVersions " , show $ pAllowedVersions p )
, ( " ciphers " , show $ pCiphers p )
, ( " compressions " , show $ pCompressions p )
, ( " certificates " , show $ pCertificates p )
] ) ++ " } "
2011-12-06 00:15:00 +00:00
2012-07-12 08:02:38 +00:00
-- | Connection IO backend
2012-03-14 08:56:28 +00:00
data Backend = Backend
2013-07-10 06:13:10 +00:00
{ backendFlush :: IO () -- ^ Flush the connection sending buffer, if any.
, backendClose :: IO () -- ^ Close the connection.
, backendSend :: ByteString -> IO () -- ^ Send a bytestring through the connection.
, backendRecv :: Int -> IO ByteString -- ^ Receive specified number of bytes from the connection.
}
2012-03-12 08:48:03 +00:00
2013-07-09 08:13:17 +00:00
2012-03-12 08:48:03 +00:00
-- | A TLS Context keep tls specific state, parameters and backend information.
2012-03-14 08:56:28 +00:00
data Context = Context
2013-07-10 06:13:10 +00:00
{ ctxConnection :: Backend -- ^ return the backend object associated with this context
, ctxParams :: Params
, 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.
2013-08-01 07:05:03 +00:00
, ctxNeedEmptyPacket :: IORef Bool -- ^ empty packet workaround for CBC guessability.
2013-07-10 06:13:10 +00:00
, 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.
2013-08-01 07:05:03 +00:00
, ctxTxState :: MVar RecordState -- ^ current tx state
2013-07-30 07:58:58 +00:00
, ctxRxState :: MVar RecordState -- ^ current rx state
2013-08-01 07:47:40 +00:00
, ctxHandshake :: MVar ( Maybe HandshakeState ) -- ^ optional handshake state
2013-07-10 06:13:10 +00:00
, ctxHooks :: IORef Hooks -- ^ hooks for this context
2013-07-11 08:06:10 +00:00
, 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.
2013-07-10 06:13:10 +00:00
}
2011-12-06 00:15:00 +00:00
2012-03-14 08:56:28 +00:00
-- deprecated types, setup as aliases for compatibility.
type TLSParams = Params
type TLSCtx = Context
type TLSLogging = Logging
type TLSCertificateUsage = CertificateUsage
type TLSCertificateRejectReason = CertificateRejectReason
2013-08-01 07:52:42 +00:00
updateMeasure :: Context -> ( Measurement -> Measurement ) -> IO ()
updateMeasure ctx f = do
2012-03-10 16:40:59 +00:00
x <- readIORef ( ctxMeasurement ctx )
writeIORef ( ctxMeasurement ctx ) $! f x
2011-12-06 00:15:00 +00:00
2013-08-01 07:52:42 +00:00
withMeasure :: Context -> ( Measurement -> IO a ) -> IO a
withMeasure ctx f = readIORef ( ctxMeasurement ctx ) >>= f
2011-12-06 00:15:00 +00:00
2012-03-31 22:15:23 +00:00
contextFlush :: Context -> IO ()
contextFlush = backendFlush . ctxConnection
2011-12-06 00:15:00 +00:00
2012-03-31 22:15:23 +00:00
contextClose :: Context -> IO ()
contextClose = backendClose . ctxConnection
2012-03-28 07:08:33 +00:00
2012-03-31 22:15:23 +00:00
contextSend :: Context -> Bytes -> IO ()
contextSend c b = updateMeasure c ( addBytesSent $ B . length b ) >> ( backendSend $ ctxConnection c ) b
2011-12-06 00:15:00 +00:00
2012-03-31 22:15:23 +00:00
contextRecv :: Context -> Int -> IO Bytes
contextRecv c sz = updateMeasure c ( addBytesReceived sz ) >> ( backendRecv $ ctxConnection c ) sz
2011-12-06 00:15:00 +00:00
2013-08-01 07:52:42 +00:00
ctxEOF :: Context -> IO Bool
ctxEOF ctx = readIORef $ ctxEOF_ ctx
2011-12-06 00:15:00 +00:00
2013-08-01 07:52:42 +00:00
ctxHasSSLv2ClientHello :: Context -> IO Bool
ctxHasSSLv2ClientHello ctx = readIORef $ ctxSSLv2ClientHello ctx
2012-12-04 08:31:22 +00:00
2013-08-01 07:52:42 +00:00
ctxDisableSSLv2ClientHello :: Context -> IO ()
ctxDisableSSLv2ClientHello ctx = writeIORef ( ctxSSLv2ClientHello ctx ) False
2012-12-04 08:31:22 +00:00
2013-08-01 07:52:42 +00:00
setEOF :: Context -> IO ()
setEOF ctx = writeIORef ( ctxEOF_ ctx ) True
2011-12-06 00:15:00 +00:00
2013-08-01 07:52:42 +00:00
ctxEstablished :: Context -> IO Bool
ctxEstablished ctx = readIORef $ ctxEstablished_ ctx
2012-01-25 16:01:55 +00:00
2013-08-01 07:52:42 +00:00
ctxWithHooks :: Context -> ( Hooks -> IO a ) -> IO a
ctxWithHooks ctx f = readIORef ( ctxHooks ctx ) >>= f
2013-07-09 08:13:17 +00:00
2013-08-01 07:52:42 +00:00
setEstablished :: Context -> Bool -> IO ()
setEstablished ctx v = writeIORef ( ctxEstablished_ ctx ) v
2012-01-25 16:01:55 +00:00
2012-03-14 08:56:28 +00:00
ctxLogging :: Context -> Logging
2011-12-06 00:15:00 +00:00
ctxLogging = pLogging . ctxParams
2012-03-15 08:16:48 +00:00
-- | create a new context using the backend and parameters specified.
2012-12-05 07:47:17 +00:00
contextNew :: ( MonadIO m , CPRG rng )
2012-12-31 14:43:15 +00:00
=> Backend -- ^ Backend abstraction with specific method to interact with the connection type.
2012-03-15 08:16:48 +00:00
-> Params -- ^ Parameters of the context.
-> rng -- ^ Random number generator associated with this context.
-> m Context
contextNew backend params rng = liftIO $ do
2013-07-21 09:16:01 +00:00
let role = case roleParams params of
Client { } -> ClientRole
Server { } -> ServerRole
let st = newTLSState rng role
2013-07-10 06:13:10 +00:00
stvar <- newMVar st
eof <- newIORef False
established <- newIORef False
stats <- newIORef newMeasurement
-- we enable the reception of SSLv2 ClientHello message only in the
-- server context, where we might be dealing with an old/compat client.
2013-07-21 09:16:01 +00:00
sslv2Compat <- newIORef ( role == ServerRole )
2013-08-01 07:05:03 +00:00
needEmptyPacket <- newIORef False
2013-07-10 06:13:10 +00:00
hooks <- newIORef defaultHooks
2013-08-01 07:05:03 +00:00
tx <- newMVar newRecordState
2013-07-30 07:58:58 +00:00
rx <- newMVar newRecordState
2013-08-01 07:47:40 +00:00
hs <- newMVar Nothing
2013-07-11 08:06:10 +00:00
lockWrite <- newMVar ()
lockRead <- newMVar ()
lockState <- newMVar ()
2013-07-10 06:13:10 +00:00
return $ Context
{ ctxConnection = backend
, ctxParams = params
, ctxState = stvar
2013-08-01 07:05:03 +00:00
, ctxTxState = tx
2013-07-30 07:58:58 +00:00
, ctxRxState = rx
2013-08-01 07:47:40 +00:00
, ctxHandshake = hs
2013-07-10 06:13:10 +00:00
, ctxMeasurement = stats
, ctxEOF_ = eof
, ctxEstablished_ = established
, ctxSSLv2ClientHello = sslv2Compat
2013-08-01 07:05:03 +00:00
, ctxNeedEmptyPacket = needEmptyPacket
2013-07-10 06:13:10 +00:00
, ctxHooks = hooks
2013-07-11 08:06:10 +00:00
, ctxLockWrite = lockWrite
, ctxLockRead = lockRead
, ctxLockState = lockState
2013-07-10 06:13:10 +00:00
}
2011-12-06 00:15:00 +00:00
2012-03-15 08:16:48 +00:00
-- | create a new context on an handle.
2012-12-05 07:47:17 +00:00
contextNewOnHandle :: ( MonadIO m , CPRG rng )
2012-03-15 08:16:48 +00:00
=> Handle -- ^ Handle of the connection.
-> Params -- ^ Parameters of the context.
-> rng -- ^ Random number generator associated with this context.
-> m Context
2012-03-15 07:55:38 +00:00
contextNewOnHandle handle params st =
2013-07-10 06:13:10 +00:00
liftIO ( hSetBuffering handle NoBuffering ) >> contextNew backend params st
where backend = Backend ( hFlush handle ) ( hClose handle ) ( B . hPut handle ) ( B . hGet handle )
2011-12-06 00:15:00 +00:00
2013-10-11 07:01:38 +00:00
-- | create a new context on a socket.
contextNewOnSocket :: ( MonadIO m , CPRG rng )
=> Socket -- ^ Socket of the connection.
-> Params -- ^ Parameters of the context.
-> rng -- ^ Random number generator associated with this context.
-> m Context
contextNewOnSocket sock params st = contextNew backend params st
where backend = Backend ( return () ) ( sClose sock ) ( Socket . sendAll sock ) recvAll
recvAll n = B . concat ` fmap ` loop n
where loop 0 = return []
loop left = do
r <- Socket . recv sock left
liftM ( r : ) ( loop ( left - B . length r ) )
2013-08-01 07:52:42 +00:00
contextHookSetHandshakeRecv :: Context -> ( Handshake -> IO Handshake ) -> IO ()
2013-07-09 08:13:17 +00:00
contextHookSetHandshakeRecv context f =
liftIO $ modifyIORef ( ctxHooks context ) ( \ hooks -> hooks { hookRecvHandshake = f } )
2011-12-06 00:15:00 +00:00
throwCore :: ( MonadIO m , Exception e ) => e -> m a
throwCore = liftIO . throwIO
2013-08-01 07:52:42 +00:00
usingState :: Context -> TLSSt a -> IO ( Either TLSError a )
2012-03-10 19:39:55 +00:00
usingState ctx f =
2013-08-01 07:52:42 +00:00
modifyMVar ( ctxState ctx ) $ \ st ->
2013-07-10 06:13:10 +00:00
let ( a , newst ) = runTLSState f st
in newst ` seq ` return ( newst , a )
2011-12-06 00:15:00 +00:00
2013-08-01 07:52:42 +00:00
usingState_ :: Context -> TLSSt a -> IO a
2011-12-06 00:15:00 +00:00
usingState_ ctx f = do
2013-07-10 06:13:10 +00:00
ret <- usingState ctx f
case ret of
Left err -> throwCore err
Right r -> return r
2011-12-06 00:15:00 +00:00
2013-08-01 07:52:42 +00:00
usingHState :: Context -> HandshakeM a -> IO a
2013-08-01 07:47:40 +00:00
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 )
2013-08-01 07:52:42 +00:00
getHState :: Context -> IO ( Maybe HandshakeState )
2013-08-01 07:47:40 +00:00
getHState ctx = liftIO $ readMVar ( ctxHandshake ctx )
2013-07-19 06:47:33 +00:00
2013-08-01 07:52:42 +00:00
runTxState :: Context -> RecordM a -> IO ( Either TLSError a )
2013-08-01 07:05:03 +00:00
runTxState ctx f = do
ver <- usingState_ ctx getVersion
2013-08-01 07:52:42 +00:00
modifyMVar ( ctxTxState ctx ) $ \ st ->
2013-08-01 07:05:03 +00:00
case runRecordM f ver st of
Left err -> return ( st , Left err )
Right ( a , newSt ) -> return ( newSt , Right a )
2013-08-01 07:52:42 +00:00
runRxState :: Context -> RecordM a -> IO ( Either TLSError a )
2013-07-30 07:58:58 +00:00
runRxState ctx f = do
ver <- usingState_ ctx getVersion
2013-08-01 07:52:42 +00:00
modifyMVar ( ctxRxState ctx ) $ \ st ->
2013-07-30 07:58:58 +00:00
case runRecordM f ver st of
Left err -> return ( st , Left err )
Right ( a , newSt ) -> return ( newSt , Right a )
2013-08-01 07:52:42 +00:00
getStateRNG :: Context -> Int -> IO Bytes
2013-07-13 07:03:25 +00:00
getStateRNG ctx n = usingState_ ctx $ genRandom n
2013-07-11 08:06:10 +00:00
2013-08-01 07:52:42 +00:00
withReadLock :: Context -> IO a -> IO a
withReadLock ctx f = withMVar ( ctxLockRead ctx ) ( const f )
2013-07-11 08:06:10 +00:00
2013-08-01 07:52:42 +00:00
withWriteLock :: Context -> IO a -> IO a
withWriteLock ctx f = withMVar ( ctxLockWrite ctx ) ( const f )
2013-07-11 08:06:10 +00:00
2013-09-01 06:36:08 +00:00
withRWLock :: Context -> IO a -> IO a
withRWLock ctx f = withReadLock ctx $ withWriteLock ctx f
2013-08-01 07:52:42 +00:00
withStateLock :: Context -> IO a -> IO a
withStateLock ctx f = withMVar ( ctxLockState ctx ) ( const f )