diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -11,6 +11,7 @@ -- * Context configuration TLSParams(..) , TLSLogging(..) + , Measurement(..) , TLSCertificateUsage(..) , TLSCertificateRejectReason(..) , defaultLogging @@ -49,6 +50,7 @@ import Network.TLS.State import Network.TLS.Sending import Network.TLS.Receiving +import Network.TLS.Measurement import Data.Maybe import Data.Certificate.X509 import Data.List (intersect, intercalate, find) @@ -96,6 +98,7 @@ , pUseSecureRenegotiation :: Bool -- notify that we want to use secure renegotation , pCertificates :: [(X509, Maybe PrivateKey)] -- ^ the cert chain for this context with the associated keys if any. , pLogging :: TLSLogging -- ^ callback for logging + , onHandshake :: Measurement -> IO Bool -- ^ callback on a beggining of handshake , onCertificatesRecv :: [X509] -> IO TLSCertificateUsage -- ^ callback to verify received cert chain. } @@ -117,6 +120,7 @@ , pUseSecureRenegotiation = True , pCertificates = [] , pLogging = defaultLogging + , onHandshake = (\_ -> return True) , onCertificatesRecv = (\_ -> return CertificateUsageAccept) } @@ -135,20 +139,27 @@ { ctxConnection :: a -- ^ return the connection object associated with this context , ctxParams :: TLSParams , ctxState :: MVar TLSState + , ctxMeasurement :: IORef Measurement , ctxEOF_ :: IORef Bool -- ^ is the handle has EOFed or not. , ctxConnectionFlush :: IO () , ctxConnectionSend :: Bytes -> IO () , ctxConnectionRecv :: Int -> IO Bytes } +updateMeasure :: MonadIO m => TLSCtx c -> (Measurement -> Measurement) -> m () +updateMeasure ctx f = liftIO $ modifyIORef (ctxMeasurement ctx) f + +withMeasure :: MonadIO m => TLSCtx c -> (Measurement -> IO a) -> m a +withMeasure ctx f = liftIO (readIORef (ctxMeasurement ctx) >>= f) + connectionFlush :: TLSCtx c -> IO () -connectionFlush c = (ctxConnectionFlush c) +connectionFlush c = ctxConnectionFlush c connectionSend :: TLSCtx c -> Bytes -> IO () -connectionSend c b = (ctxConnectionSend c) b +connectionSend c b = updateMeasure c (addBytesSent $ B.length b) >> (ctxConnectionSend c) b connectionRecv :: TLSCtx c -> Int -> IO Bytes -connectionRecv c sz = (ctxConnectionRecv c) sz +connectionRecv c sz = updateMeasure c (addBytesReceived sz) >> (ctxConnectionRecv c) sz ctxEOF :: MonadIO m => TLSCtx a -> m Bool ctxEOF ctx = liftIO (readIORef $ ctxEOF_ ctx) @@ -160,11 +171,13 @@ newCtxWith c flushF sendF recvF params st = do stvar <- newMVar st eof <- newIORef False + stats <- newIORef newMeasurement return $ TLSCtx - { ctxConnection = c - , ctxParams = params - , ctxState = stvar - , ctxEOF_ = eof + { ctxConnection = c + , ctxParams = params + , ctxState = stvar + , ctxMeasurement = stats + , ctxEOF_ = eof , ctxConnectionFlush = flushF , ctxConnectionSend = sendF , ctxConnectionRecv = recvF @@ -197,11 +210,6 @@ getStateRNG :: MonadIO m => TLSCtx c -> Int -> m Bytes getStateRNG ctx n = usingState_ ctx (genTLSRandom n) -whileStatus :: MonadIO m => TLSCtx c -> (TLSStatus -> Bool) -> m a -> m () -whileStatus ctx p a = do - b <- usingState_ ctx (p . stStatus <$> get) - when b (a >> whileStatus ctx p a) - errorToAlert :: TLSError -> Packet errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)] errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)] @@ -219,34 +227,68 @@ else throwCore (Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs))) return hdrbs +recvRecord :: MonadIO m => TLSCtx c -> m (Either TLSError (Record Plaintext)) +recvRecord ctx = readExact ctx 5 >>= either (return . Left) recvLength . decodeHeader + where recvLength header@(Header _ _ readlen) + | readlen > 16384 + 2048 = return $ Left $ Error_Protocol ("record exceeding maximum size", True, RecordOverflow) + | otherwise = do + content <- readExact ctx (fromIntegral readlen) + liftIO $ (loggingIORecv $ ctxLogging ctx) header content + usingState ctx $ disengageRecord $ rawToRecord header (fragmentCiphertext content) + + -- | receive one packet from the context that contains 1 or -- many messages (many only in case of handshake). if will returns a -- TLSError if the packet is unexpected or malformed recvPacket :: MonadIO m => TLSCtx c -> m (Either TLSError Packet) recvPacket ctx = do - hdrbs <- readExact ctx 5 - case decodeHeader hdrbs of - Left err -> return $ Left err - Right header@(Header _ _ readlen) -> - if readlen > (16384 + 2048) - then return $ Left $ Error_Protocol ("record exceeding maximum size",True, RecordOverflow) - else recvLength header readlen - where recvLength header readlen = do - content <- readExact ctx (fromIntegral readlen) - liftIO $ (loggingIORecv $ ctxLogging ctx) header content - pkt <- usingState ctx $ readPacket $ rawToRecord header (fragmentCiphertext content) - case pkt of - Right p -> liftIO $ (loggingPacketRecv $ ctxLogging ctx) $ show p - _ -> return () - return pkt + erecord <- recvRecord ctx + case erecord of + Left err -> return $ Left err + Right record -> do + pkt <- usingState ctx $ processPacket record + case pkt of + Right p -> liftIO $ (loggingPacketRecv $ ctxLogging ctx) $ show p + _ -> return () + return pkt -recvPacketSuccess :: MonadIO m => TLSCtx c -> m () -recvPacketSuccess ctx = do - pkt <- recvPacket ctx - case pkt of - Left err -> throwCore err - Right _ -> return () +recvPacketHandshake :: MonadIO m => TLSCtx c -> m [Handshake] +recvPacketHandshake ctx = do + pkts <- recvPacket ctx + case pkts of + Right (Handshake l) -> return l + Right x -> fail ("unexpected type received. expecting handshake and got: " ++ show x) + Left err -> throwCore err +data RecvState m = + RecvStateNext (Packet -> m (RecvState m)) + | RecvStateHandshake (Handshake -> m (RecvState m)) + | RecvStateDone + +runRecvState :: MonadIO m => TLSCtx a -> RecvState m -> m () +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 [] = return recvState + loop (RecvStateHandshake f) (x:xs) = do + nstate <- f x + usingState_ ctx $ processHandshake x + loop nstate xs + loop _ _ = unexpected "spurious handshake" Nothing + +sendChangeCipherAndFinish :: MonadIO m => TLSCtx c -> Bool -> m () +sendChangeCipherAndFinish ctx isClient = do + sendPacket ctx ChangeCipherSpec + liftIO $ connectionFlush ctx + cf <- usingState_ ctx $ getHandshakeDigest isClient + sendPacket ctx (Handshake [Finished cf]) + liftIO $ connectionFlush ctx + +unexpected :: MonadIO m => String -> Maybe [Char] -> m a +unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) + -- | Send one packet to the context sendPacket :: MonadIO m => TLSCtx c -> Packet -> m () sendPacket ctx pkt = do @@ -291,40 +333,13 @@ -- values intertwined with response from the server. handshakeClient :: MonadIO m => TLSCtx c -> m () handshakeClient ctx = do - -- Send ClientHello - crand <- getStateRNG ctx 32 >>= return . ClientRandom - extensions <- getExtensions - usingState_ ctx (startHandshakeClient ver crand) - sendPacket ctx $ Handshake - [ ClientHello ver crand (Session Nothing) (map cipherID ciphers) - (map compressionID compressions) extensions - ] - - -- Receive Server information until ServerHelloDone - whileStatus ctx (/= (StatusHandshake HsStatusServerHelloDone)) $ do - pkts <- recvPacket ctx - case pkts of - Left err -> throwCore err - Right l -> processServerInfo l - - -- Send Certificate if requested. XXX disabled for now. - certRequested <- return False - when certRequested (sendPacket ctx $ Handshake [Certificates clientCerts]) - - sendClientKeyXchg - - {- maybe send certificateVerify -} - {- FIXME not implemented yet -} - - sendPacket ctx ChangeCipherSpec - liftIO $ connectionFlush ctx - - -- Send Finished - cf <- usingState_ ctx $ getHandshakeDigest True - sendPacket ctx (Handshake [Finished cf]) - - -- receive changeCipherSpec & Finished - recvPacketSuccess ctx >> recvPacketSuccess ctx >> return () + updateMeasure ctx incrementNbHandshakes + sendClientHello + recvServerHello + sendCertificate >> sendClientKeyXchg >> sendCertificateVerify + sendChangeCipherAndFinish ctx True + recvChangeCipherAndFinish + updateMeasure ctx resetBytesCounters where params = ctxParams ctx @@ -338,10 +353,36 @@ then usingState_ ctx (getVerifiedData True) >>= \vd -> return [ (0xff01, encodeExtSecureRenegotiation vd Nothing) ] else return [] - processServerInfo (Handshake hss) = mapM_ processHandshake hss - processServerInfo _ = return () + sendClientHello = do + crand <- getStateRNG ctx 32 >>= return . ClientRandom + extensions <- getExtensions + usingState_ ctx (startHandshakeClient ver crand) + sendPacket ctx $ Handshake + [ ClientHello ver crand (Session Nothing) (map cipherID ciphers) + (map compressionID compressions) extensions + ] - processHandshake (ServerHello rver _ _ cipher _ _) = do + recvChangeCipherAndFinish = runRecvState ctx (RecvStateNext expectChangeCipher) + where + expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish + expectChangeCipher p = unexpected (show p) (Just "change cipher") + expectFinish (Finished _) = return RecvStateDone + expectFinish p = unexpected (show p) (Just "Handshake Finished") + + sendCertificate = do + -- Send Certificate if requested. XXX disabled for now. + certRequested <- return False + when certRequested (sendPacket ctx $ Handshake [Certificates clientCerts]) + + sendCertificateVerify = + {- maybe send certificateVerify -} + {- FIXME not implemented yet -} + return () + + recvServerHello = runRecvState ctx (RecvStateHandshake processServerHello) + + processServerHello :: MonadIO m => Handshake -> m (RecvState m) + processServerHello (ServerHello rver _ _ cipher _ _) = do when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) case find ((==) rver) allowedvers of Nothing -> throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion) @@ -349,22 +390,39 @@ case find ((==) cipher . cipherID) ciphers of Nothing -> throwCore $ Error_Protocol ("no cipher in common with the server", True, HandshakeFailure) Just c -> usingState_ ctx $ setCipher c + return $ RecvStateHandshake processCertificate + processServerHello p = unexpected (show p) (Just "server hello") - processHandshake (Certificates certs) = do + processCertificate :: MonadIO m => Handshake -> m (RecvState m) + processCertificate (Certificates certs) = do let cb = onCertificatesRecv $ params usage <- liftIO $ cb certs case usage of CertificateUsageAccept -> return () CertificateUsageReject reason -> certificateRejected reason + return $ RecvStateHandshake processServerKeyExchange + processCertificate p = processServerKeyExchange p - processHandshake (CertRequest _ _ _) = do - return () + processServerKeyExchange :: MonadIO m => Handshake -> m (RecvState m) + processServerKeyExchange (ServerKeyXchg _) = return $ RecvStateHandshake processCertificateRequest + processServerKeyExchange p = processCertificateRequest p + + processCertificateRequest (CertRequest _ _ _) = do --modify (\sc -> sc { scCertRequested = True }) - processHandshake _ = return () + return $ RecvStateHandshake processServerHelloDone + processCertificateRequest p = processServerHelloDone p + processServerHelloDone ServerHelloDone = return RecvStateDone + processServerHelloDone p = unexpected (show p) (Just "server hello data") + sendClientKeyXchg = do - prerand <- getStateRNG ctx 46 >>= return . ClientKeyData - sendPacket ctx $ Handshake [ClientKeyXchg ver prerand] + encryptedPreMaster <- usingState_ ctx $ do + xver <- stVersion <$> get + prerand <- genTLSRandom 46 + let premaster = encodePreMasterSecret xver prerand + setMasterSecret premaster + encryptRSA premaster + sendPacket ctx $ Handshake [ClientKeyXchg encryptedPreMaster] -- on certificate reject, throw an exception with the proper protocol alert error. certificateRejected CertificateRejectRevoked = @@ -377,8 +435,14 @@ throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown) handshakeServerWith :: MonadIO m => TLSCtx c -> Handshake -> m () -handshakeServerWith ctx (ClientHello ver _ _ ciphers compressions _) = do +handshakeServerWith ctx clientHello@(ClientHello ver _ _ ciphers compressions _) = do + -- check if policy allow this new handshake to happens + handshakeAuthorized <- withMeasure ctx (onHandshake $ ctxParams ctx) + unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied") + updateMeasure ctx incrementNbHandshakes + -- Handle Client hello + usingState_ ctx $ processHandshake clientHello when (ver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) when (not $ elem ver (pAllowedVersions params)) $ throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion) @@ -397,15 +461,10 @@ liftIO $ connectionFlush ctx -- Receive client info until client Finished. - whileStatus ctx (/= (StatusHandshake HsStatusClientFinished)) (recvPacketSuccess ctx) - - sendPacket ctx ChangeCipherSpec - - -- Send Finish - cf <- usingState_ ctx $ getHandshakeDigest False - sendPacket ctx (Handshake [Finished cf]) + recvClientData + sendChangeCipherAndFinish ctx False - liftIO $ connectionFlush ctx + updateMeasure ctx resetBytesCounters return () where params = ctxParams ctx @@ -417,6 +476,25 @@ privKeys = map snd $ pCertificates params needKeyXchg = cipherExchangeNeedMoreData $ cipherKeyExchange usedCipher + --- + recvClientData = runRecvState ctx (RecvStateHandshake $ processClientCertificate) + + processClientCertificate (Certificates _) = return $ RecvStateHandshake processClientKeyExchange + processClientCertificate p = processClientKeyExchange p + + processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify + processClientKeyExchange p = unexpected (show p) (Just "client key exchange") + + processCertificateVerify (Handshake [CertVerify _]) = return $ RecvStateNext expectChangeCipher + processCertificateVerify p = expectChangeCipher p + + expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish + expectChangeCipher p = unexpected (show p) (Just "change cipher") + + expectFinish (Finished _) = return RecvStateDone + expectFinish p = unexpected (show p) (Just "Handshake Finished") + --- + handshakeSendServerData = do srand <- getStateRNG ctx 32 >>= return . ServerRandom @@ -456,7 +534,7 @@ handshakeServerWith _ _ = fail "unexpected handshake type received. expecting client hello" --- after receiving a client hello, we need to redo a handshake -} +-- after receiving a client hello, we need to redo a handshake handshakeServer :: MonadIO m => TLSCtx c -> m () handshakeServer ctx = do pkts <- recvPacket ctx @@ -474,7 +552,7 @@ handleException f = catch (f >> return True) (\e -> handler e >> return False) handler e = case fromException e of Just err -> sendPacket ctx (errorToAlert err) - Nothing -> sendPacket ctx (errorToAlert $ Error_Misc "") + Nothing -> sendPacket ctx (errorToAlert $ Error_Misc $ show e) -- | sendData sends a bunch of data. -- It will automatically chunk data to acceptable packet size diff --git a/Network/TLS/Measurement.hs b/Network/TLS/Measurement.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Measurement.hs @@ -0,0 +1,46 @@ +-- | +-- Module : Network.TLS.Measurement +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Network.TLS.Measurement + ( Measurement(..) + , newMeasurement + , addBytesReceived + , addBytesSent + , resetBytesCounters + , incrementNbHandshakes + ) where + +import Data.Word + +-- | record some data about this connection. +data Measurement = Measurement + { nbHandshakes :: !Word32 -- ^ number of handshakes on this context + , bytesReceived :: !Word32 -- ^ bytes received since last handshake + , bytesSent :: !Word32 -- ^ bytes sent since last handshake + } deriving (Show,Eq) + +newMeasurement :: Measurement +newMeasurement = Measurement + { nbHandshakes = 0 + , bytesReceived = 0 + , bytesSent = 0 + } + +addBytesReceived :: Int -> Measurement -> Measurement +addBytesReceived sz measure = + measure { bytesReceived = bytesReceived measure + fromIntegral sz } + +addBytesSent :: Int -> Measurement -> Measurement +addBytesSent sz measure = + measure { bytesSent = bytesSent measure + fromIntegral sz } + +resetBytesCounters :: Measurement -> Measurement +resetBytesCounters measure = measure { bytesReceived = 0, bytesSent = 0 } + +incrementNbHandshakes :: Measurement -> Measurement +incrementNbHandshakes measure = + measure { nbHandshakes = nbHandshakes measure + 1 } diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -35,6 +35,9 @@ , decodeChangeCipherSpec , encodeChangeCipherSpec + , decodePreMasterSecret + , encodePreMasterSecret + -- * marshall extensions , decodeExtSecureRenegotiation , encodeExtSecureRenegotiation @@ -247,10 +250,7 @@ return $ CertVerify [] decodeClientKeyXchg :: Get Handshake -decodeClientKeyXchg = do - ver <- getVersion - ran <- getClientKeyData46 - return $ ClientKeyXchg ver ran +decodeClientKeyXchg = ClientKeyXchg <$> (remaining >>= getBytes) os2ip :: ByteString -> Integer os2ip = B.foldl' (\a b -> (256 * a) .|. (fromIntegral b)) 0 @@ -269,18 +269,20 @@ return $ ServerRSAParams { rsa_modulus = os2ip modulus, rsa_exponent = os2ip expo } decodeServerKeyXchg :: CurrentParams -> Get Handshake -decodeServerKeyXchg cp = do - skxAlg <- case cParamsKeyXchgType cp of - CipherKeyExchange_RSA -> do - rsaparams <- decodeServerKeyXchg_RSA - return $ SKX_RSA $ Just rsaparams - CipherKeyExchange_DH_Anon -> do - dhparams <- decodeServerKeyXchg_DH - return $ SKX_DH_Anon dhparams - _ -> do - bs <- remaining >>= getBytes - return $ SKX_Unknown bs - return (ServerKeyXchg skxAlg) +decodeServerKeyXchg cp = ServerKeyXchg <$> case cParamsKeyXchgType cp of + CipherKeyExchange_RSA -> SKX_RSA . Just <$> decodeServerKeyXchg_RSA + CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH + CipherKeyExchange_DHE_RSA -> do + dhparams <- decodeServerKeyXchg_DH + signature <- getWord16 >>= getBytes . fromIntegral + return $ SKX_DHE_RSA dhparams (B.unpack signature) + CipherKeyExchange_DHE_DSS -> do + dhparams <- decodeServerKeyXchg_DH + signature <- getWord16 >>= getBytes . fromIntegral + return $ SKX_DHE_DSS dhparams (B.unpack signature) + _ -> do + bs <- remaining >>= getBytes + return $ SKX_Unknown bs encodeHandshake :: Handshake -> ByteString encodeHandshake o = @@ -317,9 +319,8 @@ certbs = runPut $ mapM_ putCert certs len = fromIntegral $ B.length certbs -encodeHandshakeContent (ClientKeyXchg version random) = do - putVersion version - putClientKeyData46 random +encodeHandshakeContent (ClientKeyXchg content) = do + putBytes content encodeHandshakeContent (ServerKeyXchg _) = do -- FIXME @@ -358,12 +359,6 @@ putServerRandom32 :: ServerRandom -> Put putServerRandom32 (ServerRandom r) = putRandom32 r -getClientKeyData46 :: Get ClientKeyData -getClientKeyData46 = ClientKeyData <$> getBytes 46 - -putClientKeyData46 :: ClientKeyData -> Put -putClientKeyData46 (ClientKeyData d) = putBytes d - getSession :: Get Session getSession = do len8 <- getWord8 @@ -440,6 +435,14 @@ putWord8 $ fromIntegral (B.length cvd + B.length svd) putBytes cvd putBytes svd + +-- rsa pre master secret +decodePreMasterSecret :: Bytes -> Either TLSError (Version, Bytes) +decodePreMasterSecret = runGetErr "pre-master-secret" $ do + liftM2 (,) getVersion (getBytes 46) + +encodePreMasterSecret :: Version -> Bytes -> Bytes +encodePreMasterSecret version bytes = runPut (putVersion version >> putBytes bytes) {- - generate things for packet content diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs --- a/Network/TLS/Receiving.hs +++ b/Network/TLS/Receiving.hs @@ -8,26 +8,20 @@ -- the Receiving module contains calls related to unmarshalling packets according -- to the TLS state -- -module Network.TLS.Receiving ( - readPacket - ) where +module Network.TLS.Receiving (processHandshake, processPacket) where -import Data.Maybe (isJust) import Control.Applicative ((<$>)) import Control.Monad.State import Control.Monad.Error import Data.ByteString (ByteString) -import qualified Data.ByteString as B import Network.TLS.Util -import Network.TLS.Cap import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet import Network.TLS.State import Network.TLS.Cipher -import Network.TLS.Compression import Network.TLS.Crypto import Data.Certificate.X509 @@ -35,25 +29,6 @@ returnEither (Left err) = throwError err returnEither (Right a) = return a -readPacket :: Record Ciphertext -> TLSSt Packet -readPacket record = checkState record >> decryptContent record >>= uncompressContent >>= processPacket - -checkState :: Record a -> TLSSt () -checkState (Record pt _ _) = - stStatus <$> get >>= \status -> unless (allowed pt status) $ throwError (err status) - where - err st = Error_Protocol ("unexpected message received: status=" ++ show st, True, UnexpectedMessage) - - allowed :: ProtocolType -> TLSStatus -> Bool - allowed ProtocolType_Alert _ = True - allowed ProtocolType_Handshake _ = True - allowed ProtocolType_AppData StatusHandshakeReq = True - allowed ProtocolType_AppData StatusOk = True - allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientFinished) = True - allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientKeyXchg) = True - allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientCertificateVerify) = True - allowed _ _ = False - processPacket :: Record Plaintext -> TLSSt Packet processPacket (Record ProtocolType_AppData _ fragment) = return $ AppData $ fragmentGetBytes fragment @@ -61,40 +36,26 @@ processPacket (Record ProtocolType_Alert _ fragment) = return . Alert =<< returnEither (decodeAlerts $ fragmentGetBytes fragment) processPacket (Record ProtocolType_ChangeCipherSpec _ fragment) = do - e <- updateStatusCC False - when (isJust e) $ throwError (fromJust "" e) - returnEither $ decodeChangeCipherSpec $ fragmentGetBytes fragment switchRxEncryption isClientContext >>= \cc -> when (not cc) setKeyBlock return ChangeCipherSpec processPacket (Record ProtocolType_Handshake ver fragment) = do - handshakes <- returnEither (decodeHandshakes $ fragmentGetBytes fragment) - hss <- forM handshakes $ \(ty, content) -> do - hs <- processHandshake ver ty content - when (finishHandshakeTypeMaterial ty) $ updateHandshakeDigestSplitted ty content - return hs - return $ Handshake hss - -processHandshake :: Version -> HandshakeType -> ByteString -> TLSSt Handshake -processHandshake ver ty econtent = do - -- SECURITY FIXME if RSA fail, we need to generate a random master secret and not fail. - e <- updateStatusHs ty - maybe (return ()) throwError e - keyxchg <- getCipherKeyExchangeType let currentparams = CurrentParams { cParamsVersion = ver , cParamsKeyXchgType = maybe CipherKeyExchange_RSA id $ keyxchg } - content <- case ty of - HandshakeType_ClientKeyXchg -> either (const econtent) id <$> decryptRSA econtent - _ -> return econtent - hs <- case (ty, decodeHandshake currentparams ty content) of - (_, Right x) -> return x - (HandshakeType_ClientKeyXchg, Left _) -> return $ ClientKeyXchg SSL2 (ClientKeyData $ B.replicate 46 0xff) - (_, Left err) -> throwError err + handshakes <- returnEither (decodeHandshakes $ fragmentGetBytes fragment) + hss <- forM handshakes $ \(ty, content) -> do + case decodeHandshake currentparams ty content of + Left err -> throwError err + Right hs -> return hs + return $ Handshake hss + +processHandshake :: Handshake -> TLSSt () +processHandshake hs = do clientmode <- isClientContext case hs of ClientHello cver ran _ _ _ ex -> unless clientmode $ do @@ -108,11 +69,11 @@ setServerRandom ran setVersion sver Certificates certs -> when clientmode $ do processCertificates certs - ClientKeyXchg cver _ -> unless clientmode $ do - processClientKeyXchg cver content + ClientKeyXchg content -> unless clientmode $ do + processClientKeyXchg content Finished fdata -> processClientFinished fdata _ -> return () - return hs + when (finishHandshakeTypeMaterial $ typeOfHandshake hs) (updateHandshakeDigest $ encodeHandshake hs) where -- secure renegotiation processClientExtension (0xff01, content) = do @@ -135,20 +96,24 @@ decryptRSA :: ByteString -> TLSSt (Either KxError ByteString) decryptRSA econtent = do - ver <- stVersion <$> get rsapriv <- fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake <$> get - return $ kxDecrypt rsapriv (if ver < TLS10 then econtent else B.drop 2 econtent) + return $ kxDecrypt rsapriv econtent -- process the client key exchange message. the protocol expects the initial -- client version received in ClientHello, not the negociated version. -- in case the version mismatch, generate a random master secret -processClientKeyXchg :: Version -> ByteString -> TLSSt () -processClientKeyXchg ver content = do +processClientKeyXchg :: ByteString -> TLSSt () +processClientKeyXchg encryptedPremaster = do expectedVer <- hstClientVersion . fromJust "handshake" . stHandshake <$> get - setMasterSecret =<< - if expectedVer /= ver - then genTLSRandom (fromIntegral $ B.length content) - else return content + random <- genTLSRandom 48 + ePremaster <- decryptRSA encryptedPremaster + case ePremaster of + Left _ -> setMasterSecret random + Right premaster -> case decodePreMasterSecret premaster of + Left _ -> setMasterSecret random + Right (ver, _) + | ver /= expectedVer -> setMasterSecret random + | otherwise -> setMasterSecret premaster processClientFinished :: FinishedData -> TLSSt () processClientFinished fdata = do @@ -158,94 +123,6 @@ throwError $ Error_Protocol("bad record mac", True, BadRecordMac) updateVerifiedData False fdata return () - --- just `decompress' by returning the data for now till we have compression implemented -uncompressContent :: Record Compressed -> TLSSt (Record Plaintext) -uncompressContent record = onRecordFragment record $ fragmentUncompress $ \bytes -> - withCompression $ compressionInflate bytes - -decryptContent :: Record Ciphertext -> TLSSt (Record Compressed) -decryptContent record = onRecordFragment record $ fragmentUncipher $ \e -> do - st <- get - if stRxEncrypted st - then decryptData e >>= getCipherData record - else return e - -getCipherData :: Record a -> CipherData -> TLSSt ByteString -getCipherData (Record pt ver _) cdata = do - -- check if the MAC is valid. - macValid <- case cipherDataMAC cdata of - Nothing -> return True - Just digest -> do - let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata) - expected_digest <- makeDigest False new_hdr $ cipherDataContent cdata - return (expected_digest `bytesEq` digest) - - -- check if the padding is filled with the correct pattern if it exists - paddingValid <- case cipherDataPadding cdata of - Nothing -> return True - Just pad -> do - cver <- stVersion <$> get - let b = B.length pad - 1 - return (if cver < TLS10 then True else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad) - - unless (macValid &&! paddingValid) $ do - throwError $ Error_Protocol ("bad record mac", True, BadRecordMac) - - return $ cipherDataContent cdata - -decryptData :: Bytes -> TLSSt CipherData -decryptData econtent = do - st <- get - - let cipher = fromJust "cipher" $ stCipher st - let bulk = cipherBulk cipher - let cst = fromJust "rx crypt state" $ stRxCryptState st - let digestSize = hashSize $ cipherHash cipher - let writekey = cstKey cst - - case bulkF bulk of - BulkNoneF -> do - let contentlen = B.length econtent - digestSize - case partition3 econtent (contentlen, digestSize, 0) of - Nothing -> - throwError $ Error_Misc "partition3 failed" - Just (content, mac, _) -> - return $ CipherData - { cipherDataContent = content - , cipherDataMAC = Just mac - , cipherDataPadding = Nothing - } - BulkBlockF _ decryptF -> do - {- update IV -} - let (iv, econtent') = - if hasExplicitBlockIV $ stVersion st - then B.splitAt (bulkIVSize bulk) econtent - else (cstIV cst, econtent) - let newiv = fromJust "new iv" $ takelast (bulkBlockSize bulk) econtent' - put $ st { stRxCryptState = Just $ cst { cstIV = newiv } } - - let content' = decryptF writekey iv econtent' - let paddinglength = fromIntegral (B.last content') + 1 - let contentlen = B.length content' - paddinglength - digestSize - let (content, mac, padding) = fromJust "p3" $ partition3 content' (contentlen, digestSize, paddinglength) - return $ CipherData - { cipherDataContent = content - , cipherDataMAC = Just mac - , cipherDataPadding = Just padding - } - BulkStreamF initF _ decryptF -> do - let iv = cstIV cst - let (content', newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent - {- update Ctx -} - let contentlen = B.length content' - digestSize - let (content, mac, _) = fromJust "p3" $ partition3 content' (contentlen, digestSize, 0) - put $ st { stRxCryptState = Just $ cst { cstIV = newiv } } - return $ CipherData - { cipherDataContent = content - , cipherDataMAC = Just mac - , cipherDataPadding = Nothing - } processCertificates :: [X509] -> TLSSt () processCertificates certs = do diff --git a/Network/TLS/Record.hs b/Network/TLS/Record.hs --- a/Network/TLS/Record.hs +++ b/Network/TLS/Record.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE EmptyDataDecls #-} -- | -- Module : Network.TLS.Record -- License : BSD-style @@ -13,84 +12,21 @@ -- higher-level clients. -- module Network.TLS.Record - ( Header(..) - , ProtocolType(..) - , packetType - -- * TLS Records - , Record(..) - -- * TLS Record fragment and constructors + ( Record(..) , Fragment + , fragmentGetBytes , fragmentPlaintext , fragmentCiphertext - , fragmentGetBytes + , recordToRaw + , rawToRecord + , recordToHeader , Plaintext , Compressed , Ciphertext - -- * manipulate record - , onRecordFragment - , fragmentCompress - , fragmentCipher - , fragmentUncipher - , fragmentUncompress - -- * serialize record - , rawToRecord - , recordToRaw - , recordToHeader + , engageRecord + , disengageRecord ) where -import Network.TLS.Struct -import Network.TLS.State -import qualified Data.ByteString as B -import Control.Applicative ((<$>)) - --- | Represent a TLS record. -data Record a = Record !ProtocolType !Version !(Fragment a) deriving (Show,Eq) - -newtype Fragment a = Fragment Bytes deriving (Show,Eq) - -data Plaintext -data Compressed -data Ciphertext - -fragmentPlaintext :: Bytes -> Fragment Plaintext -fragmentPlaintext bytes = Fragment bytes - -fragmentCiphertext :: Bytes -> Fragment Ciphertext -fragmentCiphertext bytes = Fragment bytes - -fragmentGetBytes :: Fragment a -> Bytes -fragmentGetBytes (Fragment bytes) = bytes - -onRecordFragment :: Record a -> (Fragment a -> TLSSt (Fragment b)) -> TLSSt (Record b) -onRecordFragment (Record pt ver frag) f = Record pt ver <$> f frag - -fragmentMap :: (Bytes -> TLSSt Bytes) -> Fragment a -> TLSSt (Fragment b) -fragmentMap f (Fragment b) = Fragment <$> f b - --- | turn a plaintext record into a compressed record using the compression function supplied -fragmentCompress :: (Bytes -> TLSSt Bytes) -> Fragment Plaintext -> TLSSt (Fragment Compressed) -fragmentCompress f = fragmentMap f - --- | turn a compressed record into a ciphertext record using the cipher function supplied -fragmentCipher :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Ciphertext) -fragmentCipher f = fragmentMap f - --- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied -fragmentUncipher :: (Bytes -> TLSSt Bytes) -> Fragment Ciphertext -> TLSSt (Fragment Compressed) -fragmentUncipher f = fragmentMap f - --- | turn a compressed fragment into a plaintext fragment using the decompression function supplied -fragmentUncompress :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Plaintext) -fragmentUncompress f = fragmentMap f - --- | turn a record into an header and bytes -recordToRaw :: Record a -> (Header, Bytes) -recordToRaw (Record pt ver (Fragment bytes)) = (Header pt ver (fromIntegral $ B.length bytes), bytes) - --- | turn a header and a fragment into a record -rawToRecord :: Header -> Fragment a -> Record a -rawToRecord (Header pt ver _) fragment = Record pt ver fragment - --- | turn a record into a header -recordToHeader :: Record a -> Header -recordToHeader (Record pt ver (Fragment bytes)) = Header pt ver (fromIntegral $ B.length bytes) +import Network.TLS.Record.Types +import Network.TLS.Record.Engage +import Network.TLS.Record.Disengage diff --git a/Network/TLS/Record/Disengage.hs b/Network/TLS/Record/Disengage.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/Disengage.hs @@ -0,0 +1,117 @@ +-- | +-- Module : Network.TLS.Record.Disengage +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Disengage a record from the Record layer. +-- The record is decrypted, checked for integrity and then decompressed. +-- +module Network.TLS.Record.Disengage + ( disengageRecord + ) where + +import Control.Monad.State +import Control.Monad.Error + +import Network.TLS.Struct +import Network.TLS.Cap +import Network.TLS.State +import Network.TLS.Record.Types +import Network.TLS.Cipher +import Network.TLS.Compression +import Network.TLS.Util +import Data.ByteString (ByteString) +import qualified Data.ByteString as B + +disengageRecord :: Record Ciphertext -> TLSSt (Record Plaintext) +disengageRecord = decryptRecord >=> uncompressRecord + +uncompressRecord :: Record Compressed -> TLSSt (Record Plaintext) +uncompressRecord record = onRecordFragment record $ fragmentUncompress $ \bytes -> + withCompression $ compressionInflate bytes + +decryptRecord :: Record Ciphertext -> TLSSt (Record Compressed) +decryptRecord record = onRecordFragment record $ fragmentUncipher $ \e -> do + st <- get + if stRxEncrypted st + then decryptData e >>= getCipherData record + else return e + +getCipherData :: Record a -> CipherData -> TLSSt ByteString +getCipherData (Record pt ver _) cdata = do + -- check if the MAC is valid. + macValid <- case cipherDataMAC cdata of + Nothing -> return True + Just digest -> do + let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata) + expected_digest <- makeDigest False new_hdr $ cipherDataContent cdata + return (expected_digest `bytesEq` digest) + + -- check if the padding is filled with the correct pattern if it exists + paddingValid <- case cipherDataPadding cdata of + Nothing -> return True + Just pad -> do + cver <- gets stVersion + let b = B.length pad - 1 + return (if cver < TLS10 then True else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad) + + unless (macValid &&! paddingValid) $ do + throwError $ Error_Protocol ("bad record mac", True, BadRecordMac) + + return $ cipherDataContent cdata + +decryptData :: Bytes -> TLSSt CipherData +decryptData econtent = do + st <- get + + let cipher = fromJust "cipher" $ stCipher st + let bulk = cipherBulk cipher + let cst = fromJust "rx crypt state" $ stRxCryptState st + let digestSize = hashSize $ cipherHash cipher + let writekey = cstKey cst + + case bulkF bulk of + BulkNoneF -> do + let contentlen = B.length econtent - digestSize + case partition3 econtent (contentlen, digestSize, 0) of + Nothing -> + throwError $ Error_Misc "partition3 failed" + Just (content, mac, _) -> + return $ CipherData + { cipherDataContent = content + , cipherDataMAC = Just mac + , cipherDataPadding = Nothing + } + BulkBlockF _ decryptF -> do + {- update IV -} + let (iv, econtent') = + if hasExplicitBlockIV $ stVersion st + then B.splitAt (bulkIVSize bulk) econtent + else (cstIV cst, econtent) + let newiv = fromJust "new iv" $ takelast (bulkBlockSize bulk) econtent' + put $ st { stRxCryptState = Just $ cst { cstIV = newiv } } + + let content' = decryptF writekey iv econtent' + let paddinglength = fromIntegral (B.last content') + 1 + let contentlen = B.length content' - paddinglength - digestSize + let (content, mac, padding) = fromJust "p3" $ partition3 content' (contentlen, digestSize, paddinglength) + return $ CipherData + { cipherDataContent = content + , cipherDataMAC = Just mac + , cipherDataPadding = Just padding + } + BulkStreamF initF _ decryptF -> do + let iv = cstIV cst + let (content', newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent + {- update Ctx -} + let contentlen = B.length content' - digestSize + let (content, mac, _) = fromJust "p3" $ partition3 content' (contentlen, digestSize, 0) + put $ st { stRxCryptState = Just $ cst { cstIV = newiv } } + return $ CipherData + { cipherDataContent = content + , cipherDataMAC = Just mac + , cipherDataPadding = Nothing + } + diff --git a/Network/TLS/Record/Engage.hs b/Network/TLS/Record/Engage.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/Engage.hs @@ -0,0 +1,89 @@ +-- | +-- Module : Network.TLS.Record.Engage +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Engage a record into the Record layer. +-- The record is compressed, added some integrity field, then encrypted. +-- +module Network.TLS.Record.Engage + ( engageRecord + ) where + +import Control.Monad.State + +import Network.TLS.Cap +import Network.TLS.State +import Network.TLS.Record.Types +import Network.TLS.Cipher +import Network.TLS.Compression +import Network.TLS.Util +import Data.ByteString (ByteString) +import qualified Data.ByteString as B + +engageRecord :: Record Plaintext -> TLSSt (Record Ciphertext) +engageRecord = compressRecord >=> encryptRecord + +compressRecord :: Record Plaintext -> TLSSt (Record Compressed) +compressRecord record = + onRecordFragment record $ fragmentCompress $ \bytes -> do + withCompression $ compressionDeflate bytes + +{- + - when Tx Encrypted is set, we pass the data through encryptContent, otherwise + - we just return the packet + -} +encryptRecord :: Record Compressed -> TLSSt (Record Ciphertext) +encryptRecord record = onRecordFragment record $ fragmentCipher $ \bytes -> do + st <- get + if stTxEncrypted st + then encryptContent record bytes + else return bytes + +encryptContent :: Record Compressed -> ByteString -> TLSSt ByteString +encryptContent record content = do + digest <- makeDigest True (recordToHeader record) content + encryptData $ B.concat [content, digest] + +encryptData :: ByteString -> TLSSt ByteString +encryptData content = do + st <- get + + let cipher = fromJust "cipher" $ stCipher st + let bulk = cipherBulk cipher + let cst = fromJust "tx crypt state" $ stTxCryptState st + + let writekey = cstKey cst + + case bulkF bulk of + BulkNoneF -> return content + BulkBlockF encrypt _ -> do + let blockSize = fromIntegral $ bulkBlockSize bulk + let msg_len = B.length content + let padding = if blockSize > 0 + then + let padbyte = blockSize - (msg_len `mod` blockSize) in + let padbyte' = if padbyte == 0 then blockSize else padbyte in + B.replicate padbyte' (fromIntegral (padbyte' - 1)) + else + B.empty + + -- before TLS 1.1, the block cipher IV is made of the residual of the previous block. + iv <- if hasExplicitBlockIV $ stVersion st + then genTLSRandom (bulkIVSize bulk) + else return $ cstIV cst + let e = encrypt writekey iv (B.concat [ content, padding ]) + if hasExplicitBlockIV $ stVersion st + then return $ B.concat [iv,e] + else do + let newiv = fromJust "new iv" $ takelast (bulkIVSize bulk) e + put $ st { stTxCryptState = Just $ cst { cstIV = newiv } } + return e + BulkStreamF initF encryptF _ -> do + let iv = cstIV cst + let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content + put $ st { stTxCryptState = Just $ cst { cstIV = newiv } } + return e + diff --git a/Network/TLS/Record/Types.hs b/Network/TLS/Record/Types.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/Types.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE EmptyDataDecls #-} +-- | +-- Module : Network.TLS.Record.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- The Record Protocol takes messages to be transmitted, fragments the +-- data into manageable blocks, optionally compresses the data, applies +-- a MAC, encrypts, and transmits the result. Received data is +-- decrypted, verified, decompressed, reassembled, and then delivered to +-- higher-level clients. +-- +module Network.TLS.Record.Types + ( Header(..) + , ProtocolType(..) + , packetType + -- * TLS Records + , Record(..) + -- * TLS Record fragment and constructors + , Fragment + , fragmentPlaintext + , fragmentCiphertext + , fragmentGetBytes + , Plaintext + , Compressed + , Ciphertext + -- * manipulate record + , onRecordFragment + , fragmentCompress + , fragmentCipher + , fragmentUncipher + , fragmentUncompress + -- * serialize record + , rawToRecord + , recordToRaw + , recordToHeader + ) where + +import Network.TLS.Struct +import Network.TLS.State +import qualified Data.ByteString as B +import Control.Applicative ((<$>)) + +-- | Represent a TLS record. +data Record a = Record !ProtocolType !Version !(Fragment a) deriving (Show,Eq) + +newtype Fragment a = Fragment Bytes deriving (Show,Eq) + +data Plaintext +data Compressed +data Ciphertext + +fragmentPlaintext :: Bytes -> Fragment Plaintext +fragmentPlaintext bytes = Fragment bytes + +fragmentCiphertext :: Bytes -> Fragment Ciphertext +fragmentCiphertext bytes = Fragment bytes + +fragmentGetBytes :: Fragment a -> Bytes +fragmentGetBytes (Fragment bytes) = bytes + +onRecordFragment :: Record a -> (Fragment a -> TLSSt (Fragment b)) -> TLSSt (Record b) +onRecordFragment (Record pt ver frag) f = Record pt ver <$> f frag + +fragmentMap :: (Bytes -> TLSSt Bytes) -> Fragment a -> TLSSt (Fragment b) +fragmentMap f (Fragment b) = Fragment <$> f b + +-- | turn a plaintext record into a compressed record using the compression function supplied +fragmentCompress :: (Bytes -> TLSSt Bytes) -> Fragment Plaintext -> TLSSt (Fragment Compressed) +fragmentCompress f = fragmentMap f + +-- | turn a compressed record into a ciphertext record using the cipher function supplied +fragmentCipher :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Ciphertext) +fragmentCipher f = fragmentMap f + +-- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied +fragmentUncipher :: (Bytes -> TLSSt Bytes) -> Fragment Ciphertext -> TLSSt (Fragment Compressed) +fragmentUncipher f = fragmentMap f + +-- | turn a compressed fragment into a plaintext fragment using the decompression function supplied +fragmentUncompress :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Plaintext) +fragmentUncompress f = fragmentMap f + +-- | turn a record into an header and bytes +recordToRaw :: Record a -> (Header, Bytes) +recordToRaw (Record pt ver (Fragment bytes)) = (Header pt ver (fromIntegral $ B.length bytes), bytes) + +-- | turn a header and a fragment into a record +rawToRecord :: Header -> Fragment a -> Record a +rawToRecord (Header pt ver _) fragment = Record pt ver fragment + +-- | turn a record into a header +recordToHeader :: Record a -> Header +recordToHeader (Record pt ver (Fragment bytes)) = Header pt ver (fromIntegral $ B.length bytes) diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs --- a/Network/TLS/Sending.hs +++ b/Network/TLS/Sending.hs @@ -8,9 +8,7 @@ -- the Sending module contains calls related to marshalling packets according -- to the TLS state -- -module Network.TLS.Sending ( - writePacket - ) where +module Network.TLS.Sending (writePacket, encryptRSA) where import Control.Applicative ((<$>)) import Control.Monad.State @@ -19,14 +17,10 @@ import qualified Data.ByteString as B import Network.TLS.Util -import Network.TLS.Cap -import Network.TLS.Wire import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet import Network.TLS.State -import Network.TLS.Cipher -import Network.TLS.Compression import Network.TLS.Crypto {- @@ -47,23 +41,7 @@ when (ty == ProtocolType_Handshake) (updateHandshakeDigest $ fragmentGetBytes fragment) return record -compressRecord :: Record Plaintext -> TLSSt (Record Compressed) -compressRecord record = - onRecordFragment record $ fragmentCompress $ \bytes -> do - withCompression $ compressionDeflate bytes - {- - - when Tx Encrypted is set, we pass the data through encryptContent, otherwise - - we just return the packet - -} -encryptRecord :: Record Compressed -> TLSSt (Record Ciphertext) -encryptRecord record = onRecordFragment record $ fragmentCipher $ \bytes -> do - st <- get - if stTxEncrypted st - then encryptContent record bytes - else return bytes - -{- - ChangeCipherSpec state change need to be handled after encryption otherwise - its own packet would be encrypted with the new context, instead of beeing sent - under the current context @@ -86,10 +64,8 @@ preProcessPacket :: Packet -> TLSSt () preProcessPacket (Alert _) = return () preProcessPacket (AppData _) = return () -preProcessPacket (ChangeCipherSpec) = updateStatusCC True >> return () -- FIXME don't ignore this error just in case +preProcessPacket (ChangeCipherSpec) = return () preProcessPacket (Handshake hss) = forM_ hss $ \hs -> do - -- FIXME don't ignore this error - _ <- updateStatusHs (typeOfHandshake hs) case hs of Finished fdata -> updateVerifiedData True fdata _ -> return () @@ -101,7 +77,7 @@ writePacket :: Packet -> TLSSt ByteString writePacket pkt = do preProcessPacket pkt - makeRecord pkt >>= processRecord >>= compressRecord >>= encryptRecord >>= postprocessRecord >>= encodeRecord + makeRecord pkt >>= processRecord >>= engageRecord >>= postprocessRecord >>= encodeRecord {------------------------------------------------------------------------------} {- SENDING Helpers -} @@ -118,68 +94,8 @@ Left err -> fail ("rsa encrypt failed: " ++ show err) Right (econtent, rng') -> put (st { stRandomGen = rng' }) >> return econtent -encryptContent :: Record Compressed -> ByteString -> TLSSt ByteString -encryptContent record content = do - digest <- makeDigest True (recordToHeader record) content - encryptData $ B.concat [content, digest] - -encryptData :: ByteString -> TLSSt ByteString -encryptData content = do - st <- get - - let cipher = fromJust "cipher" $ stCipher st - let bulk = cipherBulk cipher - let cst = fromJust "tx crypt state" $ stTxCryptState st - - let writekey = cstKey cst - - case bulkF bulk of - BulkNoneF -> return content - BulkBlockF encrypt _ -> do - let blockSize = fromIntegral $ bulkBlockSize bulk - let msg_len = B.length content - let padding = if blockSize > 0 - then - let padbyte = blockSize - (msg_len `mod` blockSize) in - let padbyte' = if padbyte == 0 then blockSize else padbyte in - B.replicate padbyte' (fromIntegral (padbyte' - 1)) - else - B.empty - - -- before TLS 1.1, the block cipher IV is made of the residual of the previous block. - iv <- if hasExplicitBlockIV $ stVersion st - then genTLSRandom (bulkIVSize bulk) - else return $ cstIV cst - let e = encrypt writekey iv (B.concat [ content, padding ]) - if hasExplicitBlockIV $ stVersion st - then return $ B.concat [iv,e] - else do - let newiv = fromJust "new iv" $ takelast (bulkIVSize bulk) e - put $ st { stTxCryptState = Just $ cst { cstIV = newiv } } - return e - BulkStreamF initF encryptF _ -> do - let iv = cstIV cst - let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content - put $ st { stTxCryptState = Just $ cst { cstIV = newiv } } - return e - writePacketContent :: Packet -> TLSSt ByteString -writePacketContent (Handshake hss) = return . B.concat =<< mapM makeContent hss where - makeContent hs@(ClientKeyXchg _ _) = do - ver <- get >>= return . stVersion - let premastersecret = runPut $ encodeHandshakeContent hs - setMasterSecret premastersecret - econtent <- encryptRSA premastersecret - - let extralength = - if ver < TLS10 - then B.empty - else runPut $ putWord16 $ fromIntegral $ B.length econtent - let hdr = runPut $ encodeHandshakeHeader (typeOfHandshake hs) - (fromIntegral (B.length econtent + B.length extralength)) - return $ B.concat [hdr, extralength, econtent] - makeContent hs = return $ encodeHandshakes [hs] - +writePacketContent (Handshake hss) = return $ encodeHandshakes hss writePacketContent (Alert a) = return $ encodeAlerts a writePacketContent (ChangeCipherSpec) = return $ encodeChangeCipherSpec writePacketContent (AppData x) = return x diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs --- a/Network/TLS/State.hs +++ b/Network/TLS/State.hs @@ -16,15 +16,11 @@ , TLSHandshakeState(..) , TLSCryptState(..) , TLSMacState(..) - , TLSStatus(..) - , HandshakeStatus(..) , newTLSState , genTLSRandom , withTLSRNG , withCompression , assert -- FIXME move somewhere else (Internal.hs ?) - , updateStatusHs - , updateStatusCC , updateVerifiedData , finishHandshakeTypeMaterial , finishHandshakeMaterial @@ -45,13 +41,11 @@ , isClientContext , startHandshakeClient , updateHandshakeDigest - , updateHandshakeDigestSplitted , getHandshakeDigest , endHandshake ) where import Data.Word -import Data.List (find) import Data.Maybe (isNothing) import Network.TLS.Util import Network.TLS.Struct @@ -72,28 +66,6 @@ assert fctname list = forM_ list $ \ (name, assumption) -> do when assumption $ fail (fctname ++ ": assumption about " ++ name ++ " failed") -data HandshakeStatus = - HsStatusClientHello - | HsStatusServerHello - | HsStatusServerCertificate - | HsStatusServerKeyXchg - | HsStatusServerCertificateReq - | HsStatusServerHelloDone - | HsStatusClientCertificate - | HsStatusClientKeyXchg - | HsStatusClientCertificateVerify - | HsStatusClientChangeCipher - | HsStatusClientFinished - | HsStatusServerChangeCipher - deriving (Show,Eq) - -data TLSStatus = - StatusInit - | StatusHandshakeReq - | StatusHandshake HandshakeStatus - | StatusOk - deriving (Show,Eq) - data TLSCryptState = TLSCryptState { cstKey :: !Bytes , cstIV :: !Bytes @@ -122,7 +94,6 @@ data TLSState = TLSState { stClientContext :: Bool , stVersion :: !Version - , stStatus :: !TLSStatus , stHandshake :: !(Maybe TLSHandshakeState) , stTxEncrypted :: Bool , stRxEncrypted :: Bool @@ -155,7 +126,6 @@ newTLSState rng = TLSState { stClientContext = False , stVersion = TLS10 - , stStatus = StatusInit , stHandshake = Nothing , stTxEncrypted = False , stRxEncrypted = False @@ -210,68 +180,6 @@ modify (\_ -> if w then st { stTxMacState = Just newms } else st { stRxMacState = Just newms }) return digest -hsStatusTransitionTable :: [ (HandshakeType, TLSStatus, [ TLSStatus ]) ] -hsStatusTransitionTable = - [ (HandshakeType_HelloRequest, StatusHandshakeReq, - [ StatusOk ]) - , (HandshakeType_ClientHello, StatusHandshake HsStatusClientHello, - [ StatusInit, StatusHandshakeReq ]) - , (HandshakeType_ServerHello, StatusHandshake HsStatusServerHello, - [ StatusHandshake HsStatusClientHello ]) - , (HandshakeType_Certificate, StatusHandshake HsStatusServerCertificate, - [ StatusHandshake HsStatusServerHello ]) - , (HandshakeType_ServerKeyXchg, StatusHandshake HsStatusServerKeyXchg, - [ StatusHandshake HsStatusServerHello - , StatusHandshake HsStatusServerCertificate ]) - , (HandshakeType_CertRequest, StatusHandshake HsStatusServerCertificateReq, - [ StatusHandshake HsStatusServerHello - , StatusHandshake HsStatusServerCertificate - , StatusHandshake HsStatusServerKeyXchg ]) - , (HandshakeType_ServerHelloDone, StatusHandshake HsStatusServerHelloDone, - [ StatusHandshake HsStatusServerHello - , StatusHandshake HsStatusServerCertificate - , StatusHandshake HsStatusServerKeyXchg - , StatusHandshake HsStatusServerCertificateReq ]) - , (HandshakeType_Certificate, StatusHandshake HsStatusClientCertificate, - [ StatusHandshake HsStatusServerHelloDone ]) - , (HandshakeType_ClientKeyXchg, StatusHandshake HsStatusClientKeyXchg, - [ StatusHandshake HsStatusServerHelloDone - , StatusHandshake HsStatusClientCertificate ]) - , (HandshakeType_CertVerify, StatusHandshake HsStatusClientCertificateVerify, - [ StatusHandshake HsStatusClientKeyXchg ]) - , (HandshakeType_Finished, StatusHandshake HsStatusClientFinished, - [ StatusHandshake HsStatusClientChangeCipher ]) - , (HandshakeType_Finished, StatusOk, - [ StatusHandshake HsStatusServerChangeCipher ]) - ] - -updateStatus :: MonadState TLSState m => TLSStatus -> m () -updateStatus x = modify (\st -> st { stStatus = x }) - -updateStatusHs :: MonadState TLSState m => HandshakeType -> m (Maybe TLSError) -updateStatusHs ty = do - status <- return . stStatus =<< get - ns <- return . transition . stStatus =<< get - case ns of - Nothing -> return $ Just $ Error_Packet_unexpected (show status) ("handshake:" ++ show ty) - Just (_,x,_) -> updateStatus x >> return Nothing - where - edgeEq cur (ety, _, aprevs) = ty == ety && (maybe False (const True) $ find (== cur) aprevs) - transition currentStatus = find (edgeEq currentStatus) hsStatusTransitionTable - -updateStatusCC :: MonadState TLSState m => Bool -> m (Maybe TLSError) -updateStatusCC sending = do - status <- return . stStatus =<< get - cc <- isClientContext - let x = case (cc /= sending, status) of - (False, StatusHandshake HsStatusClientKeyXchg) -> Just (StatusHandshake HsStatusClientChangeCipher) - (False, StatusHandshake HsStatusClientCertificateVerify) -> Just (StatusHandshake HsStatusClientChangeCipher) - (True, StatusHandshake HsStatusClientFinished) -> Just (StatusHandshake HsStatusServerChangeCipher) - _ -> Nothing - case x of - Just newstatus -> updateStatus newstatus >> return Nothing - Nothing -> return $ Just $ Error_Packet_unexpected (show status) ("Client Context: " ++ show cc) - updateVerifiedData :: MonadState TLSState m => Bool -> Bytes -> m () updateVerifiedData sending bs = do cc <- isClientContext @@ -407,11 +315,6 @@ updateHandshakeDigest :: MonadState TLSState m => Bytes -> m () updateHandshakeDigest content = updateHandshake "update digest" $ \hs -> hs { hstHandshakeDigest = hashUpdate (hstHandshakeDigest hs) content } - -updateHandshakeDigestSplitted :: MonadState TLSState m => HandshakeType -> Bytes -> m () -updateHandshakeDigestSplitted ty bytes = updateHandshakeDigest $ B.concat [hdr, bytes] - where - hdr = runPut $ encodeHandshakeHeader ty (B.length bytes) getHandshakeDigest :: MonadState TLSState m => Bool -> m Bytes getHandshakeDigest client = do diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -28,7 +28,6 @@ , Header(..) , ServerRandom(..) , ClientRandom(..) - , ClientKeyData(..) , serverRandom , clientRandom , FinishedData @@ -112,6 +111,7 @@ Error_Misc String -- ^ mainly for instance of Error | Error_Protocol (String, Bool, AlertDescription) | Error_Certificate String + | Error_HandshakePolicy String -- ^ handshake policy failed. | Error_Random String | Error_EOF | Error_Packet String @@ -140,7 +140,6 @@ newtype ServerRandom = ServerRandom Bytes deriving (Show, Eq) newtype ClientRandom = ClientRandom Bytes deriving (Show, Eq) -newtype ClientKeyData = ClientKeyData Bytes deriving (Show, Eq) newtype Session = Session (Maybe Bytes) deriving (Show, Eq) type CipherID = Word16 type CompressionID = Word8 @@ -227,7 +226,7 @@ | Certificates [X509] | HelloRequest | ServerHelloDone - | ClientKeyXchg Version ClientKeyData + | ClientKeyXchg Bytes | ServerKeyXchg ServerKeyXchgAlgorithmData | CertRequest [CertificateType] (Maybe [ (HashAlgorithm, SignatureAlgorithm) ]) [Word8] | CertVerify [Word8] @@ -246,7 +245,7 @@ typeOfHandshake (Certificates _) = HandshakeType_Certificate typeOfHandshake (HelloRequest) = HandshakeType_HelloRequest typeOfHandshake (ServerHelloDone) = HandshakeType_ServerHelloDone -typeOfHandshake (ClientKeyXchg _ _) = HandshakeType_ClientKeyXchg +typeOfHandshake (ClientKeyXchg _) = HandshakeType_ClientKeyXchg typeOfHandshake (ServerKeyXchg _) = HandshakeType_ServerKeyXchg typeOfHandshake (CertRequest _ _ _) = HandshakeType_CertRequest typeOfHandshake (CertVerify _) = HandshakeType_CertVerify diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -1,23 +1,29 @@ {-# LANGUAGE CPP #-} import Test.QuickCheck -import Test.QuickCheck.Test +import Test.QuickCheck.Monadic import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) ---import Tests.Certificate +import Tests.Certificate +import Tests.PipeChan +import Tests.Connection import Data.Word -import Data.Certificate.X509 import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Network.TLS.Core import Network.TLS.Cipher import Network.TLS.Struct import Network.TLS.Packet -import Control.Monad import Control.Applicative -import System.IO +import Control.Concurrent +import Control.Exception (throw, catch, SomeException) +import Control.Monad +import Prelude hiding (catch) + genByteString :: Int -> Gen B.ByteString genByteString i = B.pack <$> vector i @@ -49,15 +55,12 @@ instance Arbitrary ServerRandom where arbitrary = ServerRandom <$> (genByteString 32) -instance Arbitrary ClientKeyData where - arbitrary = ClientKeyData <$> (genByteString 46) - instance Arbitrary Session where arbitrary = do i <- choose (1,2) :: Gen Int case i of - 1 -> return $ Session Nothing 2 -> liftM (Session . Just) (genByteString 32) + _ -> return $ Session Nothing arbitraryCiphersIDs :: Gen [Word16] arbitraryCiphersIDs = choose (0,200) >>= vector @@ -88,10 +91,10 @@ <*> arbitrary <*> arbitrary <*> (return []) - --, liftM Certificates (resize 2 $ listOf $ arbitraryX509 pubkey) + , liftM Certificates (resize 2 $ listOf $ arbitraryX509) , pure HelloRequest , pure ServerHelloDone - , ClientKeyXchg <$> arbitrary <*> arbitrary + , ClientKeyXchg <$> genByteString 48 --, liftM ServerKeyXchg --, liftM3 CertRequest arbitrary (return Nothing) (return []) --, liftM CertVerify (return []) @@ -100,15 +103,95 @@ {- quickcheck property -} +prop_header_marshalling_id :: Header -> Bool prop_header_marshalling_id x = (decodeHeader $ encodeHeader x) == Right x + +prop_handshake_marshalling_id :: Handshake -> Bool prop_handshake_marshalling_id x = (decodeHs $ encodeHandshake x) == Right x where decodeHs b = either (Left . id) (uncurry (decodeHandshake cp) . head) $ decodeHandshakes b cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = CipherKeyExchange_RSA } -tests = testGroup "Marshalling" - [ testProperty "Header" prop_header_marshalling_id - , testProperty "Handshake" prop_handshake_marshalling_id +prop_pipe_work :: PropertyM IO () +prop_pipe_work = do + pipe <- run newPipe + _ <- run (runPipe pipe) + + let bSize = 16 + n <- pick (choose (1, 32)) + + let d1 = B.replicate (bSize * n) 40 + let d2 = B.replicate (bSize * n) 45 + + d1' <- run (writePipeA pipe d1 >> readPipeB pipe (B.length d1)) + d1 `assertEq` d1' + + d2' <- run (writePipeB pipe d2 >> readPipeA pipe (B.length d2)) + d2 `assertEq` d2' + + return () + +prop_handshake_initiate :: PropertyM IO () +prop_handshake_initiate = do + -- initial setup + pipe <- run newPipe + _ <- run (runPipe pipe) + startQueue <- run newChan + resultQueue <- run newChan + + params <- pick arbitraryPairParams + (cCtx, sCtx) <- run $ newPairContext pipe params + + _ <- run $ forkIO $ catch (tlsServer sCtx resultQueue) (printAndRaise "server") + _ <- run $ forkIO $ catch (tlsClient startQueue cCtx) (printAndRaise "client") + + {- the test involves writing data on one side of the data "pipe" and + - then checking we received them on the other side of the data "pipe" -} + d <- L.pack <$> pick (someWords8 256) + run $ writeChan startQueue d + + dres <- run $ readChan resultQueue + d `assertEq` dres + + return () + where + printAndRaise :: String -> SomeException -> IO () + printAndRaise s e = putStrLn (s ++ " exception: " ++ show e) >> throw e + + someWords8 :: Int -> Gen [Word8] + someWords8 i = replicateM i (fromIntegral <$> (choose (0,255) :: Gen Int)) + + tlsServer ctx queue = do + hSuccess <- handshake ctx + unless hSuccess $ fail "handshake failed on server side" + d <- recvData ctx + writeChan queue d + return () + tlsClient queue ctx = do + hSuccess <- handshake ctx + unless hSuccess $ fail "handshake failed on client side" + d <- readChan queue + sendData ctx d + bye ctx + return () + +assertEq :: (Show a, Monad m, Eq a) => a -> a -> m () +assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected) + +main :: IO () +main = defaultMain + [ tests_marshalling + , tests_handshake ] + where + -- lowlevel tests to check the packet marshalling. + tests_marshalling = testGroup "Marshalling" + [ testProperty "Header" prop_header_marshalling_id + , testProperty "Handshake" prop_handshake_marshalling_id + ] -main = defaultMain [ tests ] + -- high level tests between a client and server with fake ciphers. + tests_handshake = testGroup "Handshakes" + [ testProperty "setup" (monadicIO prop_pipe_work) + , testProperty "initiate" (monadicIO prop_handshake_initiate) + ] diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,5 +1,5 @@ Name: tls -Version: 0.8.2 +Version: 0.8.3 Description: Native Haskell TLS and SSL protocol implementation for server and client. . @@ -49,11 +49,15 @@ Network.TLS.Internal other-modules: Network.TLS.Cap Network.TLS.Struct - Network.TLS.MAC Network.TLS.Core Network.TLS.Crypto + Network.TLS.MAC + Network.TLS.Measurement Network.TLS.Packet Network.TLS.Record + Network.TLS.Record.Types + Network.TLS.Record.Engage + Network.TLS.Record.Disengage Network.TLS.State Network.TLS.Sending Network.TLS.Receiving @@ -70,6 +74,9 @@ , test-framework , test-framework-quickcheck2 , bytestring + , time + , cprng-aes + , cryptocipher >= 0.3.0 else Buildable: False ghc-options: -Wall -fhpc