yogsototh/hs-tls
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

accept SSLv2 format 'ClientHello' Handshake message.

Browse source
This commit is contained in:
notogawa 2012-11-10 01:02:50 +09:00
parent a0878b6022
commit a4f06256fe
7 changed files with 77 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
core/Network/TLS/Handshake/Client.hs
View file

@ -77,7 +77,7 @@ handshakeClient cparams ctx = do
usingState_ ctx (startHandshakeClient (pConnectVersion params) crand)
sendPacket ctx $ Handshake
[ ClientHello (pConnectVersion params) crand clientSession (map cipherID ciphers)
(map compressionID compressions) extensions
(map compressionID compressions) extensions Nothing
]
return $ map fst extensions

2
core/Network/TLS/Handshake/Server.hs
View file

@ -77,7 +77,7 @@ handshakeServer sparams ctx = do
-- -> finish <- finish
--
handshakeServerWith :: MonadIO m => ServerParams -> Context -> Handshake -> m ()
handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession ciphers compressions exts) = do
handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession ciphers compressions exts _) = do
-- check if policy allow this new handshake to happens
handshakeAuthorized <- withMeasure ctx (onHandshake $ ctxParams ctx)
unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied")

17
core/Network/TLS/IO.hs
View file

@ -51,14 +51,27 @@ readExact ctx sz = do
return hdrbs
recvRecord :: MonadIO m => Context -> m (Either TLSError (Record Plaintext))
recvRecord ctx = readExact ctx 5 >>= either (return . Left) recvLength . decodeHeader
recvRecord ctx = do
header <- readExact ctx 2
if B.head header < 0x80
then readExact ctx 3 >>= either (return . Left) recvLength . decodeHeader . B.append header
else either (return . Left) recvDeprecatedLength $ decodeDeprecatedHeaderLength header
where recvLength header@(Header _ _ readlen)
| readlen > 16384 + 2048 = return $ Left $ Error_Protocol ("record exceeding maximum size", True, RecordOverflow)
| readlen > 16384 + 2048 = return $ Left maximumSizeExceeded
| otherwise = readExact ctx (fromIntegral readlen) >>= makeRecord ctx header
recvDeprecatedLength readlen
| readlen > 1024 * 4 = return $ Left maximumSizeExceeded
| otherwise = do
content <- readExact ctx (fromIntegral readlen)
case decodeDeprecatedHeader readlen content of
Left err -> return $ Left err
Right header -> makeRecord ctx header content
maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow)
makeRecord ctx header content = do
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

46
core/Network/TLS/Packet.hs
View file

@ -15,6 +15,8 @@ module Network.TLS.Packet
CurrentParams(..)
-- * marshall functions for header messages
, decodeHeader
, decodeDeprecatedHeaderLength
, decodeDeprecatedHeader
, encodeHeader
, encodeHeaderNoVer -- use for SSL3
@ -26,6 +28,7 @@ module Network.TLS.Packet
-- * marshall functions for handshake messages
, decodeHandshakes
, decodeHandshake
, decodeDeprecatedHandshake
, encodeHandshake
, encodeHandshakes
, encodeHandshakeHeader
@ -52,6 +55,7 @@ import Network.TLS.Wire
import Network.TLS.Cap
import Data.Either (partitionEithers)
import Data.Maybe (fromJust)
import Data.Word
import Data.Bits ((.|.))
import Control.Applicative ((<$>))
import Control.Monad
@ -109,6 +113,16 @@ getHandshakeType = do
decodeHeader :: ByteString -> Either TLSError Header
decodeHeader = runGetErr "header" $ liftM3 Header getHeaderType getVersion getWord16
decodeDeprecatedHeaderLength :: ByteString -> Either TLSError Word16
decodeDeprecatedHeaderLength = runGetErr "deprecatedheaderlength" $ subtract 0x8000 <$> getWord16
decodeDeprecatedHeader :: Word16 -> ByteString -> Either TLSError Header
decodeDeprecatedHeader size =
runGetErr "deprecatedheader" $ do
1 <- getWord8
version <- getVersion
return $ Header ProtocolType_DeprecatedHandshake version size
encodeHeader :: Header -> ByteString
encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putVersion ver >> putWord16 len)
{- FIXME check len <= 2^14 -}
@ -173,6 +187,28 @@ decodeHandshake cp ty = runGetErr "handshake" $ case ty of
unless (cParamsSupportNPN cp) $ fail "unsupported handshake type"
decodeNextProtocolNegotiation
decodeDeprecatedHandshake :: ByteString -> Either TLSError Handshake
decodeDeprecatedHandshake b = runGetErr "deprecatedhandshake" getDeprecated b where
getDeprecated = do
1 <- getWord8
ver <- getVersion
cipherSpecLen <- fromEnum <$> getWord16
sessionIdLen <- fromEnum <$> getWord16
challengeLen <- fromEnum <$> getWord16
ciphers <- getCipherSpec cipherSpecLen
session <- getSessionId sessionIdLen
random <- getChallenge challengeLen
let compressions = [0]
return $ ClientHello ver random session ciphers compressions [] (Just b)
getCipherSpec len | len < 3 = return []
getCipherSpec len = do
[c0,c1,c2] <- map fromEnum <$> replicateM 3 getWord8
([ toEnum $ c1 * 0x100 + c2 | c0 == 0 ] ++) <$> getCipherSpec (len - 3)
getSessionId 0 = return $ Session Nothing
getSessionId len = Session . Just <$> getBytes len
getChallenge len | 32 < len = getBytes (len - 32) >> getChallenge 32
getChallenge len = ClientRandom . B.append (B.replicate (32 - len) 0) <$> getBytes len
decodeHelloRequest :: Get Handshake
decodeHelloRequest = return HelloRequest
@ -187,7 +223,7 @@ decodeClientHello = do
exts <- if hasHelloExtensions ver && r > 0
then fmap fromIntegral getWord16 >>= getExtensions
else return []
return $ ClientHello ver random session ciphers compressions exts
return $ ClientHello ver random session ciphers compressions exts Nothing
decodeServerHello :: Get Handshake
decodeServerHello = do
@ -300,7 +336,9 @@ encodeHandshake :: Handshake -> ByteString
encodeHandshake o =
let content = runPut $ encodeHandshakeContent o in
let len = fromIntegral $ B.length content in
let header = runPut $ encodeHandshakeHeader (typeOfHandshake o) len in
let header = case o of
ClientHello _ _ _ _ _ _ (Just _) -> "" -- SSLv2 ClientHello message
_ -> runPut $ encodeHandshakeHeader (typeOfHandshake o) len in
B.concat [ header, content ]
encodeHandshakes :: [Handshake] -> ByteString
@ -311,7 +349,9 @@ encodeHandshakeHeader ty len = putWord8 (valOfType ty) >> putWord24 len
encodeHandshakeContent :: Handshake -> Put
encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts) = do
encodeHandshakeContent (ClientHello _ _ _ _ _ _ (Just deprecated)) = do
putBytes deprecated
encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts Nothing) = do
putVersion version
putClientRandom32 random
putSession session

9
core/Network/TLS/Receiving.hs
View file

@ -58,11 +58,16 @@ processPacket (Record ProtocolType_Handshake ver fragment) = do
Right hs -> return hs
return $ Handshake hss
processPacket (Record ProtocolType_DeprecatedHandshake _ fragment) =
case decodeDeprecatedHandshake $ fragmentGetBytes fragment of
Left err -> throwError err
Right hs -> return $ Handshake [hs]
processHandshake :: Handshake -> TLSSt ()
processHandshake hs = do
clientmode <- isClientContext
case hs of
ClientHello cver ran _ _ _ ex -> unless clientmode $ do
ClientHello cver ran _ _ _ ex _ -> unless clientmode $ do
mapM_ processClientExtension ex
startHandshakeClient cver ran
Certificates certs -> processCertificates clientmode certs
@ -143,7 +148,7 @@ processClientFinished fdata = do
processCertificates :: Bool -> [X509] -> TLSSt ()
processCertificates clientmode certs = do
if null certs
if null certs
then when (clientmode) $
throwError $ Error_Protocol ("server certificate missing", True,
HandshakeFailure)

14
core/Network/TLS/Struct.hs
View file

@ -108,6 +108,7 @@ data ProtocolType =
| ProtocolType_Alert
| ProtocolType_Handshake
| ProtocolType_AppData
| ProtocolType_DeprecatedHandshake
deriving (Eq, Show)
-- | TLSError that might be returned through the TLS stack
@ -233,8 +234,10 @@ data ServerKeyXchgAlgorithmData =
| SKX_Unknown Bytes
deriving (Show,Eq)
type DeprecatedRecord = ByteString
data Handshake =
ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] [ExtensionRaw]
ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] [ExtensionRaw] (Maybe DeprecatedRecord)
| ServerHello !Version !ServerRandom !Session !CipherID !CompressionID [ExtensionRaw]
| Certificates [X509]
| HelloRequest
@ -304,10 +307,11 @@ instance TypeValuable CipherType where
valToType _ = Nothing
instance TypeValuable ProtocolType where
valOfType ProtocolType_ChangeCipherSpec = 20
valOfType ProtocolType_Alert = 21
valOfType ProtocolType_Handshake = 22
valOfType ProtocolType_AppData = 23
valOfType ProtocolType_ChangeCipherSpec = 20
valOfType ProtocolType_Alert = 21
valOfType ProtocolType_Handshake = 22
valOfType ProtocolType_AppData = 23
valOfType ProtocolType_DeprecatedHandshake = 128 -- unused
valToType 20 = Just ProtocolType_ChangeCipherSpec
valToType 21 = Just ProtocolType_Alert

1
core/Tests.hs
View file

@ -93,6 +93,7 @@ instance Arbitrary Handshake where
<*> arbitraryCiphersIDs
<*> arbitraryCompressionIDs
<*> (return [])
<*> (return Nothing)
, ServerHello
<$> arbitrary
<*> arbitrary