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

reflect the fact in types that the record layer record returns list of same header type.

Browse source
This commit is contained in:
Vincent Hanquez 2011-06-10 21:24:46 +01:00
parent f56f5d6e41
commit 5207a41a57
5 changed files with 108 additions and 103 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

84
Network/TLS/Core.hs
View file

@ -172,13 +172,13 @@ whileStatus ctx p a = do
when b (a >> whileStatus ctx p a)
errorToAlert :: TLSError -> Packet
errorToAlert (Error_Protocol (_, _, ad)) = Alert (AlertLevel_Fatal, ad)
errorToAlert _ = Alert (AlertLevel_Fatal, InternalError)
errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)]
errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)]
-- | receive one enveloppe from the context that contains 1 or
-- many packets (many only in case of handshake). if will returns a
-- TLSError if the packet is unexpected or malformed
recvPacket :: MonadIO m => TLSCtx -> m (Either TLSError [Packet])
recvPacket :: MonadIO m => TLSCtx -> m (Either TLSError Packet)
recvPacket ctx = do
hdr <- (liftIO $ B.hGet (ctxHandle ctx) 5) >>= return . decodeHeader
case hdr of
@ -192,7 +192,7 @@ recvPacket ctx = do
liftIO $ (loggingIORecv $ ctxLogging ctx) header content
pkt <- usingState ctx $ readPacket header (EncryptedData content)
case pkt of
Right p -> liftIO $ mapM_ ((loggingPacketRecv $ ctxLogging ctx) . show) p
Right p -> liftIO $ (loggingPacketRecv $ ctxLogging ctx) $ show p
_ -> return ()
return pkt
@ -222,7 +222,7 @@ server params rng handle = liftIO $ newCtx handle params st
--
-- this doesn't actually close the handle
bye :: MonadIO m => TLSCtx -> m ()
bye ctx = sendPacket ctx $ Alert (AlertLevel_Warning, CloseNotify)
bye ctx = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)]
-- client part of handshake. send a bunch of handshake of client
-- values intertwined with response from the server.
@ -231,26 +231,25 @@ handshakeClient ctx = do
-- Send ClientHello
crand <- getStateRNG ctx 32 >>= return . ClientRandom
extensions <- getExtensions
sendPacket ctx $ Handshake $ ClientHello ver crand
(Session Nothing)
(map cipherID ciphers)
(map compressionID compressions)
extensions
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 -> error ("error received: " ++ show err)
Right l -> mapM_ processServerInfo l
Right l -> processServerInfo l
-- Send Certificate if requested. XXX disabled for now.
certRequested <- return False
when certRequested (sendPacket ctx $ Handshake (Certificates clientCerts))
when certRequested (sendPacket ctx $ Handshake [Certificates clientCerts])
-- Send ClientKeyXchg
prerand <- getStateRNG ctx 46 >>= return . ClientKeyData
sendPacket ctx $ Handshake (ClientKeyXchg ver prerand)
sendPacket ctx $ Handshake [ClientKeyXchg ver prerand]
{- maybe send certificateVerify -}
{- FIXME not implemented yet -}
@ -260,7 +259,7 @@ handshakeClient ctx = do
-- Send Finished
cf <- usingState_ ctx $ getHandshakeDigest True
sendPacket ctx (Handshake $ Finished cf)
sendPacket ctx (Handshake [Finished cf])
-- receive changeCipherSpec & Finished
recvPacket ctx >> recvPacket ctx >> return ()
@ -277,7 +276,10 @@ handshakeClient ctx = do
then usingState_ ctx (getVerifiedData True) >>= \vd -> return [ (0xff01, vd) ]
else return []
processServerInfo (Handshake (ServerHello rver _ _ cipher _ _)) = do
processServerInfo (Handshake hss) = mapM_ processHandshake hss
processServerInfo _ = return ()
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)
@ -286,18 +288,18 @@ handshakeClient ctx = do
Nothing -> throwCore $ Error_Protocol ("no cipher in common with the server", True, HandshakeFailure)
Just c -> usingState_ ctx $ setCipher c
processServerInfo (Handshake (CertRequest _ _ _)) = do
return ()
--modify (\sc -> sc { scCertRequested = True })
processServerInfo (Handshake (Certificates certs)) = do
processHandshake (Certificates certs) = do
let cb = onCertificatesRecv $ params
usage <- liftIO $ cb certs
case usage of
CertificateUsageAccept -> return ()
CertificateUsageReject reason -> certificateRejected reason
processServerInfo _ = return ()
processHandshake (CertRequest _ _ _) = do
return ()
--modify (\sc -> sc { scCertRequested = True })
processHandshake _ = return ()
-- on certificate reject, throw an exception with the proper protocol alert error.
certificateRejected CertificateRejectRevoked =
@ -336,7 +338,7 @@ handshakeServerWith ctx (ClientHello ver _ _ ciphers compressions _) = do
-- Send Finish
cf <- usingState_ ctx $ getHandshakeDigest False
sendPacket ctx (Handshake $ Finished cf)
sendPacket ctx (Handshake [Finished cf])
liftIO $ hFlush $ ctxHandle ctx
return ()
@ -370,22 +372,21 @@ handshakeServerWith ctx (ClientHello ver _ _ ciphers compressions _) = do
return $ B.concat [cvf,svf]
return [ (0xff01, vf) ]
else return []
sendPacket ctx $ Handshake $ ServerHello ver srand
(Session Nothing)
(cipherID usedCipher)
(compressionID usedCompression)
extensions
sendPacket ctx (Handshake $ Certificates srvCerts)
sendPacket ctx $ Handshake
[ ServerHello ver srand (Session Nothing) (cipherID usedCipher)
(compressionID usedCompression) extensions
, Certificates srvCerts
]
when needKeyXchg $ do
let skg = SKX_RSA Nothing
sendPacket ctx (Handshake $ ServerKeyXchg skg)
sendPacket ctx (Handshake [ServerKeyXchg skg])
-- FIXME we don't do this on a Anonymous server
when (pWantClientCert params) $ do
let certTypes = [ CertificateType_RSA_Sign ]
let creq = CertRequest certTypes Nothing [0,0,0]
sendPacket ctx (Handshake creq)
sendPacket ctx (Handshake [creq])
-- Send HelloDone
sendPacket ctx (Handshake ServerHelloDone)
sendPacket ctx (Handshake [ServerHelloDone])
handshakeServerWith _ _ = fail "unexpected handshake type received. expecting client hello"
@ -394,8 +395,8 @@ handshakeServer :: MonadIO m => TLSCtx -> m ()
handshakeServer ctx = do
pkts <- recvPacket ctx
case pkts of
Right [Handshake hs] -> handshakeServerWith ctx hs
x -> fail ("unexpected type received. expecting handshake ++ " ++ show x)
Right (Handshake [hs]) -> handshakeServerWith ctx hs
x -> fail ("unexpected type received. expecting handshake ++ " ++ show x)
-- | Handshake for a new TLS connection
-- This is to be called at the beginning of a connection, and during renegociation
@ -429,21 +430,16 @@ recvData ctx = do
pkt <- recvPacket ctx
case pkt of
-- on server context receiving a client hello == renegociation
Right [Handshake ch@(ClientHello _ _ _ _ _ _)] ->
Right (Handshake [ch@(ClientHello _ _ _ _ _ _)]) ->
handshakeServerWith ctx ch >> recvData ctx
-- on client context, receiving a hello request == renegociation
Right [Handshake HelloRequest] ->
Right (Handshake [HelloRequest]) ->
handshakeClient ctx >> recvData ctx
Right [Alert (AlertLevel_Fatal, _)] ->
Right (Alert [(AlertLevel_Fatal, _)]) ->
-- close the connection
return L.empty
Right [Alert (AlertLevel_Warning, CloseNotify)] -> do
Right (Alert [(AlertLevel_Warning, CloseNotify)]) -> do
return L.empty
Right l -> do
let dat = map getAppData l
when (length dat < length l) $ error "error mixed type packet"
return $ L.fromChunks $ catMaybes dat
Right (AppData x) -> return $ L.fromChunks [x]
Right p -> error ("error unexpected packet: p" ++ show p)
Left err -> error ("error received: " ++ show err)
where
getAppData (AppData x) = Just x
getAppData _ = Nothing

24
Network/TLS/Packet.hs
View file

@ -20,12 +20,14 @@ module Network.TLS.Packet
-- * marshall functions for alert messages
, decodeAlert
, encodeAlert
, decodeAlerts
, encodeAlerts
-- * marshall functions for handshake messages
, decodeHandshakes
, decodeHandshake
, encodeHandshake
, encodeHandshakes
, encodeHandshakeHeader
, encodeHandshakeContent
@ -116,8 +118,8 @@ encodeHeaderNoVer (Header pt _ len) = runPut (putHeaderType pt >> putWord16 len)
{-
- decode and encode ALERT
-}
decodeAlert :: ByteString -> Either TLSError (AlertLevel, AlertDescription)
decodeAlert = runGetErr $ do
decodeAlert :: Get (AlertLevel, AlertDescription)
decodeAlert = do
al <- getWord8
ad <- getWord8
case (valToType al, valToType ad) of
@ -125,8 +127,17 @@ decodeAlert = runGetErr $ do
(Nothing, _) -> fail "cannot decode alert level"
(_, Nothing) -> fail "cannot decode alert description"
encodeAlert :: (AlertLevel, AlertDescription) -> ByteString
encodeAlert (al, ad) = runPut (putWord8 (valOfType al) >> putWord8 (valOfType ad))
decodeAlerts :: ByteString -> Either TLSError [(AlertLevel, AlertDescription)]
decodeAlerts = runGetErr $ loop
where loop = do
r <- remaining
if r == 0
then return []
else liftM2 (:) decodeAlert loop
encodeAlerts :: [(AlertLevel, AlertDescription)] -> ByteString
encodeAlerts l = runPut $ mapM_ encodeAlert l
where encodeAlert (al, ad) = (putWord8 (valOfType al) >> putWord8 (valOfType ad))
{- decode and encode HANDSHAKE -}
decodeHandshakeHeader :: Get (HandshakeType, Bytes)
@ -275,6 +286,9 @@ encodeHandshake o =
let header = runPut $ encodeHandshakeHeader (typeOfHandshake o) len in
B.concat [ header, content ]
encodeHandshakes :: [Handshake] -> ByteString
encodeHandshakes hss = B.concat $ map encodeHandshake hss
encodeHandshakeHeader :: HandshakeType -> Int -> Put
encodeHandshakeHeader ty len = putWord8 (valOfType ty) >> putWord24 len

17
Network/TLS/Receiving.hs
View file

@ -35,7 +35,7 @@ returnEither :: Either TLSError a -> TLSSt a
returnEither (Left err) = throwError err
returnEither (Right a) = return a
readPacket :: Header -> EncryptedData -> TLSSt [Packet]
readPacket :: Header -> EncryptedData -> TLSSt Packet
readPacket hdr content = checkState hdr >> decryptContent hdr content >>= processPacket hdr
checkState :: Header -> TLSSt ()
@ -54,11 +54,11 @@ checkState (Header pt _ _) =
allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientCertificateVerify) = True
allowed _ _ = False
processPacket :: Header -> Bytes -> TLSSt [Packet]
processPacket :: Header -> Bytes -> TLSSt Packet
processPacket (Header ProtocolType_AppData _ _) content = return [AppData content]
processPacket (Header ProtocolType_AppData _ _) content = return $ AppData content
processPacket (Header ProtocolType_Alert _ _) content = return . (:[]) . Alert =<< returnEither (decodeAlert content)
processPacket (Header ProtocolType_Alert _ _) content = return . Alert =<< returnEither (decodeAlerts content)
processPacket (Header ProtocolType_ChangeCipherSpec _ _) content = do
e <- updateStatusCC False
@ -67,16 +67,17 @@ processPacket (Header ProtocolType_ChangeCipherSpec _ _) content = do
returnEither $ decodeChangeCipherSpec content
switchRxEncryption
isClientContext >>= \cc -> when (not cc) setKeyBlock
return [ChangeCipherSpec]
return ChangeCipherSpec
processPacket (Header ProtocolType_Handshake ver _) dcontent = do
handshakes <- returnEither (decodeHandshakes dcontent)
forM handshakes $ \(ty, content) -> do
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 Packet
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
@ -111,7 +112,7 @@ processHandshake ver ty econtent = do
processClientKeyXchg cver content
Finished fdata -> processClientFinished fdata
_ -> return ()
return $ Handshake hs
return hs
where
-- secure renegotiation
processClientExtension (0xff01, content) = do

82
Network/TLS/Sending.hs
View file

@ -76,27 +76,23 @@ encodePacket (hdr, content) = return $ B.concat [ encodeHeader hdr, content ]
{-
- just update TLS state machine
-}
preProcessPacket :: Packet -> TLSSt Packet
preProcessPacket pkt = do
-- FIXME don't ignore this error just in case
_ <- case pkt of
Handshake hs -> do
e <- updateStatusHs (typeOfHandshake hs)
case hs of
Finished fdata -> updateVerifiedData True fdata
_ -> return ()
return e
AppData _ -> return Nothing
ChangeCipherSpec -> updateStatusCC True
Alert _ -> return Nothing
return pkt
preProcessPacket :: Packet -> TLSSt ()
preProcessPacket (Alert _) = return ()
preProcessPacket (AppData _) = 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 ()
{-
- writePacket transform a packet into marshalled data related to current state
- and updating state on the go
-}
writePacket :: Packet -> TLSSt ByteString
writePacket pkt = preProcessPacket pkt >>= makePacketData >>= processPacketData >>=
writePacket pkt = preProcessPacket pkt >> makePacketData pkt >>= processPacketData >>=
encryptPacketData >>= postprocessPacketData >>= encodePacket
{------------------------------------------------------------------------------}
@ -159,37 +155,35 @@ encryptData content = do
put $ st { stTxCryptState = Just $ cst { cstIV = newiv } }
return e
encodePacketContent :: Packet -> ByteString
encodePacketContent (Handshake h) = encodeHandshake h
encodePacketContent (Alert a) = encodeAlert a
encodePacketContent (ChangeCipherSpec) = encodeChangeCipherSpec
encodePacketContent (AppData x) = x
writePacketContent :: Packet -> TLSSt ByteString
writePacketContent (Handshake ckx@(ClientKeyXchg _ _)) = do
ver <- get >>= return . stVersion
let premastersecret = runPut $ encodeHandshakeContent ckx
setMasterSecret premastersecret
econtent <- encryptRSA premastersecret
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 ckx)
(fromIntegral (B.length econtent + B.length extralength))
return $ B.concat [hdr, extralength, econtent]
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]
writePacketContent pkt@(Handshake (ClientHello ver crand _ _ _ _)) = do
cc <- isClientContext
when cc (startHandshakeClient ver crand)
return $ encodePacketContent pkt
makeContent hs@(ClientHello ver crand _ _ _ _) = do
cc <- isClientContext
when cc (startHandshakeClient ver crand)
return $ encodeHandshakes [hs]
makeContent hs@(ServerHello ver srand _ _ _ _) = do
cc <- isClientContext
unless cc $ do
setVersion ver
setServerRandom srand
return $ encodeHandshakes [hs]
writePacketContent pkt@(Handshake (ServerHello ver srand _ _ _ _)) = do
cc <- isClientContext
unless cc $ do
setVersion ver
setServerRandom srand
return $ encodePacketContent pkt
makeContent hs = return $ encodeHandshakes [hs]
writePacketContent pkt = return $ encodePacketContent pkt
writePacketContent (Alert a) = return $ encodeAlerts a
writePacketContent (ChangeCipherSpec) = return $ encodeChangeCipherSpec
writePacketContent (AppData x) = return x

4
Network/TLS/Struct.hs
View file

@ -130,8 +130,8 @@ instance Error TLSError where
instance Exception TLSError
data Packet =
Handshake Handshake
| Alert (AlertLevel, AlertDescription)
Handshake [Handshake]
| Alert [(AlertLevel, AlertDescription)]
| ChangeCipherSpec
| AppData ByteString
deriving (Show,Eq)