remove unnecessary MonadIO parametrization
This commit is contained in:
Vincent Hanquez
parent
be34ed350e
commit
5836669878
10 changed files with 87 additions and 90 deletions
|
|
@ -339,13 +339,13 @@ type TLSLogging = Logging
|
|||
type TLSCertificateUsage = CertificateUsage
|
||||
type TLSCertificateRejectReason = CertificateRejectReason
|
||||
|
||||
updateMeasure :: MonadIO m => Context -> (Measurement -> Measurement) -> m ()
|
||||
updateMeasure ctx f = liftIO $ do
|
||||
updateMeasure :: Context -> (Measurement -> Measurement) -> IO ()
|
||||
updateMeasure ctx f = do
|
||||
x <- readIORef (ctxMeasurement ctx)
|
||||
writeIORef (ctxMeasurement ctx) $! f x
|
||||
|
||||
withMeasure :: MonadIO m => Context -> (Measurement -> IO a) -> m a
|
||||
withMeasure ctx f = liftIO (readIORef (ctxMeasurement ctx) >>= f)
|
||||
withMeasure :: Context -> (Measurement -> IO a) -> IO a
|
||||
withMeasure ctx f = readIORef (ctxMeasurement ctx) >>= f
|
||||
|
||||
contextFlush :: Context -> IO ()
|
||||
contextFlush = backendFlush . ctxConnection
|
||||
|
|
@ -359,26 +359,26 @@ contextSend c b = updateMeasure c (addBytesSent $ B.length b) >> (backendSend $
|
|||
contextRecv :: Context -> Int -> IO Bytes
|
||||
contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxConnection c) sz
|
||||
|
||||
ctxEOF :: MonadIO m => Context -> m Bool
|
||||
ctxEOF ctx = liftIO (readIORef $ ctxEOF_ ctx)
|
||||
ctxEOF :: Context -> IO Bool
|
||||
ctxEOF ctx = readIORef $ ctxEOF_ ctx
|
||||
|
||||
ctxHasSSLv2ClientHello :: MonadIO m => Context -> m Bool
|
||||
ctxHasSSLv2ClientHello ctx = liftIO (readIORef $ ctxSSLv2ClientHello ctx)
|
||||
ctxHasSSLv2ClientHello :: Context -> IO Bool
|
||||
ctxHasSSLv2ClientHello ctx = readIORef $ ctxSSLv2ClientHello ctx
|
||||
|
||||
ctxDisableSSLv2ClientHello :: MonadIO m => Context -> m ()
|
||||
ctxDisableSSLv2ClientHello ctx = liftIO (writeIORef (ctxSSLv2ClientHello ctx) False)
|
||||
ctxDisableSSLv2ClientHello :: Context -> IO ()
|
||||
ctxDisableSSLv2ClientHello ctx = writeIORef (ctxSSLv2ClientHello ctx) False
|
||||
|
||||
setEOF :: MonadIO m => Context -> m ()
|
||||
setEOF ctx = liftIO $ writeIORef (ctxEOF_ ctx) True
|
||||
setEOF :: Context -> IO ()
|
||||
setEOF ctx = writeIORef (ctxEOF_ ctx) True
|
||||
|
||||
ctxEstablished :: MonadIO m => Context -> m Bool
|
||||
ctxEstablished ctx = liftIO $ readIORef $ ctxEstablished_ ctx
|
||||
ctxEstablished :: Context -> IO Bool
|
||||
ctxEstablished ctx = readIORef $ ctxEstablished_ ctx
|
||||
|
||||
ctxWithHooks :: MonadIO m => Context -> (Hooks -> m a) -> m a
|
||||
ctxWithHooks ctx f = liftIO (readIORef $ ctxHooks ctx) >>= f
|
||||
ctxWithHooks :: Context -> (Hooks -> IO a) -> IO a
|
||||
ctxWithHooks ctx f = readIORef (ctxHooks ctx) >>= f
|
||||
|
||||
setEstablished :: MonadIO m => Context -> Bool -> m ()
|
||||
setEstablished ctx v = liftIO $ writeIORef (ctxEstablished_ ctx) v
|
||||
setEstablished :: Context -> Bool -> IO ()
|
||||
setEstablished ctx v = writeIORef (ctxEstablished_ ctx) v
|
||||
|
||||
ctxLogging :: Context -> Logging
|
||||
ctxLogging = pLogging . ctxParams
|
||||
|
|
@ -438,59 +438,59 @@ contextNewOnHandle handle params st =
|
|||
liftIO (hSetBuffering handle NoBuffering) >> contextNew backend params st
|
||||
where backend = Backend (hFlush handle) (hClose handle) (B.hPut handle) (B.hGet handle)
|
||||
|
||||
contextHookSetHandshakeRecv :: MonadIO m => Context -> (Handshake -> IO Handshake) -> m ()
|
||||
contextHookSetHandshakeRecv :: Context -> (Handshake -> IO Handshake) -> IO ()
|
||||
contextHookSetHandshakeRecv context f =
|
||||
liftIO $ modifyIORef (ctxHooks context) (\hooks -> hooks { hookRecvHandshake = f })
|
||||
|
||||
throwCore :: (MonadIO m, Exception e) => e -> m a
|
||||
throwCore = liftIO . throwIO
|
||||
|
||||
usingState :: MonadIO m => Context -> TLSSt a -> m (Either TLSError a)
|
||||
usingState :: Context -> TLSSt a -> IO (Either TLSError a)
|
||||
usingState ctx f =
|
||||
liftIO $ modifyMVar (ctxState ctx) $ \st ->
|
||||
modifyMVar (ctxState ctx) $ \st ->
|
||||
let (a, newst) = runTLSState f st
|
||||
in newst `seq` return (newst, a)
|
||||
|
||||
usingState_ :: MonadIO m => Context -> TLSSt a -> m a
|
||||
usingState_ :: Context -> TLSSt a -> IO a
|
||||
usingState_ ctx f = do
|
||||
ret <- usingState ctx f
|
||||
case ret of
|
||||
Left err -> throwCore err
|
||||
Right r -> return r
|
||||
|
||||
usingHState :: MonadIO m => Context -> HandshakeM a -> m a
|
||||
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 :: MonadIO m => Context -> m (Maybe HandshakeState)
|
||||
getHState :: Context -> IO (Maybe HandshakeState)
|
||||
getHState ctx = liftIO $ readMVar (ctxHandshake ctx)
|
||||
|
||||
runTxState :: MonadIO m => Context -> RecordM a -> m (Either TLSError a)
|
||||
runTxState :: Context -> RecordM a -> IO (Either TLSError a)
|
||||
runTxState ctx f = do
|
||||
ver <- usingState_ ctx getVersion
|
||||
liftIO $ modifyMVar (ctxTxState ctx) $ \st ->
|
||||
modifyMVar (ctxTxState ctx) $ \st ->
|
||||
case runRecordM f ver st of
|
||||
Left err -> return (st, Left err)
|
||||
Right (a, newSt) -> return (newSt, Right a)
|
||||
|
||||
runRxState :: MonadIO m => Context -> RecordM a -> m (Either TLSError a)
|
||||
runRxState :: Context -> RecordM a -> IO (Either TLSError a)
|
||||
runRxState ctx f = do
|
||||
ver <- usingState_ ctx getVersion
|
||||
liftIO $ modifyMVar (ctxRxState ctx) $ \st ->
|
||||
modifyMVar (ctxRxState ctx) $ \st ->
|
||||
case runRecordM f ver st of
|
||||
Left err -> return (st, Left err)
|
||||
Right (a, newSt) -> return (newSt, Right a)
|
||||
|
||||
getStateRNG :: MonadIO m => Context -> Int -> m Bytes
|
||||
getStateRNG :: Context -> Int -> IO Bytes
|
||||
getStateRNG ctx n = usingState_ ctx $ genRandom n
|
||||
|
||||
withReadLock :: MonadIO m => Context -> IO a -> m a
|
||||
withReadLock ctx f = liftIO $ withMVar (ctxLockRead ctx) (const f)
|
||||
withReadLock :: Context -> IO a -> IO a
|
||||
withReadLock ctx f = withMVar (ctxLockRead ctx) (const f)
|
||||
|
||||
withWriteLock :: MonadIO m => Context -> IO a -> m a
|
||||
withWriteLock ctx f = liftIO $ withMVar (ctxLockWrite ctx) (const f)
|
||||
withWriteLock :: Context -> IO a -> IO a
|
||||
withWriteLock ctx f = withMVar (ctxLockWrite ctx) (const f)
|
||||
|
||||
withStateLock :: MonadIO m => Context -> IO a -> m a
|
||||
withStateLock ctx f = liftIO $ withMVar (ctxLockState ctx) (const f)
|
||||
withStateLock :: Context -> IO a -> IO a
|
||||
withStateLock ctx f = withMVar (ctxLockState ctx) (const f)
|
||||
|
|
|
|||
|
|
@ -61,12 +61,12 @@ bye ctx = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)]
|
|||
-- | If the Next Protocol Negotiation extension has been used, this will
|
||||
-- return get the protocol agreed upon.
|
||||
getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString)
|
||||
getNegotiatedProtocol ctx = usingState_ ctx S.getNegotiatedProtocol
|
||||
getNegotiatedProtocol ctx = liftIO $ usingState_ ctx S.getNegotiatedProtocol
|
||||
|
||||
-- | sendData sends a bunch of data.
|
||||
-- It will automatically chunk data to acceptable packet size
|
||||
sendData :: MonadIO m => Context -> L.ByteString -> m ()
|
||||
sendData ctx dataToSend = checkValid ctx >> mapM_ sendDataChunk (L.toChunks dataToSend)
|
||||
sendData ctx dataToSend = liftIO (checkValid ctx) >> mapM_ sendDataChunk (L.toChunks dataToSend)
|
||||
where sendDataChunk d
|
||||
| B.length d > 16384 = do
|
||||
let (sending, remain) = B.splitAt 16384 d
|
||||
|
|
@ -77,7 +77,7 @@ sendData ctx dataToSend = checkValid ctx >> mapM_ sendDataChunk (L.toChunks data
|
|||
-- | recvData get data out of Data packet, and automatically renegotiate if
|
||||
-- a Handshake ClientHello is received
|
||||
recvData :: MonadIO m => Context -> m B.ByteString
|
||||
recvData ctx = checkValid ctx >> recvPacket ctx >>= either onError process
|
||||
recvData ctx = liftIO (checkValid ctx) >> recvPacket ctx >>= liftIO . either onError process
|
||||
where onError err@(Error_Protocol (reason,fatal,desc)) =
|
||||
terminate err (if fatal then AlertLevel_Fatal else AlertLevel_Warning) desc reason
|
||||
onError err =
|
||||
|
|
@ -107,19 +107,19 @@ recvData ctx = checkValid ctx >> recvPacket ctx >>= either onError process
|
|||
process p = let reason = "unexpected message " ++ show p in
|
||||
terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
|
||||
|
||||
terminate :: MonadIO m => TLSError -> AlertLevel -> AlertDescription -> String -> m a
|
||||
terminate :: TLSError -> AlertLevel -> AlertDescription -> String -> IO a
|
||||
terminate err level desc reason = do
|
||||
session <- usingState_ ctx getSession
|
||||
case session of
|
||||
Session Nothing -> return ()
|
||||
Session (Just sid) -> withSessionManager (ctxParams ctx) (\s -> liftIO $ sessionInvalidate s sid)
|
||||
liftIO $ E.catch (sendPacket ctx $ Alert [(level, desc)]) (\(_ :: E.SomeException) -> return ())
|
||||
Session (Just sid) -> withSessionManager (ctxParams ctx) (\s -> sessionInvalidate s sid)
|
||||
E.catch (sendPacket ctx $ Alert [(level, desc)]) (\(_ :: E.SomeException) -> return ())
|
||||
setEOF ctx
|
||||
liftIO $ E.throwIO (Terminated False reason err)
|
||||
E.throwIO (Terminated False reason err)
|
||||
|
||||
-- the other side could have close the connection already, so wrap
|
||||
-- this in a try and ignore all exceptions
|
||||
tryBye = liftIO $ E.catch (bye ctx) (\(_ :: E.SomeException) -> return ())
|
||||
tryBye = E.catch (bye ctx) (\(_ :: E.SomeException) -> return ())
|
||||
|
||||
{-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-}
|
||||
-- | same as recvData but returns a lazy bytestring.
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ import Network.TLS.Handshake.State
|
|||
|
||||
-- client part of handshake. send a bunch of handshake of client
|
||||
-- values intertwined with response from the server.
|
||||
handshakeClient :: MonadIO m => ClientParams -> Context -> m ()
|
||||
handshakeClient :: ClientParams -> Context -> IO ()
|
||||
handshakeClient cparams ctx = do
|
||||
updateMeasure ctx incrementNbHandshakes
|
||||
sentExtensions <- sendClientHello
|
||||
|
|
@ -90,7 +90,7 @@ handshakeClient cparams ctx = do
|
|||
-- -> [certificate]
|
||||
-- -> client key exchange
|
||||
-- -> [cert verify]
|
||||
sendClientData :: MonadIO m => ClientParams -> Context -> m ()
|
||||
sendClientData :: ClientParams -> Context -> IO ()
|
||||
sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertificateVerify
|
||||
where
|
||||
-- When the server requests a client certificate, we
|
||||
|
|
@ -199,7 +199,7 @@ processServerExtension (0xff01, content) = do
|
|||
return ()
|
||||
processServerExtension _ = return ()
|
||||
|
||||
throwMiscErrorOnException :: MonadIO m => String -> SomeException -> m a
|
||||
throwMiscErrorOnException :: String -> SomeException -> IO a
|
||||
throwMiscErrorOnException msg e =
|
||||
throwCore $ Error_Misc $ msg ++ ": " ++ show e
|
||||
|
||||
|
|
@ -212,7 +212,7 @@ throwMiscErrorOnException msg e =
|
|||
-- 5) process NPN extension
|
||||
-- 6) if no resume switch to processCertificate SM or in resume switch to expectChangeCipher
|
||||
--
|
||||
onServerHello :: MonadIO m => Context -> ClientParams -> [ExtensionID] -> Handshake -> m (RecvState m)
|
||||
onServerHello :: Context -> ClientParams -> [ExtensionID] -> Handshake -> IO (RecvState IO)
|
||||
onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do
|
||||
when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)
|
||||
case find ((==) rver) allowedvers of
|
||||
|
|
@ -257,7 +257,7 @@ onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cip
|
|||
compressions = pCompressions params
|
||||
onServerHello _ _ _ p = unexpected (show p) (Just "server hello")
|
||||
|
||||
processCertificate :: MonadIO m => Context -> Handshake -> m (RecvState m)
|
||||
processCertificate :: Context -> Handshake -> IO (RecvState IO)
|
||||
processCertificate ctx (Certificates certs) = do
|
||||
usage <- liftIO $ E.catch (onCertificatesRecv params certs) rejectOnException
|
||||
case usage of
|
||||
|
|
@ -267,19 +267,19 @@ processCertificate ctx (Certificates certs) = do
|
|||
where params = ctxParams ctx
|
||||
processCertificate ctx p = processServerKeyExchange ctx p
|
||||
|
||||
expectChangeCipher :: MonadIO m => Packet -> m (RecvState m)
|
||||
expectChangeCipher :: Packet -> IO (RecvState IO)
|
||||
expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish
|
||||
expectChangeCipher p = unexpected (show p) (Just "change cipher")
|
||||
|
||||
expectFinish :: MonadIO m => Handshake -> m (RecvState m)
|
||||
expectFinish :: Handshake -> IO (RecvState IO)
|
||||
expectFinish (Finished _) = return RecvStateDone
|
||||
expectFinish p = unexpected (show p) (Just "Handshake Finished")
|
||||
|
||||
processServerKeyExchange :: MonadIO m => Context -> Handshake -> m (RecvState m)
|
||||
processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)
|
||||
processServerKeyExchange ctx (ServerKeyXchg _) = return $ RecvStateHandshake (processCertificateRequest ctx)
|
||||
processServerKeyExchange ctx p = processCertificateRequest ctx p
|
||||
|
||||
processCertificateRequest :: MonadIO m => Context -> Handshake -> m (RecvState m)
|
||||
processCertificateRequest :: Context -> Handshake -> IO (RecvState IO)
|
||||
processCertificateRequest ctx (CertRequest cTypes sigAlgs dNames) = do
|
||||
-- When the server requests a client
|
||||
-- certificate, we simply store the
|
||||
|
|
@ -289,6 +289,6 @@ processCertificateRequest ctx (CertRequest cTypes sigAlgs dNames) = do
|
|||
return $ RecvStateHandshake (processServerHelloDone ctx)
|
||||
processCertificateRequest ctx p = processServerHelloDone ctx p
|
||||
|
||||
processServerHelloDone :: MonadIO m => Context -> Handshake -> m (RecvState m)
|
||||
processServerHelloDone :: Context -> Handshake -> IO (RecvState m)
|
||||
processServerHelloDone _ ServerHelloDone = return RecvStateDone
|
||||
processServerHelloDone _ p = unexpected (show p) (Just "server hello data")
|
||||
|
|
|
|||
|
|
@ -47,16 +47,16 @@ errorToAlert :: TLSError -> Packet
|
|||
errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)]
|
||||
errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)]
|
||||
|
||||
unexpected :: MonadIO m => String -> Maybe [Char] -> m a
|
||||
unexpected :: String -> Maybe [Char] -> IO a
|
||||
unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected)
|
||||
|
||||
newSession :: MonadIO m => Context -> m Session
|
||||
newSession :: Context -> IO Session
|
||||
newSession ctx
|
||||
| pUseSession $ ctxParams ctx = getStateRNG ctx 32 >>= return . Session . Just
|
||||
| otherwise = return $ Session Nothing
|
||||
|
||||
-- | when a new handshake is done, wrap up & clean up.
|
||||
handshakeTerminate :: MonadIO m => Context -> m ()
|
||||
handshakeTerminate :: Context -> IO ()
|
||||
handshakeTerminate ctx = do
|
||||
session <- usingState_ ctx getSession
|
||||
-- only callback the session established if we have a session
|
||||
|
|
@ -72,7 +72,7 @@ handshakeTerminate ctx = do
|
|||
setEstablished ctx True
|
||||
return ()
|
||||
|
||||
sendChangeCipherAndFinish :: MonadIO m => Context -> Role -> m ()
|
||||
sendChangeCipherAndFinish :: Context -> Role -> IO ()
|
||||
sendChangeCipherAndFinish ctx role = do
|
||||
sendPacket ctx ChangeCipherSpec
|
||||
|
||||
|
|
@ -94,7 +94,7 @@ sendChangeCipherAndFinish ctx role = do
|
|||
sendPacket ctx (Handshake [Finished cf])
|
||||
liftIO $ contextFlush ctx
|
||||
|
||||
recvChangeCipherAndFinish :: MonadIO m => Context -> m ()
|
||||
recvChangeCipherAndFinish :: Context -> IO ()
|
||||
recvChangeCipherAndFinish ctx = runRecvState ctx (RecvStateNext expectChangeCipher)
|
||||
where expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish
|
||||
expectChangeCipher p = unexpected (show p) (Just "change cipher")
|
||||
|
|
@ -106,7 +106,7 @@ data RecvState m =
|
|||
| RecvStateHandshake (Handshake -> m (RecvState m))
|
||||
| RecvStateDone
|
||||
|
||||
recvPacketHandshake :: MonadIO m => Context -> m [Handshake]
|
||||
recvPacketHandshake :: Context -> IO [Handshake]
|
||||
recvPacketHandshake ctx = do
|
||||
pkts <- recvPacket ctx
|
||||
case pkts of
|
||||
|
|
@ -114,12 +114,12 @@ recvPacketHandshake ctx = do
|
|||
Right x -> fail ("unexpected type received. expecting handshake and got: " ++ show x)
|
||||
Left err -> throwCore err
|
||||
|
||||
runRecvState :: MonadIO m => Context -> RecvState m -> m ()
|
||||
runRecvState :: Context -> RecvState IO -> IO ()
|
||||
runRecvState _ (RecvStateDone) = return ()
|
||||
runRecvState ctx (RecvStateNext f) = recvPacket ctx >>= either throwCore f >>= runRecvState ctx
|
||||
runRecvState ctx iniState = recvPacketHandshake ctx >>= loop iniState >>= runRecvState ctx
|
||||
where
|
||||
loop :: MonadIO m => RecvState m -> [Handshake] -> m (RecvState m)
|
||||
loop :: RecvState IO -> [Handshake] -> IO (RecvState IO)
|
||||
loop recvState [] = return recvState
|
||||
loop (RecvStateHandshake f) (x:xs) = do
|
||||
nstate <- f x
|
||||
|
|
@ -127,7 +127,7 @@ runRecvState ctx iniState = recvPacketHandshake ctx >>= loop iniState >
|
|||
loop nstate xs
|
||||
loop _ _ = unexpected "spurious handshake" Nothing
|
||||
|
||||
getSessionData :: MonadIO m => Context -> m (Maybe SessionData)
|
||||
getSessionData :: Context -> IO (Maybe SessionData)
|
||||
getSessionData ctx = do
|
||||
ver <- usingState_ ctx getVersion
|
||||
mms <- usingHState ctx (gets hstMasterSecret)
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ import Network.TLS.Context
|
|||
{- if the RSA encryption fails we just return an empty bytestring, and let the protocol
|
||||
- fail by itself; however it would be probably better to just report it since it's an internal problem.
|
||||
-}
|
||||
encryptRSA :: MonadIO m => Context -> ByteString -> m ByteString
|
||||
encryptRSA :: Context -> ByteString -> IO ByteString
|
||||
encryptRSA ctx content = do
|
||||
rsakey <- return . fromJust "rsa public key" =<< handshakeGet ctx hstRSAPublicKey
|
||||
usingState_ ctx $ do
|
||||
|
|
@ -38,7 +38,7 @@ encryptRSA ctx content = do
|
|||
Left err -> fail ("rsa encrypt failed: " ++ show err)
|
||||
Right econtent -> return econtent
|
||||
|
||||
signRSA :: MonadIO m => Context -> HashDescr -> ByteString -> m ByteString
|
||||
signRSA :: Context -> HashDescr -> ByteString -> IO ByteString
|
||||
signRSA ctx hsh content = do
|
||||
rsakey <- return . fromJust "rsa client private key" =<< handshakeGet ctx hstRSAClientPrivateKey
|
||||
usingState_ ctx $ do
|
||||
|
|
@ -47,7 +47,7 @@ signRSA ctx hsh content = do
|
|||
Left err -> fail ("rsa sign failed: " ++ show err)
|
||||
Right econtent -> return econtent
|
||||
|
||||
decryptRSA :: MonadIO m => Context -> ByteString -> m (Either KxError ByteString)
|
||||
decryptRSA :: Context -> ByteString -> IO (Either KxError ByteString)
|
||||
decryptRSA ctx econtent = do
|
||||
rsapriv <- return . fromJust "rsa private key" =<< handshakeGet ctx hstRSAPrivateKey
|
||||
usingState_ ctx $ do
|
||||
|
|
@ -55,10 +55,10 @@ decryptRSA ctx econtent = do
|
|||
let cipher = if ver < TLS10 then econtent else B.drop 2 econtent
|
||||
withRNG (\g -> kxDecrypt g rsapriv cipher)
|
||||
|
||||
verifyRSA :: MonadIO m => Context -> HashDescr -> ByteString -> ByteString -> m Bool
|
||||
verifyRSA :: Context -> HashDescr -> ByteString -> ByteString -> IO Bool
|
||||
verifyRSA ctx hsh econtent sign = do
|
||||
rsapriv <- return . fromJust "rsa client public key" =<< handshakeGet ctx hstRSAClientPublicKey
|
||||
return $ kxVerify rsapriv hsh econtent sign
|
||||
|
||||
handshakeGet :: MonadIO m => Context -> (HandshakeState -> a) -> m a
|
||||
handshakeGet :: Context -> (HandshakeState -> a) -> IO a
|
||||
handshakeGet ctx f = usingHState ctx (gets f)
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ import Network.TLS.Handshake.Key
|
|||
import Network.TLS.Extension
|
||||
import Data.X509
|
||||
|
||||
processHandshake :: MonadIO m => Context -> Handshake -> m ()
|
||||
processHandshake :: Context -> Handshake -> IO ()
|
||||
processHandshake ctx hs = do
|
||||
role <- usingState_ ctx isClientContext
|
||||
case hs of
|
||||
|
|
@ -59,7 +59,7 @@ processHandshake ctx hs = do
|
|||
-- unknown extensions
|
||||
processClientExtension _ = return ()
|
||||
|
||||
processCertificates :: MonadIO m => Role -> CertificateChain -> m ()
|
||||
processCertificates :: Role -> CertificateChain -> IO ()
|
||||
processCertificates ServerRole (CertificateChain []) = return ()
|
||||
processCertificates ClientRole (CertificateChain []) =
|
||||
throwCore $ Error_Protocol ("server certificate missing", True, HandshakeFailure)
|
||||
|
|
@ -71,7 +71,7 @@ processHandshake ctx hs = do
|
|||
-- process the client key exchange message. the protocol expects the initial
|
||||
-- client version received in ClientHello, not the negotiated version.
|
||||
-- in case the version mismatch, generate a random master secret
|
||||
processClientKeyXchg :: MonadIO m => Context -> ByteString -> m ()
|
||||
processClientKeyXchg :: Context -> ByteString -> IO ()
|
||||
processClientKeyXchg ctx encryptedPremaster = do
|
||||
(rver, role, random) <- usingState_ ctx $ do
|
||||
(,,) <$> getVersion <*> isClientContext <*> genRandom 48
|
||||
|
|
@ -86,7 +86,7 @@ processClientKeyXchg ctx encryptedPremaster = do
|
|||
| ver /= expectedVer -> setMasterSecretFromPre rver role random
|
||||
| otherwise -> setMasterSecretFromPre rver role premaster
|
||||
|
||||
processClientFinished :: MonadIO m => Context -> FinishedData -> m ()
|
||||
processClientFinished :: Context -> FinishedData -> IO ()
|
||||
processClientFinished ctx fdata = do
|
||||
(cc,ver) <- usingState_ ctx $ (,) <$> isClientContext <*> getVersion
|
||||
expected <- usingHState ctx $ getHandshakeDigest ver $ invertRole cc
|
||||
|
|
@ -95,7 +95,7 @@ processClientFinished ctx fdata = do
|
|||
usingState_ ctx $ updateVerifiedData ServerRole fdata
|
||||
return ()
|
||||
|
||||
startHandshake :: MonadIO m => Context -> Version -> ClientRandom -> m ()
|
||||
startHandshake :: Context -> Version -> ClientRandom -> IO ()
|
||||
startHandshake ctx ver crand = do
|
||||
-- FIXME check if handshake is already not null
|
||||
let initCtx = if ver < TLS12 then hashMD5SHA1 else hashSHA256
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ import Network.TLS.X509
|
|||
-- This is just a helper to pop the next message from the recv layer,
|
||||
-- and call handshakeServerWith.
|
||||
handshakeServer :: MonadIO m => ServerParams -> Context -> m ()
|
||||
handshakeServer sparams ctx = do
|
||||
handshakeServer sparams ctx = liftIO $ do
|
||||
hss <- recvPacketHandshake ctx
|
||||
case hss of
|
||||
[ch] -> handshakeServerWith sparams ctx ch
|
||||
|
|
@ -78,7 +78,7 @@ handshakeServer sparams ctx = do
|
|||
-- -> change cipher <- change cipher
|
||||
-- -> finish <- finish
|
||||
--
|
||||
handshakeServerWith :: MonadIO m => ServerParams -> Context -> Handshake -> m ()
|
||||
handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()
|
||||
handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession ciphers compressions exts _) = do
|
||||
-- check if policy allow this new handshake to happens
|
||||
handshakeAuthorized <- withMeasure ctx (onHandshake $ ctxParams ctx)
|
||||
|
|
@ -212,7 +212,7 @@ handshakeServerWith _ _ _ = fail "unexpected handshake type received. expecting
|
|||
-- <- [NPN]
|
||||
-- <- finish
|
||||
--
|
||||
recvClientData :: MonadIO m => ServerParams -> Context -> m ()
|
||||
recvClientData :: ServerParams -> Context -> IO ()
|
||||
recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientCertificate)
|
||||
where processClientCertificate (Certificates certs) = do
|
||||
-- Call application callback to see whether the
|
||||
|
|
|
|||
|
|
@ -34,14 +34,14 @@ data ConnectionNotEstablished = ConnectionNotEstablished
|
|||
|
||||
instance Exception ConnectionNotEstablished
|
||||
|
||||
checkValid :: MonadIO m => Context -> m ()
|
||||
checkValid :: Context -> IO ()
|
||||
checkValid ctx = do
|
||||
established <- ctxEstablished ctx
|
||||
unless established $ liftIO $ throwIO ConnectionNotEstablished
|
||||
eofed <- ctxEOF ctx
|
||||
when eofed $ liftIO $ throwIO $ mkIOError eofErrorType "data" Nothing Nothing
|
||||
|
||||
readExact :: MonadIO m => Context -> Int -> m Bytes
|
||||
readExact :: Context -> Int -> IO Bytes
|
||||
readExact ctx sz = do
|
||||
hdrbs <- liftIO $ contextRecv ctx sz
|
||||
when (B.length hdrbs < sz) $ do
|
||||
|
|
@ -54,9 +54,9 @@ readExact ctx sz = do
|
|||
-- | recvRecord receive a full TLS record (header + data), from the other side.
|
||||
--
|
||||
-- The record is disengaged from the record layer
|
||||
recvRecord :: MonadIO m => Bool -- ^ flag to enable SSLv2 compat ClientHello reception
|
||||
-> Context -- ^ TLS context
|
||||
-> m (Either TLSError (Record Plaintext))
|
||||
recvRecord :: Bool -- ^ flag to enable SSLv2 compat ClientHello reception
|
||||
-> Context -- ^ TLS context
|
||||
-> IO (Either TLSError (Record Plaintext))
|
||||
recvRecord compatSSLv2 ctx
|
||||
#ifdef SSLV2_COMPATIBLE
|
||||
| compatSSLv2 = do
|
||||
|
|
@ -79,7 +79,7 @@ recvRecord compatSSLv2 ctx
|
|||
Right header -> getRecord header content
|
||||
#endif
|
||||
maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow)
|
||||
getRecord :: MonadIO m => Header -> Bytes -> m (Either TLSError (Record Plaintext))
|
||||
getRecord :: Header -> Bytes -> IO (Either TLSError (Record Plaintext))
|
||||
getRecord header content = do
|
||||
liftIO $ (loggingIORecv $ ctxLogging ctx) header content
|
||||
runRxState ctx $ disengageRecord $ rawToRecord header (fragmentCiphertext content)
|
||||
|
|
@ -89,7 +89,7 @@ recvRecord compatSSLv2 ctx
|
|||
-- many messages (many only in case of handshake). if will returns a
|
||||
-- TLSError if the packet is unexpected or malformed
|
||||
recvPacket :: MonadIO m => Context -> m (Either TLSError Packet)
|
||||
recvPacket ctx = do
|
||||
recvPacket ctx = liftIO $ do
|
||||
compatSSLv2 <- ctxHasSSLv2ClientHello ctx
|
||||
erecord <- recvRecord compatSSLv2 ctx
|
||||
case erecord of
|
||||
|
|
@ -99,10 +99,10 @@ recvPacket ctx = do
|
|||
pkt <- case pktRecv of
|
||||
Right (Handshake hss) ->
|
||||
ctxWithHooks ctx $ \hooks ->
|
||||
liftIO (mapM (hookRecvHandshake hooks) hss) >>= return . Right . Handshake
|
||||
(mapM (hookRecvHandshake hooks) hss) >>= return . Right . Handshake
|
||||
_ -> return pktRecv
|
||||
case pkt of
|
||||
Right p -> liftIO $ (loggingPacketRecv $ ctxLogging ctx) $ show p
|
||||
Right p -> (loggingPacketRecv $ ctxLogging ctx) $ show p
|
||||
_ -> return ()
|
||||
when compatSSLv2 $ ctxDisableSSLv2ClientHello ctx
|
||||
return pkt
|
||||
|
|
|
|||
|
|
@ -12,7 +12,6 @@ module Network.TLS.Receiving
|
|||
( processPacket
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Error
|
||||
import Control.Concurrent.MVar
|
||||
|
|
@ -30,7 +29,7 @@ returnEither :: Either TLSError a -> TLSSt a
|
|||
returnEither (Left err) = throwError err
|
||||
returnEither (Right a) = return a
|
||||
|
||||
processPacket :: MonadIO m => Context -> Record Plaintext -> m (Either TLSError Packet)
|
||||
processPacket :: Context -> Record Plaintext -> IO (Either TLSError Packet)
|
||||
|
||||
processPacket _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment
|
||||
|
||||
|
|
@ -43,7 +42,6 @@ processPacket ctx (Record ProtocolType_ChangeCipherSpec _ fragment) =
|
|||
return $ Right ChangeCipherSpec
|
||||
|
||||
processPacket ctx (Record ProtocolType_Handshake ver fragment) = do
|
||||
--keyxchg <- (hstPendingCipher >=> return . cipherKeyExchange) <$> getHState ctx >>=
|
||||
keyxchg <- getHState ctx >>= \hs -> return $ (hs >>= hstPendingCipher >>= Just . cipherKeyExchange)
|
||||
usingState ctx $ do
|
||||
npn <- getExtensionNPN
|
||||
|
|
@ -64,7 +62,7 @@ processPacket _ (Record ProtocolType_DeprecatedHandshake _ fragment) =
|
|||
Left err -> return $ Left err
|
||||
Right hs -> return $ Right $ Handshake [hs]
|
||||
|
||||
switchRxEncryption :: MonadIO m => Context -> m ()
|
||||
switchRxEncryption :: Context -> IO ()
|
||||
switchRxEncryption ctx =
|
||||
usingHState ctx (gets hstPendingRxState) >>= \rx ->
|
||||
liftIO $ modifyMVar_ (ctxRxState ctx) (\_ -> return $ fromJust "rx-state" rx)
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ prepareRecord ctx f = do
|
|||
runTxState ctx (modify (setRecordIV newIV) >> f)
|
||||
else runTxState ctx f
|
||||
|
||||
switchTxEncryption :: MonadIO m => Context -> m ()
|
||||
switchTxEncryption :: Context -> IO ()
|
||||
switchTxEncryption ctx = do
|
||||
tx <- usingHState ctx (fromJust "tx-state" <$> gets hstPendingTxState)
|
||||
(ver, cc) <- usingState_ ctx $ do v <- getVersion
|
||||
|
|
@ -87,4 +87,3 @@ switchTxEncryption ctx = do
|
|||
-- set empty packet counter measure if condition are met
|
||||
when (ver <= TLS10 && cc == ClientRole && isCBC tx) $ liftIO $ writeIORef (ctxNeedEmptyPacket ctx) True
|
||||
where isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue