diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -11,7 +11,6 @@ -- * Context configuration TLSParams(..) , TLSLogging(..) - , Measurement(..) , TLSCertificateUsage(..) , TLSCertificateRejectReason(..) , defaultLogging @@ -50,7 +49,6 @@ 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) @@ -98,7 +96,6 @@ , 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. } @@ -120,7 +117,6 @@ , pUseSecureRenegotiation = True , pCertificates = [] , pLogging = defaultLogging - , onHandshake = (\_ -> return True) , onCertificatesRecv = (\_ -> return CertificateUsageAccept) } @@ -139,27 +135,20 @@ { 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 = updateMeasure c (addBytesSent $ B.length b) >> (ctxConnectionSend c) b +connectionSend c b = (ctxConnectionSend c) b connectionRecv :: TLSCtx c -> Int -> IO Bytes -connectionRecv c sz = updateMeasure c (addBytesReceived sz) >> (ctxConnectionRecv c) sz +connectionRecv c sz = (ctxConnectionRecv c) sz ctxEOF :: MonadIO m => TLSCtx a -> m Bool ctxEOF ctx = liftIO (readIORef $ ctxEOF_ ctx) @@ -171,13 +160,11 @@ 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 - , ctxMeasurement = stats - , ctxEOF_ = eof + { ctxConnection = c + , ctxParams = params + , ctxState = stvar + , ctxEOF_ = eof , ctxConnectionFlush = flushF , ctxConnectionSend = sendF , ctxConnectionRecv = recvF @@ -210,6 +197,11 @@ 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)] @@ -227,67 +219,33 @@ 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 - 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 - -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 + 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 -unexpected :: MonadIO m => String -> Maybe [Char] -> m a -unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) +recvPacketSuccess :: MonadIO m => TLSCtx c -> m () +recvPacketSuccess ctx = do + pkt <- recvPacket ctx + case pkt of + Left err -> throwCore err + Right _ -> return () -- | Send one packet to the context sendPacket :: MonadIO m => TLSCtx c -> Packet -> m () @@ -333,14 +291,41 @@ -- values intertwined with response from the server. handshakeClient :: MonadIO m => TLSCtx c -> m () handshakeClient ctx = do - updateMeasure ctx incrementNbHandshakes - sendClientHello - recvServerHello - sendCertificate >> sendClientKeyXchg >> sendCertificateVerify - sendChangeCipherAndFinish ctx True - recvChangeCipherAndFinish - updateMeasure ctx resetBytesCounters + -- 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 () + where params = ctxParams ctx ver = pConnectVersion params @@ -353,36 +338,10 @@ then usingState_ ctx (getVerifiedData True) >>= \vd -> return [ (0xff01, encodeExtSecureRenegotiation vd Nothing) ] else 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 - ] - - 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) + processServerInfo (Handshake hss) = mapM_ processHandshake hss + processServerInfo _ = return () - processServerHello :: MonadIO m => Handshake -> m (RecvState m) - processServerHello (ServerHello rver _ _ cipher _ _) = do + processHandshake (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) @@ -390,39 +349,22 @@ 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") - processCertificate :: MonadIO m => Handshake -> m (RecvState m) - processCertificate (Certificates certs) = do + processHandshake (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 - processServerKeyExchange :: MonadIO m => Handshake -> m (RecvState m) - processServerKeyExchange (ServerKeyXchg _) = return $ RecvStateHandshake processCertificateRequest - processServerKeyExchange p = processCertificateRequest p - - processCertificateRequest (CertRequest _ _ _) = do + processHandshake (CertRequest _ _ _) = do + return () --modify (\sc -> sc { scCertRequested = True }) - return $ RecvStateHandshake processServerHelloDone - processCertificateRequest p = processServerHelloDone p - - processServerHelloDone ServerHelloDone = return RecvStateDone - processServerHelloDone p = unexpected (show p) (Just "server hello data") + processHandshake _ = return () sendClientKeyXchg = do - encryptedPreMaster <- usingState_ ctx $ do - xver <- stVersion <$> get - prerand <- genTLSRandom 46 - let premaster = encodePreMasterSecret xver prerand - setMasterSecret premaster - encryptRSA premaster - sendPacket ctx $ Handshake [ClientKeyXchg encryptedPreMaster] + prerand <- getStateRNG ctx 46 >>= return . ClientKeyData + sendPacket ctx $ Handshake [ClientKeyXchg ver prerand] -- on certificate reject, throw an exception with the proper protocol alert error. certificateRejected CertificateRejectRevoked = @@ -435,14 +377,8 @@ throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown) handshakeServerWith :: MonadIO m => TLSCtx c -> Handshake -> m () -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 - +handshakeServerWith ctx (ClientHello ver _ _ ciphers compressions _) = do -- 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) @@ -461,10 +397,15 @@ liftIO $ connectionFlush ctx -- Receive client info until client Finished. - recvClientData - sendChangeCipherAndFinish ctx False + whileStatus ctx (/= (StatusHandshake HsStatusClientFinished)) (recvPacketSuccess ctx) - updateMeasure ctx resetBytesCounters + sendPacket ctx ChangeCipherSpec + + -- Send Finish + cf <- usingState_ ctx $ getHandshakeDigest False + sendPacket ctx (Handshake [Finished cf]) + + liftIO $ connectionFlush ctx return () where params = ctxParams ctx @@ -476,25 +417,6 @@ 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 @@ -534,7 +456,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 @@ -552,7 +474,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 $ show e) + Nothing -> sendPacket ctx (errorToAlert $ Error_Misc "") -- | 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 deleted file mode 100644 --- a/Network/TLS/Measurement.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | --- 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,9 +35,6 @@ , decodeChangeCipherSpec , encodeChangeCipherSpec - , decodePreMasterSecret - , encodePreMasterSecret - -- * marshall extensions , decodeExtSecureRenegotiation , encodeExtSecureRenegotiation @@ -250,7 +247,10 @@ return $ CertVerify [] decodeClientKeyXchg :: Get Handshake -decodeClientKeyXchg = ClientKeyXchg <$> (remaining >>= getBytes) +decodeClientKeyXchg = do + ver <- getVersion + ran <- getClientKeyData46 + return $ ClientKeyXchg ver ran os2ip :: ByteString -> Integer os2ip = B.foldl' (\a b -> (256 * a) .|. (fromIntegral b)) 0 @@ -269,20 +269,18 @@ return $ ServerRSAParams { rsa_modulus = os2ip modulus, rsa_exponent = os2ip expo } decodeServerKeyXchg :: CurrentParams -> Get Handshake -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 +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) encodeHandshake :: Handshake -> ByteString encodeHandshake o = @@ -319,8 +317,9 @@ certbs = runPut $ mapM_ putCert certs len = fromIntegral $ B.length certbs -encodeHandshakeContent (ClientKeyXchg content) = do - putBytes content +encodeHandshakeContent (ClientKeyXchg version random) = do + putVersion version + putClientKeyData46 random encodeHandshakeContent (ServerKeyXchg _) = do -- FIXME @@ -359,6 +358,12 @@ 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 @@ -435,14 +440,6 @@ 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,20 +8,26 @@ -- the Receiving module contains calls related to unmarshalling packets according -- to the TLS state -- -module Network.TLS.Receiving (processHandshake, processPacket) where +module Network.TLS.Receiving ( + readPacket + ) 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 @@ -29,6 +35,25 @@ 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 @@ -36,26 +61,40 @@ 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 } - 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 + 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 clientmode <- isClientContext case hs of ClientHello cver ran _ _ _ ex -> unless clientmode $ do @@ -69,11 +108,11 @@ setServerRandom ran setVersion sver Certificates certs -> when clientmode $ do processCertificates certs - ClientKeyXchg content -> unless clientmode $ do - processClientKeyXchg content + ClientKeyXchg cver _ -> unless clientmode $ do + processClientKeyXchg cver content Finished fdata -> processClientFinished fdata _ -> return () - when (finishHandshakeTypeMaterial $ typeOfHandshake hs) (updateHandshakeDigest $ encodeHandshake hs) + return hs where -- secure renegotiation processClientExtension (0xff01, content) = do @@ -96,24 +135,20 @@ 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 econtent + return $ kxDecrypt rsapriv (if ver < TLS10 then econtent else B.drop 2 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 :: ByteString -> TLSSt () -processClientKeyXchg encryptedPremaster = do +processClientKeyXchg :: Version -> ByteString -> TLSSt () +processClientKeyXchg ver content = do expectedVer <- hstClientVersion . fromJust "handshake" . stHandshake <$> get - 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 + setMasterSecret =<< + if expectedVer /= ver + then genTLSRandom (fromIntegral $ B.length content) + else return content processClientFinished :: FinishedData -> TLSSt () processClientFinished fdata = do @@ -123,6 +158,94 @@ 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,3 +1,4 @@ +{-# LANGUAGE EmptyDataDecls #-} -- | -- Module : Network.TLS.Record -- License : BSD-style @@ -12,21 +13,84 @@ -- higher-level clients. -- module Network.TLS.Record - ( Record(..) + ( Header(..) + , ProtocolType(..) + , packetType + -- * TLS Records + , Record(..) + -- * TLS Record fragment and constructors , Fragment - , fragmentGetBytes , fragmentPlaintext , fragmentCiphertext - , recordToRaw - , rawToRecord - , recordToHeader + , fragmentGetBytes , Plaintext , Compressed , Ciphertext - , engageRecord - , disengageRecord + -- * manipulate record + , onRecordFragment + , fragmentCompress + , fragmentCipher + , fragmentUncipher + , fragmentUncompress + -- * serialize record + , rawToRecord + , recordToRaw + , recordToHeader ) where -import Network.TLS.Record.Types -import Network.TLS.Record.Engage -import Network.TLS.Record.Disengage +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/Record/Disengage.hs b/Network/TLS/Record/Disengage.hs deleted file mode 100644 --- a/Network/TLS/Record/Disengage.hs +++ /dev/null @@ -1,117 +0,0 @@ --- | --- 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 deleted file mode 100644 --- a/Network/TLS/Record/Engage.hs +++ /dev/null @@ -1,89 +0,0 @@ --- | --- 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 deleted file mode 100644 --- a/Network/TLS/Record/Types.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# 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,7 +8,9 @@ -- the Sending module contains calls related to marshalling packets according -- to the TLS state -- -module Network.TLS.Sending (writePacket, encryptRSA) where +module Network.TLS.Sending ( + writePacket + ) where import Control.Applicative ((<$>)) import Control.Monad.State @@ -17,10 +19,14 @@ 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 {- @@ -41,7 +47,23 @@ 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 @@ -64,8 +86,10 @@ preProcessPacket :: Packet -> TLSSt () preProcessPacket (Alert _) = return () preProcessPacket (AppData _) = return () -preProcessPacket (ChangeCipherSpec) = return () +preProcessPacket (ChangeCipherSpec) = updateStatusCC True >> return () -- FIXME don't ignore this error just in case 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 () @@ -77,7 +101,7 @@ writePacket :: Packet -> TLSSt ByteString writePacket pkt = do preProcessPacket pkt - makeRecord pkt >>= processRecord >>= engageRecord >>= postprocessRecord >>= encodeRecord + makeRecord pkt >>= processRecord >>= compressRecord >>= encryptRecord >>= postprocessRecord >>= encodeRecord {------------------------------------------------------------------------------} {- SENDING Helpers -} @@ -94,8 +118,68 @@ 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 $ encodeHandshakes hss +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 (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,11 +16,15 @@ , TLSHandshakeState(..) , TLSCryptState(..) , TLSMacState(..) + , TLSStatus(..) + , HandshakeStatus(..) , newTLSState , genTLSRandom , withTLSRNG , withCompression , assert -- FIXME move somewhere else (Internal.hs ?) + , updateStatusHs + , updateStatusCC , updateVerifiedData , finishHandshakeTypeMaterial , finishHandshakeMaterial @@ -41,11 +45,13 @@ , 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 @@ -66,6 +72,28 @@ 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 @@ -94,6 +122,7 @@ data TLSState = TLSState { stClientContext :: Bool , stVersion :: !Version + , stStatus :: !TLSStatus , stHandshake :: !(Maybe TLSHandshakeState) , stTxEncrypted :: Bool , stRxEncrypted :: Bool @@ -126,6 +155,7 @@ newTLSState rng = TLSState { stClientContext = False , stVersion = TLS10 + , stStatus = StatusInit , stHandshake = Nothing , stTxEncrypted = False , stRxEncrypted = False @@ -180,6 +210,68 @@ 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 @@ -315,6 +407,11 @@ 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,6 +28,7 @@ , Header(..) , ServerRandom(..) , ClientRandom(..) + , ClientKeyData(..) , serverRandom , clientRandom , FinishedData @@ -111,7 +112,6 @@ 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,6 +140,7 @@ 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 @@ -226,7 +227,7 @@ | Certificates [X509] | HelloRequest | ServerHelloDone - | ClientKeyXchg Bytes + | ClientKeyXchg Version ClientKeyData | ServerKeyXchg ServerKeyXchgAlgorithmData | CertRequest [CertificateType] (Maybe [ (HashAlgorithm, SignatureAlgorithm) ]) [Word8] | CertVerify [Word8] @@ -245,7 +246,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,28 +1,22 @@ {-# LANGUAGE CPP #-} import Test.QuickCheck -import Test.QuickCheck.Monadic +import Test.QuickCheck.Test import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Tests.Certificate -import Tests.PipeChan -import Tests.Connection +--import Tests.Certificate 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.Applicative -import Control.Concurrent -import Control.Exception (throw, catch, SomeException) import Control.Monad - -import Prelude hiding (catch) +import Control.Applicative +import System.IO genByteString :: Int -> Gen B.ByteString genByteString i = B.pack <$> vector i @@ -55,12 +49,15 @@ 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 @@ -91,10 +88,10 @@ <*> arbitrary <*> arbitrary <*> (return []) - , liftM Certificates (resize 2 $ listOf $ arbitraryX509) + --, liftM Certificates (resize 2 $ listOf $ arbitraryX509 pubkey) , pure HelloRequest , pure ServerHelloDone - , ClientKeyXchg <$> genByteString 48 + , ClientKeyXchg <$> arbitrary <*> arbitrary --, liftM ServerKeyXchg --, liftM3 CertRequest arbitrary (return Nothing) (return []) --, liftM CertVerify (return []) @@ -103,95 +100,15 @@ {- 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 } -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 +tests = testGroup "Marshalling" + [ testProperty "Header" prop_header_marshalling_id + , testProperty "Handshake" prop_handshake_marshalling_id ] - where - -- lowlevel tests to check the packet marshalling. - tests_marshalling = testGroup "Marshalling" - [ testProperty "Header" prop_header_marshalling_id - , testProperty "Handshake" prop_handshake_marshalling_id - ] - -- 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) - ] +main = defaultMain [ tests ] diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,5 +1,5 @@ Name: tls -Version: 0.8.3 +Version: 0.8.3.1 Description: Native Haskell TLS and SSL protocol implementation for server and client. . @@ -49,15 +49,11 @@ 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 @@ -74,9 +70,6 @@ , test-framework , test-framework-quickcheck2 , bytestring - , time - , cprng-aes - , cryptocipher >= 0.3.0 else Buildable: False ghc-options: -Wall -fhpc