tls 0.1.3 → 0.2
raw patch · 13 files changed
+362/−206 lines, 13 filesdep ~basedep ~certificate
Dependency ranges changed: base, certificate
Files
- Network/TLS/Cipher.hs +13/−9
- Network/TLS/Client.hs +41/−52
- Network/TLS/MAC.hs +9/−0
- Network/TLS/Packet.hs +44/−18
- Network/TLS/Receiving.hs +69/−43
- Network/TLS/SRandom.hs +4/−3
- Network/TLS/Sending.hs +20/−3
- Network/TLS/Server.hs +17/−45
- Network/TLS/State.hs +122/−5
- Network/TLS/Struct.hs +1/−0
- Stunnel.hs +13/−22
- Tests.hs +1/−1
- tls.cabal +8/−5
Network/TLS/Cipher.hs view
@@ -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
Network/TLS/Client.hs view
@@ -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"
Network/TLS/MAC.hs view
@@ -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 =
Network/TLS/Packet.hs view
@@ -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"
Network/TLS/Receiving.hs view
@@ -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 ([], [])
Network/TLS/SRandom.hs view
@@ -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
Network/TLS/Sending.hs view
@@ -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
Network/TLS/Server.hs view
@@ -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"
Network/TLS/State.hs view
@@ -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
Network/TLS/Struct.hs view
@@ -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
Stunnel.hs view
@@ -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
Tests.hs view
@@ -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
tls.cabal view
@@ -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 <vincent@snarc.org> Author: Vincent Hanquez <vincent@snarc.org> Maintainer: Vincent Hanquez <vincent@snarc.org>-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