diff --git a/Network/TLS/Cipher.hs b/Network/TLS/Cipher.hs --- a/Network/TLS/Cipher.hs +++ b/Network/TLS/Cipher.hs @@ -23,7 +23,11 @@ import Data.Word import Network.TLS.Struct (Version(..)) -import Network.TLS.MAC + +import qualified Data.CryptoHash.SHA256 as SHA256 +import qualified Data.CryptoHash.SHA1 as SHA1 +import qualified Data.CryptoHash.MD5 as MD5 + import qualified Data.Vector.Unboxed as Vector (fromList, toList) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as B @@ -63,7 +67,7 @@ , cipherKeyBlockSize :: Word8 , cipherPaddingSize :: Word8 , cipherKeyExchange :: CipherKeyExchangeType - , cipherHMAC :: B.ByteString -> B.ByteString -> B.ByteString + , cipherMACHash :: B.ByteString -> B.ByteString , cipherF :: CipherTypeFunctions , cipherMinVer :: Maybe Version } @@ -174,7 +178,7 @@ , cipherIVSize = 0 , cipherKeyBlockSize = 0 , cipherPaddingSize = 0 - , cipherHMAC = (\_ _ -> B.empty) + , cipherMACHash = (const B.empty) , cipherKeyExchange = CipherKeyExchangeRSA , cipherF = CipherNoneF , cipherMinVer = Nothing @@ -189,7 +193,7 @@ , cipherIVSize = 0 , cipherKeyBlockSize = 2 * (16 + 16 + 0) , cipherPaddingSize = 0 - , cipherHMAC = hmacMD5 + , cipherMACHash = MD5.hash , cipherKeyExchange = CipherKeyExchangeRSA , cipherF = CipherStreamF initF_rc4 encryptF_rc4 decryptF_rc4 , cipherMinVer = Nothing @@ -204,7 +208,7 @@ , cipherIVSize = 0 , cipherKeyBlockSize = 2 * (20 + 16 + 0) , cipherPaddingSize = 0 - , cipherHMAC = hmacSHA1 + , cipherMACHash = SHA1.hash , cipherKeyExchange = CipherKeyExchangeRSA , cipherF = CipherStreamF initF_rc4 encryptF_rc4 decryptF_rc4 , cipherMinVer = Nothing @@ -219,7 +223,7 @@ , cipherIVSize = 16 , cipherKeyBlockSize = 2 * (20 + 16 + 16) , cipherPaddingSize = 16 - , cipherHMAC = hmacSHA1 + , cipherMACHash = SHA1.hash , cipherKeyExchange = CipherKeyExchangeRSA , cipherF = CipherBlockF aes128_cbc_encrypt aes128_cbc_decrypt , cipherMinVer = Just SSL3 @@ -234,7 +238,7 @@ , cipherIVSize = 16 , cipherKeyBlockSize = 2 * (20 + 32 + 16) , cipherPaddingSize = 16 - , cipherHMAC = hmacSHA1 + , cipherMACHash = SHA1.hash , cipherKeyExchange = CipherKeyExchangeRSA , cipherF = CipherBlockF aes256_cbc_encrypt aes256_cbc_decrypt , cipherMinVer = Just SSL3 @@ -249,7 +253,7 @@ , cipherIVSize = 16 , cipherKeyBlockSize = 2 * (32 + 16 + 16) , cipherPaddingSize = 16 - , cipherHMAC = hmacSHA256 + , cipherMACHash = SHA256.hash , cipherKeyExchange = CipherKeyExchangeRSA , cipherF = CipherBlockF aes128_cbc_encrypt aes128_cbc_decrypt , cipherMinVer = Just TLS12 @@ -264,7 +268,7 @@ , cipherIVSize = 16 , cipherKeyBlockSize = 2 * (32 + 32 + 16) , cipherPaddingSize = 16 - , cipherHMAC = hmacSHA256 + , cipherMACHash = SHA256.hash , cipherKeyExchange = CipherKeyExchangeRSA , cipherF = CipherBlockF aes256_cbc_encrypt aes256_cbc_decrypt , cipherMinVer = Just TLS12 diff --git a/Network/TLS/Client.hs b/Network/TLS/Client.hs --- a/Network/TLS/Client.hs +++ b/Network/TLS/Client.hs @@ -71,7 +71,7 @@ instance Monad m => MonadTLSState (TLSClient m) where getTLSState = TLSClient (get >>= return . scTLSState) - putTLSState s = TLSClient (get >>= put . (\st -> st { scTLSState = s })) + putTLSState s = TLSClient (modify (\st -> id $! st { scTLSState = s })) instance MonadTrans TLSClient where lift = TLSClient . lift @@ -87,7 +87,7 @@ where state = (newTLSState rng) { stVersion = cpConnectVersion params, stClientContext = True } {- | receive a single TLS packet or on error a TLSError -} -recvPacket :: Handle -> TLSClient IO (Either TLSError Packet) +recvPacket :: Handle -> TLSClient IO (Either TLSError [Packet]) recvPacket handle = do hdr <- lift $ B.hGet handle 5 >>= return . decodeHeader case hdr of @@ -102,36 +102,38 @@ dataToSend <- writePacket pkt lift $ B.hPut handle dataToSend -recvServerHello :: Handle -> TLSClient IO () -recvServerHello handle = do +processServerInfo :: Packet -> TLSClient IO () +processServerInfo (Handshake (ServerHello ver _ _ cipher _ _)) = do ciphers <- cpCiphers . scParams <$> get allowedvers <- cpAllowedVersions . scParams <$> get + case find ((==) ver) allowedvers of + Nothing -> error ("received version which is not allowed: " ++ show ver) + Just _ -> setVersion ver + case find ((==) cipher . cipherID) ciphers of + Nothing -> error "no cipher in common with the server" + Just c -> setCipher c + +processServerInfo (Handshake (CertRequest _ _ _)) = do + modify (\sc -> sc { scCertRequested = True }) + +processServerInfo (Handshake (Certificates certs)) = do callbacks <- cpCallbacks . scParams <$> get - pkt <- recvPacket handle - let hs = case pkt of - Right (Handshake h) -> h - Left err -> error ("error received: " ++ show err) - Right x -> error ("unexpected packet received, expecting handshake " ++ show x) - case hs of - ServerHello ver _ _ cipher _ _ -> do - case find ((==) ver) allowedvers of - Nothing -> error ("received version which is not allowed: " ++ show ver) - Just _ -> setVersion ver + valid <- lift $ maybe (return True) (\cb -> cb certs) (cbCertificates callbacks) + unless valid $ error "certificates received deemed invalid by user" - case find ((==) cipher . cipherID) ciphers of - Nothing -> error "no cipher in common with the server" - Just c -> setCipher c - recvServerHello handle - CertRequest _ _ _ -> modify (\sc -> sc { scCertRequested = True }) >> recvServerHello handle - Certificates certs -> do - valid <- lift $ maybe (return True) (\cb -> cb certs) (cbCertificates callbacks) - unless valid $ error "certificates received deemed invalid by user" - recvServerHello handle - ServerHelloDone -> return () - _ -> error "unexpected handshake message received in server hello messages" +processServerInfo _ = return () -connectSendClientHello :: Handle -> ClientRandom -> TLSClient IO () -connectSendClientHello handle crand = do +recvServerInfo :: Handle -> TLSClient IO () +recvServerInfo handle = do + whileStatus (/= (StatusHandshake HsStatusServerHelloDone)) $ do + pkts <- recvPacket handle + case pkts of + Left err -> error ("error received: " ++ show err) + Right l -> forM_ l processServerInfo + +connectSendClientHello :: Handle -> TLSClient IO () +connectSendClientHello handle = do + crand <- fromJust . clientRandom <$> withTLSRNG (\rng -> getRandomBytes rng 32) ver <- cpConnectVersion . scParams <$> get ciphers <- cpCiphers . scParams <$> get sendPacket handle $ Handshake (ClientHello ver crand (Session Nothing) (map cipherID ciphers) [ 0 ] Nothing) @@ -143,8 +145,9 @@ clientCert <- cpCertificate . scParams <$> get sendPacket handle $ Handshake (Certificates $ maybe [] (:[]) clientCert) -connectSendClientKeyXchg :: Handle -> ClientKeyData -> TLSClient IO () -connectSendClientKeyXchg handle prerand = do +connectSendClientKeyXchg :: Handle -> TLSClient IO () +connectSendClientKeyXchg handle = do + prerand <- ClientKeyData . B.pack <$> withTLSRNG (\rng -> getRandomBytes rng 46) ver <- cpConnectVersion . scParams <$> get sendPacket handle $ Handshake (ClientKeyXchg ver prerand) @@ -154,13 +157,13 @@ sendPacket handle (Handshake $ Finished $ B.unpack cf) {- | connect through a handle as a new TLS connection. -} -connect :: Handle -> ClientRandom -> ClientKeyData -> TLSClient IO () -connect handle crand premasterRandom = do - connectSendClientHello handle crand - recvServerHello handle +connect :: Handle -> TLSClient IO () +connect handle = do + connectSendClientHello handle + recvServerInfo handle connectSendClientCertificate handle - connectSendClientKeyXchg handle premasterRandom + connectSendClientKeyXchg handle {- maybe send certificateVerify -} {- FIXME not implemented yet -} @@ -172,16 +175,10 @@ connectSendFinish handle {- receive changeCipherSpec -} - pktCCS <- recvPacket handle - case pktCCS of - Right ChangeCipherSpec -> return () - x -> error ("unexpected reply. expecting change cipher spec " ++ show x) + _ <- recvPacket handle {- receive Finished -} - pktFin <- recvPacket handle - case pktFin of - Right (Handshake (Finished _)) -> return () - x -> error ("unexpected reply. expecting finished " ++ show x) + _ <- recvPacket handle return () @@ -205,16 +202,8 @@ recvData handle = do pkt <- recvPacket handle case pkt of - Right (AppData x) -> return $ L.fromChunks [x] - Right (Handshake HelloRequest) -> do - -- SECURITY FIXME audit the rng here.. - st <- getTLSState - let (bytes, rng') = getRandomBytes (stRandomGen st) 32 - let (premaster, rng'') = getRandomBytes rng' 46 - putTLSState $ st { stRandomGen = rng'' } - let crand = fromJust $ clientRandom bytes - connect handle crand (ClientKeyData $ B.pack premaster) - recvData handle + Right [AppData x] -> return $ L.fromChunks [x] + Right [Handshake HelloRequest] -> connect handle >> recvData handle Left err -> error ("error received: " ++ show err) _ -> error "unexpected item" diff --git a/Network/TLS/MAC.hs b/Network/TLS/MAC.hs --- a/Network/TLS/MAC.hs +++ b/Network/TLS/MAC.hs @@ -2,6 +2,8 @@ ( hmacMD5 , hmacSHA1 , hmacSHA256 + , macSSL + , hmac , prf_MD5 , prf_SHA1 , prf_MD5SHA1 @@ -13,6 +15,13 @@ import qualified Data.ByteString as B import Data.ByteString (ByteString) import Data.Bits (xor) + +macSSL :: (ByteString -> ByteString) -> ByteString -> ByteString -> ByteString +macSSL f secret msg = f $! B.concat [ secret, B.replicate padlen 0x5c, + f $! B.concat [ secret, B.replicate padlen 0x36, msg ] ] + where + -- get the type of algorithm out of the digest length by using the hash fct. + padlen = if (B.length $ f B.empty) == 16 then 48 else 40 hmac :: (ByteString -> ByteString) -> Int -> ByteString -> ByteString -> ByteString hmac f bl secret msg = diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -14,13 +14,14 @@ -- * marshall functions for header messages decodeHeader , encodeHeader + , encodeHeaderNoVer -- use for SSL3 -- * marshall functions for alert messages , decodeAlert , encodeAlert -- * marshall functions for handshake messages - , decodeHandshakeHeader + , decodeHandshakes , decodeHandshake , encodeHandshake , encodeHandshakeHeader @@ -73,6 +74,11 @@ runPut (putWord8 (valOfType pt) >> putWord8 major >> putWord8 minor >> putWord16 len) where (major, minor) = numericalVer ver +encodeHeaderNoVer :: Header -> ByteString +encodeHeaderNoVer (Header pt _ len) = + {- FIXME check len <= 2^14 -} + runPut (putWord8 (valOfType pt) >> putWord16 len) + {- - decode and encode ALERT -} @@ -90,19 +96,26 @@ encodeAlert (al, ad) = runPut (putWord8 (valOfType al) >> putWord8 (valOfType ad)) {- decode and encode HANDSHAKE -} - -decodeHandshakeHeader :: ByteString -> Either TLSError (HandshakeType, Bytes) -decodeHandshakeHeader = runGet $ do +decodeHandshakeHeader :: Get (HandshakeType, Bytes) +decodeHandshakeHeader = do tyopt <- getWord8 >>= return . valToType ty <- if isNothing tyopt then throwError (Error_Unknown_Type "handshake type") else return $ fromJust tyopt len <- getWord24 content <- getBytes len - empty <- isEmpty - unless empty (throwError (Error_Internal_Packet_Remaining 1)) return (ty, content) +decodeHandshakes :: ByteString -> Either TLSError [(HandshakeType, Bytes)] +decodeHandshakes b = runGet getAll b + where + getAll = do + x <- decodeHandshakeHeader + empty <- isEmpty + if empty + then return [x] + else getAll >>= \l -> return (x : l) + decodeHandshake :: Version -> HandshakeType -> ByteString -> Either TLSError Handshake decodeHandshake ver ty = runGet $ case ty of HandshakeType_HelloRequest -> decodeHelloRequest @@ -388,10 +401,10 @@ generateMasterSecret_TLS premasterSecret (ClientRandom c) (ServerRandom s) = prf_MD5SHA1 premasterSecret seed 48 where - seed = B.concat [ BC.pack "master secret", c, s ] + seed = B.concat [ "master secret", c, s ] generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) = - B.concat $ map (computeMD5 . BC.pack) [ "A", "BB", "CCC" ] + B.concat $ map (computeMD5) ["A","BB","CCC"] where computeMD5 label = hashMD5 $ B.concat [ premasterSecret, computeSHA1 label ] computeSHA1 label = hashSHA1 $ B.concat [ label, premasterSecret, c, s ] @@ -400,12 +413,24 @@ generateMasterSecret ver = if ver < TLS10 then generateMasterSecret_SSL else generateMasterSecret_TLS -generateKeyBlock :: ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes -generateKeyBlock (ClientRandom c) (ServerRandom s) mastersecret kbsize = +generateKeyBlock_TLS :: ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes +generateKeyBlock_TLS (ClientRandom c) (ServerRandom s) mastersecret kbsize = prf_MD5SHA1 mastersecret seed kbsize where - seed = B.concat [ BC.pack "key expansion", s, c ] + seed = B.concat [ "key expansion", s, c ] +generateKeyBlock_SSL :: ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes +generateKeyBlock_SSL (ClientRandom c) (ServerRandom s) mastersecret kbsize = + B.concat $ map computeMD5 $ take ((kbsize `div` 16) + 1) labels + where + labels = [ uncurry BC.replicate x | x <- zip [1..] ['A'..'Z'] ] + computeMD5 label = hashMD5 $ B.concat [ mastersecret, computeSHA1 label ] + computeSHA1 label = hashSHA1 $ B.concat [ label, mastersecret, s, c ] + +generateKeyBlock :: Version -> ClientRandom -> ServerRandom -> Bytes -> Int -> Bytes +generateKeyBlock ver = + if ver < TLS10 then generateKeyBlock_SSL else generateKeyBlock_TLS + generateFinished_TLS :: Bytes -> Bytes -> HashCtx -> HashCtx -> Bytes generateFinished_TLS label mastersecret md5ctx sha1ctx = prf_MD5SHA1 mastersecret seed 12 @@ -416,16 +441,17 @@ generateFinished_SSL sender mastersecret md5ctx sha1ctx = B.concat [md5hash, sha1hash] where - md5hash = hashMD5 $ B.concat [ mastersecret, pad2, md5left ] - sha1hash = hashSHA1 $ B.concat [ mastersecret, pad2, sha1left ] - pad2 = B.empty -- FIXME - md5left = hashMD5 B.empty - sha1left = hashSHA1 B.empty + md5hash = hashMD5 $ B.concat [ mastersecret, pad2, md5left ] + sha1hash = hashSHA1 $ B.concat [ mastersecret, B.take 40 pad2, sha1left ] + md5left = finalizeHash $ foldl updateHash md5ctx [ sender, mastersecret, pad1 ] + sha1left = finalizeHash $ foldl updateHash sha1ctx [ sender, mastersecret, B.take 40 pad1 ] + pad2 = B.replicate 48 0x5c + pad1 = B.replicate 48 0x36 generateClientFinished :: Version -> Bytes -> HashCtx -> HashCtx -> Bytes generateClientFinished ver = - if ver < TLS10 then generateFinished_SSL "CLNT" else generateFinished_TLS (BC.pack "client finished") + if ver < TLS10 then generateFinished_SSL "CLNT" else generateFinished_TLS "client finished" generateServerFinished :: Version -> Bytes -> HashCtx -> HashCtx -> Bytes generateServerFinished ver = - if ver < TLS10 then generateFinished_SSL "SRVR" else generateFinished_TLS (BC.pack "server finished") + if ver < TLS10 then generateFinished_SSL "SRVR" else generateFinished_TLS "server finished" diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs --- a/Network/TLS/Receiving.hs +++ b/Network/TLS/Receiving.hs @@ -54,56 +54,51 @@ returnEither (Left err) = throwError err returnEither (Right a) = return a -readPacket :: MonadTLSState m => Header -> EncryptedData -> m (Either TLSError Packet) -readPacket hdr@(Header ProtocolType_AppData _ _) content = - runTLSRead (AppData <$> decryptContent hdr content) +readPacket :: MonadTLSState m => Header -> EncryptedData -> m (Either TLSError [Packet]) +readPacket hdr content = runTLSRead (checkState hdr >> decryptContent hdr content >>= processPacket hdr) -readPacket hdr@(Header ProtocolType_Alert _ _) content = - runTLSRead (decryptContent hdr content >>= returnEither . decodeAlert >>= return . Alert) +checkState :: Header -> TLSRead () +checkState (Header pt _ _) = + stStatus <$> getTLSState >>= \status -> unless (allowed pt status) $ throwError $ Error_Packet_unexpected (show status) (show pt) + where + 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 -readPacket hdr@(Header ProtocolType_ChangeCipherSpec _ _) content = runTLSRead $ do - dcontent <- decryptContent hdr content - returnEither $ decodeChangeCipherSpec dcontent - switchRxEncryption - isClientContext >>= \cc -> when (not cc) setKeyBlock - return ChangeCipherSpec +processPacket :: Header -> Bytes -> TLSRead [Packet] -readPacket hdr@(Header ProtocolType_Handshake ver _) content = - runTLSRead (decryptContent hdr content >>= processHsPacket ver) +processPacket (Header ProtocolType_AppData _ _) content = return [AppData content] -decryptRSA :: MonadTLSState m => ByteString -> m (Maybe ByteString) -decryptRSA econtent = do - rsapriv <- getTLSState >>= return . fromJust . hstRSAPrivateKey . fromJust . stHandshake - return $ rsaDecrypt rsapriv (B.drop 2 econtent) +processPacket (Header ProtocolType_Alert _ _) content = return . (:[]) . Alert =<< returnEither (decodeAlert content) -setMasterSecretRandom :: ByteString -> TLSRead () -setMasterSecretRandom content = do - st <- getTLSState - let (bytes, g') = getRandomBytes (stRandomGen st) (fromIntegral $ B.length content) - putTLSState $ st { stRandomGen = g' } - setMasterSecret (B.pack bytes) +processPacket (Header ProtocolType_ChangeCipherSpec _ _) content = do + e <- updateStatusCC False + when (isJust e) $ throwError (fromJust e) -processClientKeyXchg :: Version -> ByteString -> TLSRead () -processClientKeyXchg ver content = do - {- the TLS protocol expect the initial client version received in the ClientHello, not the negociated version -} - expectedVer <- getTLSState >>= return . hstClientVersion . fromJust . stHandshake - if expectedVer /= ver - then setMasterSecretRandom content - else setMasterSecret content + returnEither $ decodeChangeCipherSpec content + switchRxEncryption + isClientContext >>= \cc -> when (not cc) setKeyBlock + return [ChangeCipherSpec] -processClientFinished :: FinishedData -> TLSRead () -processClientFinished fdata = do - cc <- getTLSState >>= return . stClientContext - expected <- getHandshakeDigest (not cc) - when (expected /= B.pack fdata) $ do - -- FIXME don't fail, but report the error so that the code can send a BadMac Alert. - fail ("client mac failure: expecting " ++ show expected ++ " received " ++ (show $L.pack fdata)) - return () +processPacket (Header ProtocolType_Handshake ver _) dcontent = do + handshakes <- returnEither (decodeHandshakes dcontent) + forM handshakes $ \(ty, content) -> do + hs <- processHandshake ver ty content + when (finishHandshakeTypeMaterial ty) $ updateHandshakeDigestSplitted ty content + return hs -processHsPacket :: Version -> ByteString -> TLSRead Packet -processHsPacket ver dcontent = do - (ty, econtent) <- returnEither $ decodeHandshakeHeader dcontent +processHandshake :: Version -> HandshakeType -> ByteString -> TLSRead Packet +processHandshake ver ty econtent = do -- SECURITY FIXME if RSA fail, we need to generate a random master secret and not fail. + e <- updateStatusHs ty + when (isJust e) $ throwError (fromJust e) + content <- case ty of HandshakeType_ClientKeyXchg -> do copt <- decryptRSA econtent @@ -126,10 +121,38 @@ processClientKeyXchg cver content Finished fdata -> processClientFinished fdata _ -> return () - when (finishHandshakeTypeMaterial ty) (updateHandshakeDigest dcontent) return $ Handshake hs +decryptRSA :: MonadTLSState m => ByteString -> m (Maybe ByteString) +decryptRSA econtent = do + ver <- return . stVersion =<< getTLSState + rsapriv <- getTLSState >>= return . fromJust . hstRSAPrivateKey . fromJust . stHandshake + return $ rsaDecrypt rsapriv (if ver < TLS10 then econtent else B.drop 2 econtent) +setMasterSecretRandom :: ByteString -> TLSRead () +setMasterSecretRandom content = do + st <- getTLSState + let (bytes, g') = getRandomBytes (stRandomGen st) (fromIntegral $ B.length content) + putTLSState $ st { stRandomGen = g' } + setMasterSecret (B.pack bytes) + +processClientKeyXchg :: Version -> ByteString -> TLSRead () +processClientKeyXchg ver content = do + {- the TLS protocol expect the initial client version received in the ClientHello, not the negociated version -} + expectedVer <- getTLSState >>= return . hstClientVersion . fromJust . stHandshake + if expectedVer /= ver + then setMasterSecretRandom content + else setMasterSecret content + +processClientFinished :: FinishedData -> TLSRead () +processClientFinished fdata = do + cc <- getTLSState >>= return . stClientContext + expected <- getHandshakeDigest (not cc) + when (expected /= B.pack fdata) $ do + -- FIXME don't fail, but report the error so that the code can send a BadMac Alert. + fail ("client mac failure: expecting " ++ show expected ++ " received " ++ (show $L.pack fdata)) + return () + decryptContent :: Header -> EncryptedData -> TLSRead ByteString decryptContent hdr e@(EncryptedData b) = do st <- getTLSState @@ -154,8 +177,11 @@ paddingValid <- case cipherDataPadding cdata of Nothing -> return True Just pad -> do + ver <- stVersion <$> getTLSState let b = B.length pad - 1 - return $ maybe True (const False) $ B.find (/= fromIntegral b) pad + if ver < TLS10 + then return True + else return $ maybe True (const False) $ B.find (/= fromIntegral b) pad unless (and $! [ macValid, paddingValid ]) $ do throwError $ Error_Digest ([], []) diff --git a/Network/TLS/SRandom.hs b/Network/TLS/SRandom.hs --- a/Network/TLS/SRandom.hs +++ b/Network/TLS/SRandom.hs @@ -10,11 +10,12 @@ import System.Random import Control.Arrow (first) import Data.Word +import Codec.Crypto.AES.Random -type SRandomGen = StdGen +type SRandomGen = AESGen -makeSRandomGen :: Int -> SRandomGen -makeSRandomGen i = mkStdGen i +makeSRandomGen :: IO SRandomGen +makeSRandomGen = newAESGen getRandomByte :: SRandomGen -> (Word8, SRandomGen) getRandomByte rng = first fromIntegral $ next rng diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs --- a/Network/TLS/Sending.hs +++ b/Network/TLS/Sending.hs @@ -76,13 +76,24 @@ encodePacket :: MonadTLSState m => (Header, ByteString) -> m ByteString encodePacket (hdr, content) = return $ B.concat [ encodeHeader hdr, content ] +{- + - just update TLS state machine + -} +preProcessPacket :: MonadTLSState m => Packet -> m Packet +preProcessPacket pkt = do + e <- case pkt of + Handshake hs -> updateStatusHs (typeOfHandshake hs) + AppData _ -> return Nothing + ChangeCipherSpec -> updateStatusCC True + Alert _ -> return Nothing + return pkt {- - writePacket transform a packet into marshalled data related to current state - and updating state on the go -} writePacket :: MonadTLSState m => Packet -> m ByteString -writePacket pkt = makePacketData pkt >>= processPacketData >>= +writePacket pkt = preProcessPacket pkt >>= makePacketData >>= processPacketData >>= encryptPacketData >>= postprocessPacketData >>= encodePacket {------------------------------------------------------------------------------} @@ -157,11 +168,17 @@ writePacketContent :: MonadTLSState m => Packet -> m ByteString writePacketContent (Handshake ckx@(ClientKeyXchg _ _)) = do + ver <- getTLSState >>= return . stVersion let premastersecret = runPut $ encodeHandshakeContent ckx setMasterSecret premastersecret econtent <- encryptRSA premastersecret - let extralength = runPut $ putWord16 $ fromIntegral $ B.length econtent - let hdr = runPut $ encodeHandshakeHeader (typeOfHandshake ckx) (fromIntegral (B.length econtent + 2)) + + let extralength = + if ver < TLS10 + then B.empty + else runPut $ putWord16 $ fromIntegral $ B.length econtent + let hdr = runPut $ encodeHandshakeHeader (typeOfHandshake ckx) + (fromIntegral (B.length econtent + B.length extralength)) return $ B.concat [hdr, extralength, econtent] writePacketContent pkt@(Handshake (ClientHello ver crand _ _ _ _)) = do diff --git a/Network/TLS/Server.hs b/Network/TLS/Server.hs --- a/Network/TLS/Server.hs +++ b/Network/TLS/Server.hs @@ -30,6 +30,7 @@ import Data.List (intersect, find) import Control.Monad.Trans import Control.Monad.State +import Control.Applicative ((<$>)) import Codec.Crypto.RSA (PrivateKey(..)) import Data.Certificate.X509 import qualified Data.Certificate.Key as CertificateKey @@ -88,7 +89,7 @@ where state = (newTLSState rng) { stClientContext = False } {- | receive a single TLS packet or on error a TLSError -} -recvPacket :: Handle -> TLSServer IO (Either TLSError Packet) +recvPacket :: Handle -> TLSServer IO (Either TLSError [Packet]) recvPacket handle = do hdr <- lift $ B.hGet handle 5 >>= return . decodeHeader case hdr of @@ -127,27 +128,9 @@ handleClientHello _ = do fail "unexpected handshake type received. expecting client hello" -expectingPacket :: (Either TLSError Packet) -> ProtocolType -> TLSServer IO () -expectingPacket pkt expectedType = do - apkt <- case pkt of - Right x -> return x - Left tlserror -> fail ("expecting packet but got error " ++ show tlserror) - when (packetType apkt /= expectedType) $ do - fail ("unexpected packet received, expecting " ++ show expectedType) - return () - -expectingHandshake :: (Either TLSError Packet) -> HandshakeType -> TLSServer IO () -expectingHandshake pkt expectedType = do - hs <- case pkt of - Right (Handshake hs) -> return hs - Right _ -> fail ("unexpected packet received, expecting handshake " ++ show expectedType) - Left tlserror -> fail ("expecting handshake but got error " ++ show tlserror) - when (typeOfHandshake hs /= expectedType) $ do - fail ("unexpected handshake received, expecting " ++ show expectedType) - return () - -handshakeSendServerData :: Handle -> ServerRandom -> TLSServer IO () -handshakeSendServerData handle srand = do +handshakeSendServerData :: Handle -> TLSServer IO () +handshakeSendServerData handle = do + srand <- fromJust . serverRandom <$> withTLSRNG (\rng -> getRandomBytes rng 32) sp <- get >>= return . scParams st <- getTLSState @@ -187,14 +170,12 @@ sendPacket handle (Handshake $ Finished $ B.unpack cf) {- after receiving a client hello, we need to redo a handshake -} -handshake :: Handle -> ServerRandom -> TLSServer IO () -handshake handle srand = do - handshakeSendServerData handle srand +handshake :: Handle -> TLSServer IO () +handshake handle = do + handshakeSendServerData handle lift $ hFlush handle - recvPacket handle >>= \pkt -> expectingHandshake pkt HandshakeType_ClientKeyXchg - recvPacket handle >>= \pkt -> expectingPacket pkt ProtocolType_ChangeCipherSpec - recvPacket handle >>= \pkt -> expectingHandshake pkt HandshakeType_Finished + whileStatus (/= (StatusHandshake HsStatusClientFinished)) (recvPacket handle) sendPacket handle ChangeCipherSpec handshakeSendFinish handle @@ -204,15 +185,13 @@ return () {- | listen on a handle to a new TLS connection. -} -listen :: Handle -> ServerRandom -> TLSServer IO () -listen handle srand = do - pkt <- recvPacket handle - case pkt of - Right (Handshake hs) -> handleClientHello hs +listen :: Handle -> TLSServer IO () +listen handle = do + pkts <- recvPacket handle + case pkts of + Right [Handshake hs] -> handleClientHello hs x -> fail ("unexpected type received. expecting handshake ++ " ++ show x) - handshake handle srand - - return () + handshake handle sendDataChunk :: Handle -> B.ByteString -> TLSServer IO () sendDataChunk handle d = @@ -234,15 +213,8 @@ recvData handle = do pkt <- recvPacket handle case pkt of - Right (Handshake (ClientHello _ _ _ _ _ _)) -> do - -- SECURITY FIXME audit the rng here.. - st <- getTLSState - let (bytes, rng') = getRandomBytes (stRandomGen st) 32 - putTLSState $ st { stRandomGen = rng' } - let srand = fromJust $ serverRandom bytes - handshake handle srand - recvData handle - Right (AppData x) -> return $ L.fromChunks [x] + Right [Handshake (ClientHello _ _ _ _ _ _)] -> handshake handle >> recvData handle + Right [AppData x] -> return $ L.fromChunks [x] Left err -> error ("error received: " ++ show err) _ -> error "unexpected item" diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs --- a/Network/TLS/State.hs +++ b/Network/TLS/State.hs @@ -13,9 +13,15 @@ , TLSHandshakeState(..) , TLSCryptState(..) , TLSMacState(..) + , TLSStatus(..) + , HandshakeStatus(..) , MonadTLSState, getTLSState, putTLSState, modifyTLSState , newTLSState + , withTLSRNG , assert -- FIXME move somewhere else (Internal.hs ?) + , updateStatusHs + , updateStatusCC + , whileStatus , finishHandshakeTypeMaterial , finishHandshakeMaterial , makeDigest @@ -31,11 +37,13 @@ , isClientContext , startHandshakeClient , updateHandshakeDigest + , updateHandshakeDigestSplitted , getHandshakeDigest , endHandshake ) where import Data.Word +import Data.List (find) import Data.Maybe (fromJust, isNothing) import Network.TLS.Util import Network.TLS.Struct @@ -44,6 +52,7 @@ import Network.TLS.Packet import Network.TLS.Crypto import Network.TLS.Cipher +import Network.TLS.MAC import qualified Data.ByteString as B import Control.Monad @@ -51,6 +60,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 @@ -74,6 +105,7 @@ data TLSState = TLSState { stClientContext :: Bool , stVersion :: !Version + , stStatus :: !TLSStatus , stHandshake :: !(Maybe TLSHandshakeState) , stTxEncrypted :: Bool , stRxEncrypted :: Bool @@ -93,6 +125,7 @@ newTLSState rng = TLSState { stClientContext = False , stVersion = TLS10 + , stStatus = StatusInit , stHandshake = Nothing , stTxEncrypted = False , stRxEncrypted = False @@ -107,6 +140,13 @@ modifyTLSState :: (MonadTLSState m) => (TLSState -> TLSState) -> m () modifyTLSState f = getTLSState >>= \st -> putTLSState (f st) +withTLSRNG :: MonadTLSState m => (SRandomGen -> (a, SRandomGen)) -> m a +withTLSRNG f = do + st <- getTLSState + let (a, newrng) = f (stRandomGen st) + putTLSState (st { stRandomGen = newrng }) + return a + makeDigest :: (MonadTLSState m) => Bool -> Header -> Bytes -> m Bytes makeDigest w hdr content = do st <- getTLSState @@ -114,18 +154,90 @@ [ ("cipher", isNothing $ stCipher st) , ("crypt state", isNothing $ if w then stTxCryptState st else stRxCryptState st) , ("mac state", isNothing $ if w then stTxMacState st else stRxMacState st) ] + let ver = stVersion st let cst = fromJust $ if w then stTxCryptState st else stRxCryptState st let ms = fromJust $ if w then stTxMacState st else stRxMacState st let cipher = fromJust $ stCipher st + let machash = cipherMACHash cipher - let hmac_msg = B.concat [ encodeWord64 $ msSequence ms, encodeHeader hdr, content ] - let digest = (cipherHMAC cipher) (cstMacSecret cst) hmac_msg + let (macF, msg) = + if ver < TLS10 + then (macSSL machash, B.concat [ encodeWord64 $ msSequence ms, encodeHeaderNoVer hdr, content ]) + else (hmac machash 64, B.concat [ encodeWord64 $ msSequence ms, encodeHeader hdr, content ]) + let digest = macF (cstMacSecret cst) msg let newms = ms { msSequence = (msSequence ms) + 1 } modifyTLSState (\_ -> 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 ]) + ] + +whileStatus :: (MonadTLSState m, Monad m) => (TLSStatus -> Bool) -> m a -> m () +whileStatus p a = do + currentStatus <- getTLSState >>= return . stStatus + when (p currentStatus) (a >> whileStatus p a) + +updateStatus :: MonadTLSState m => TLSStatus -> m () +updateStatus x = modifyTLSState (\st -> st { stStatus = x }) + +updateStatusHs :: MonadTLSState m => HandshakeType -> m (Maybe TLSError) +updateStatusHs ty = do + status <- return . stStatus =<< getTLSState + ns <- return . transition . stStatus =<< getTLSState + 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 :: MonadTLSState m => Bool -> m (Maybe TLSError) +updateStatusCC sending = do + status <- return . stStatus =<< getTLSState + 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) + finishHandshakeTypeMaterial :: HandshakeType -> Bool finishHandshakeTypeMaterial HandshakeType_ClientHello = True finishHandshakeTypeMaterial HandshakeType_ServerHello = True @@ -185,7 +297,7 @@ let digestSize = fromIntegral $ cipherDigestSize cipher let keySize = fromIntegral $ cipherKeySize cipher let ivSize = fromIntegral $ cipherIVSize cipher - let kb = generateKeyBlock (hstClientRandom hst) + let kb = generateKeyBlock (stVersion st) (hstClientRandom hst) (fromJust $ hstServerRandom hst) (fromJust $ hstMasterSecret hst) keyblockSize @@ -210,10 +322,10 @@ } setCipher :: MonadTLSState m => Cipher -> m () -setCipher cipher = getTLSState >>= putTLSState . (\st -> st { stCipher = Just cipher }) +setCipher cipher = modifyTLSState (\st -> st { stCipher = Just cipher }) setVersion :: MonadTLSState m => Version -> m () -setVersion ver = getTLSState >>= putTLSState . (\st -> st { stVersion = ver }) +setVersion ver = modifyTLSState (\st -> st { stVersion = ver }) isClientContext :: MonadTLSState m => m Bool isClientContext = getTLSState >>= return . stClientContext @@ -254,6 +366,11 @@ let nc2 = updateHash c2 content in hs { hstHandshakeDigest = Just (nc1, nc2) } ) + +updateHandshakeDigestSplitted :: MonadTLSState m => HandshakeType -> Bytes -> m () +updateHandshakeDigestSplitted ty bytes = updateHandshakeDigest $ B.concat [hdr, bytes] + where + hdr = runPut $ encodeHandshakeHeader ty (B.length bytes) getHandshakeDigest :: MonadTLSState 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 @@ -103,6 +103,7 @@ | Error_Digest ([Word8], [Word8]) | Error_Packet String | Error_Packet_Size_Mismatch (Int, Int) + | Error_Packet_unexpected String String | Error_Internal_Packet_Remaining Int | Error_Internal_Packet_ByteProcessed Int Int Int | Error_Unknown_Version Word8 Word8 diff --git a/Stunnel.hs b/Stunnel.hs --- a/Stunnel.hs +++ b/Stunnel.hs @@ -28,9 +28,6 @@ import qualified Network.TLS.Client as C import qualified Network.TLS.Server as S -import System.Random -import qualified Codec.Crypto.AES.Random as AESRand - ciphers :: [Cipher] ciphers = [ cipher_AES128_SHA1 @@ -44,8 +41,8 @@ where [a,b,c,d] = map fromIntegral l -tlsclient handle crand prerand = do - C.connect handle crand prerand +tlsclient handle = do + C.connect handle C.sendData handle (L.pack $ map (toEnum.fromEnum) "GET / HTTP/1.0\r\n\r\n") d <- C.recvData handle @@ -58,12 +55,7 @@ mainClient :: String -> Int -> IO () mainClient host port = do - {- generate some random stuff ready to be used after skipping some byte for no particular reason -} - ranByte <- B.head <$> AESRand.randBytes 1 - _ <- AESRand.randBytes (fromIntegral ranByte) - clientRandom <- fromJust . clientRandom . B.unpack <$> AESRand.randBytes 32 - premasterRandom <- ClientKeyData <$> AESRand.randBytes 46 - seqInit <- conv . B.unpack <$> AESRand.randBytes 4 + rng <- makeSRandomGen handle <- connectTo host (PortNumber $ fromIntegral port) hSetBuffering handle NoBuffering @@ -78,20 +70,19 @@ { C.cbCertificates = Nothing } } - C.runTLSClient (tlsclient handle clientRandom premasterRandom) clientstate (makeSRandomGen seqInit) + C.runTLSClient (tlsclient handle) clientstate rng putStrLn "end" -tlsserver handle srand = do - S.listen handle srand +tlsserver handle = do + S.listen handle _ <- S.recvData handle S.sendData handle (LC.pack "this is some data") lift $ hFlush handle lift $ putStrLn "end" clientProcess ((certdata, cert), pk) (handle, src) = do - serverRandom <- fromJust . serverRandom . B.unpack <$> AESRand.randBytes 32 - seqInit <- conv . B.unpack <$> AESRand.randBytes 4 + rng <- makeSRandomGen let serverstate = S.TLSServerParams { S.spAllowedVersions = [TLS10,TLS11] @@ -103,7 +94,7 @@ { S.cbCertificates = Nothing } } - S.runTLSServer (tlsserver handle serverRandom) serverstate (makeSRandomGen seqInit) + S.runTLSServer (tlsserver handle) serverstate rng putStrLn "end" mainServerAccept cert port socket = do @@ -122,8 +113,8 @@ readCertificate filepath = do content <- B.readFile filepath let certdata = case parsePEMCert content of - Left err -> error ("cannot read PEM certificate: " ++ err) - Right x -> x + Nothing -> error ("no valid certificate section") + Just x -> x let cert = case decodeCertificate $ L.fromChunks [certdata] of Left err -> error ("cannot decode certificate: " ++ err) Right x -> x @@ -132,9 +123,9 @@ readPrivateKey :: FilePath -> IO (L.ByteString, PrivateKey) readPrivateKey filepath = do content <- B.readFile filepath - let pkdata = case parsePEMKey content of - Left err -> error ("cannot read PEM key: " ++ err) - Right x -> L.fromChunks [x] + let pkdata = case parsePEMKeyRSA content of + Nothing -> error ("no valid RSA key section") + Just x -> L.fromChunks [x] let pk = case decodePrivateKey pkdata of Left err -> error ("cannot decode key: " ++ err) Right x -> x diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -89,7 +89,7 @@ prop_header_marshalling_id x = (decodeHeader $ encodeHeader x) == Right x prop_handshake_marshalling_id x = (decodeHs $ encodeHandshake x) == Right x where - decodeHs b = either (Left . id) (\(ty, bdata) -> decodeHandshake TLS10 ty bdata) $ decodeHandshakeHeader b + decodeHs b = either (Left . id) (uncurry (decodeHandshake TLS10) . head) $ decodeHandshakes b {- main -} args = Args diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,16 +1,19 @@ Name: tls -Version: 0.1.3 +Version: 0.2 Description: - Implementation of the TLS protocol, focusing on purity and more type-checking. + native TLS protocol implementation, focusing on purity and more type-checking. . - Currently implement only partially the TLS1.0 protocol. Not yet properly secure. + Currently implement the SSL3.0, TLS1.0 and TLS1.1 protocol. + Not yet properly secure and missing some features. Do not yet use as replacement to more mature implementation. + . + only RSA supported as Key exchange for now. License: BSD3 License-file: LICENSE Copyright: Vincent Hanquez Author: Vincent Hanquez Maintainer: Vincent Hanquez -Synopsis: TLS protocol for Server and Client sides +Synopsis: TLS/SSL protocol native implementation (Server and Client) Build-Type: Simple Category: Network stability: experimental @@ -36,7 +39,7 @@ random, AES, RSA, spoon, cryptocipher, - certificate >= 0.2 + certificate >= 0.3 Exposed-modules: Network.TLS.Client Network.TLS.Server Network.TLS.Struct