1{-# LANGUAGE OverloadedStrings #-} 2-- | 3-- Module : Network.TLS.Packet 4-- License : BSD-style 5-- Maintainer : Vincent Hanquez <vincent@snarc.org> 6-- Stability : experimental 7-- Portability : unknown 8-- 9-- the Packet module contains everything necessary to serialize and deserialize things 10-- with only explicit parameters, no TLS state is involved here. 11-- 12module Network.TLS.Packet 13 ( 14 -- * params for encoding and decoding 15 CurrentParams(..) 16 -- * marshall functions for header messages 17 , decodeHeader 18 , decodeDeprecatedHeaderLength 19 , decodeDeprecatedHeader 20 , encodeHeader 21 , encodeHeaderNoVer -- use for SSL3 22 23 -- * marshall functions for alert messages 24 , decodeAlert 25 , decodeAlerts 26 , encodeAlerts 27 28 -- * marshall functions for handshake messages 29 , decodeHandshakeRecord 30 , decodeHandshake 31 , decodeDeprecatedHandshake 32 , encodeHandshake 33 , encodeHandshakeHeader 34 , encodeHandshakeContent 35 36 -- * marshall functions for change cipher spec message 37 , decodeChangeCipherSpec 38 , encodeChangeCipherSpec 39 40 , decodePreMasterSecret 41 , encodePreMasterSecret 42 , encodeSignedDHParams 43 , encodeSignedECDHParams 44 45 , decodeReallyServerKeyXchgAlgorithmData 46 47 -- * generate things for packet content 48 , generateMasterSecret 49 , generateExtendedMasterSec 50 , generateKeyBlock 51 , generateClientFinished 52 , generateServerFinished 53 54 , generateCertificateVerify_SSL 55 , generateCertificateVerify_SSL_DSS 56 57 -- * for extensions parsing 58 , getSignatureHashAlgorithm 59 , putSignatureHashAlgorithm 60 , getBinaryVersion 61 , putBinaryVersion 62 , getClientRandom32 63 , putClientRandom32 64 , getServerRandom32 65 , putServerRandom32 66 , getExtensions 67 , putExtension 68 , getSession 69 , putSession 70 , putDNames 71 , getDNames 72 ) where 73 74import Network.TLS.Imports 75import Network.TLS.Struct 76import Network.TLS.Wire 77import Network.TLS.Cap 78import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain) 79import Network.TLS.Crypto 80import Network.TLS.MAC 81import Network.TLS.Cipher (CipherKeyExchangeType(..), Cipher(..)) 82import Network.TLS.Util.ASN1 83import qualified Data.ByteString as B 84import qualified Data.ByteString.Char8 as BC 85import Data.ByteArray (ByteArrayAccess) 86import qualified Data.ByteArray as B (convert) 87 88data CurrentParams = CurrentParams 89 { cParamsVersion :: Version -- ^ current protocol version 90 , cParamsKeyXchgType :: Maybe CipherKeyExchangeType -- ^ current key exchange type 91 } deriving (Show,Eq) 92 93{- marshall helpers -} 94getVersion :: Get Version 95getVersion = do 96 major <- getWord8 97 minor <- getWord8 98 case verOfNum (major, minor) of 99 Nothing -> fail ("invalid version : " ++ show major ++ "," ++ show minor) 100 Just v -> return v 101 102getBinaryVersion :: Get (Maybe Version) 103getBinaryVersion = do 104 major <- getWord8 105 minor <- getWord8 106 return $ verOfNum (major, minor) 107 108putBinaryVersion :: Version -> Put 109putBinaryVersion ver = putWord8 major >> putWord8 minor 110 where (major, minor) = numericalVer ver 111 112getHeaderType :: Get ProtocolType 113getHeaderType = do 114 ty <- getWord8 115 case valToType ty of 116 Nothing -> fail ("invalid header type: " ++ show ty) 117 Just t -> return t 118 119putHeaderType :: ProtocolType -> Put 120putHeaderType = putWord8 . valOfType 121 122getHandshakeType :: Get HandshakeType 123getHandshakeType = do 124 ty <- getWord8 125 case valToType ty of 126 Nothing -> fail ("invalid handshake type: " ++ show ty) 127 Just t -> return t 128 129{- 130 - decode and encode headers 131 -} 132decodeHeader :: ByteString -> Either TLSError Header 133decodeHeader = runGetErr "header" $ Header <$> getHeaderType <*> getVersion <*> getWord16 134 135decodeDeprecatedHeaderLength :: ByteString -> Either TLSError Word16 136decodeDeprecatedHeaderLength = runGetErr "deprecatedheaderlength" $ subtract 0x8000 <$> getWord16 137 138decodeDeprecatedHeader :: Word16 -> ByteString -> Either TLSError Header 139decodeDeprecatedHeader size = 140 runGetErr "deprecatedheader" $ do 141 1 <- getWord8 142 version <- getVersion 143 return $ Header ProtocolType_DeprecatedHandshake version size 144 145encodeHeader :: Header -> ByteString 146encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putBinaryVersion ver >> putWord16 len) 147 {- FIXME check len <= 2^14 -} 148 149encodeHeaderNoVer :: Header -> ByteString 150encodeHeaderNoVer (Header pt _ len) = runPut (putHeaderType pt >> putWord16 len) 151 {- FIXME check len <= 2^14 -} 152 153{- 154 - decode and encode ALERT 155 -} 156decodeAlert :: Get (AlertLevel, AlertDescription) 157decodeAlert = do 158 al <- getWord8 159 ad <- getWord8 160 case (valToType al, valToType ad) of 161 (Just a, Just d) -> return (a, d) 162 (Nothing, _) -> fail "cannot decode alert level" 163 (_, Nothing) -> fail "cannot decode alert description" 164 165decodeAlerts :: ByteString -> Either TLSError [(AlertLevel, AlertDescription)] 166decodeAlerts = runGetErr "alerts" loop 167 where loop = do 168 r <- remaining 169 if r == 0 170 then return [] 171 else (:) <$> decodeAlert <*> loop 172 173encodeAlerts :: [(AlertLevel, AlertDescription)] -> ByteString 174encodeAlerts l = runPut $ mapM_ encodeAlert l 175 where encodeAlert (al, ad) = putWord8 (valOfType al) >> putWord8 (valOfType ad) 176 177{- decode and encode HANDSHAKE -} 178decodeHandshakeRecord :: ByteString -> GetResult (HandshakeType, ByteString) 179decodeHandshakeRecord = runGet "handshake-record" $ do 180 ty <- getHandshakeType 181 content <- getOpaque24 182 return (ty, content) 183 184decodeHandshake :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake 185decodeHandshake cp ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of 186 HandshakeType_HelloRequest -> decodeHelloRequest 187 HandshakeType_ClientHello -> decodeClientHello 188 HandshakeType_ServerHello -> decodeServerHello 189 HandshakeType_Certificate -> decodeCertificates 190 HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp 191 HandshakeType_CertRequest -> decodeCertRequest cp 192 HandshakeType_ServerHelloDone -> decodeServerHelloDone 193 HandshakeType_CertVerify -> decodeCertVerify cp 194 HandshakeType_ClientKeyXchg -> decodeClientKeyXchg cp 195 HandshakeType_Finished -> decodeFinished 196 197decodeDeprecatedHandshake :: ByteString -> Either TLSError Handshake 198decodeDeprecatedHandshake b = runGetErr "deprecatedhandshake" getDeprecated b 199 where getDeprecated = do 200 1 <- getWord8 201 ver <- getVersion 202 cipherSpecLen <- fromEnum <$> getWord16 203 sessionIdLen <- fromEnum <$> getWord16 204 challengeLen <- fromEnum <$> getWord16 205 ciphers <- getCipherSpec cipherSpecLen 206 session <- getSessionId sessionIdLen 207 random <- getChallenge challengeLen 208 let compressions = [0] 209 return $ ClientHello ver random session ciphers compressions [] (Just b) 210 getCipherSpec len | len < 3 = return [] 211 getCipherSpec len = do 212 [c0,c1,c2] <- map fromEnum <$> replicateM 3 getWord8 213 ([ toEnum $ c1 * 0x100 + c2 | c0 == 0 ] ++) <$> getCipherSpec (len - 3) 214 getSessionId 0 = return $ Session Nothing 215 getSessionId len = Session . Just <$> getBytes len 216 getChallenge len | 32 < len = getBytes (len - 32) >> getChallenge 32 217 getChallenge len = ClientRandom . B.append (B.replicate (32 - len) 0) <$> getBytes len 218 219decodeHelloRequest :: Get Handshake 220decodeHelloRequest = return HelloRequest 221 222decodeClientHello :: Get Handshake 223decodeClientHello = do 224 ver <- getVersion 225 random <- getClientRandom32 226 session <- getSession 227 ciphers <- getWords16 228 compressions <- getWords8 229 r <- remaining 230 exts <- if hasHelloExtensions ver && r > 0 231 then fromIntegral <$> getWord16 >>= getExtensions 232 else return [] 233 return $ ClientHello ver random session ciphers compressions exts Nothing 234 235decodeServerHello :: Get Handshake 236decodeServerHello = do 237 ver <- getVersion 238 random <- getServerRandom32 239 session <- getSession 240 cipherid <- getWord16 241 compressionid <- getWord8 242 r <- remaining 243 exts <- if hasHelloExtensions ver && r > 0 244 then fromIntegral <$> getWord16 >>= getExtensions 245 else return [] 246 return $ ServerHello ver random session cipherid compressionid exts 247 248decodeServerHelloDone :: Get Handshake 249decodeServerHelloDone = return ServerHelloDone 250 251decodeCertificates :: Get Handshake 252decodeCertificates = do 253 certsRaw <- CertificateChainRaw <$> (getWord24 >>= \len -> getList (fromIntegral len) getCertRaw) 254 case decodeCertificateChain certsRaw of 255 Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s) 256 Right cc -> return $ Certificates cc 257 where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) 258 259decodeFinished :: Get Handshake 260decodeFinished = Finished <$> (remaining >>= getBytes) 261 262decodeCertRequest :: CurrentParams -> Get Handshake 263decodeCertRequest cp = do 264 mcertTypes <- map (valToType . fromIntegral) <$> getWords8 265 certTypes <- mapM (fromJustM "decodeCertRequest") mcertTypes 266 sigHashAlgs <- if cParamsVersion cp >= TLS12 267 then Just <$> (getWord16 >>= getSignatureHashAlgorithms) 268 else return Nothing 269 CertRequest certTypes sigHashAlgs <$> getDNames 270 where getSignatureHashAlgorithms len = getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) 271 272-- | Decode a list CA distinguished names 273getDNames :: Get [DistinguishedName] 274getDNames = do 275 dNameLen <- getWord16 276 -- FIXME: Decide whether to remove this check completely or to make it an option. 277 -- when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size" 278 getList (fromIntegral dNameLen) getDName 279 where 280 getDName = do 281 dName <- getOpaque16 282 when (B.length dName == 0) $ fail "certrequest: invalid DN length" 283 dn <- either fail return $ decodeASN1Object "cert request DistinguishedName" dName 284 return (2 + B.length dName, dn) 285 286decodeCertVerify :: CurrentParams -> Get Handshake 287decodeCertVerify cp = CertVerify <$> getDigitallySigned (cParamsVersion cp) 288 289decodeClientKeyXchg :: CurrentParams -> Get Handshake 290decodeClientKeyXchg cp = -- case ClientKeyXchg <$> (remaining >>= getBytes) 291 case cParamsKeyXchgType cp of 292 Nothing -> error "no client key exchange type" 293 Just cke -> ClientKeyXchg <$> parseCKE cke 294 where parseCKE CipherKeyExchange_RSA = CKX_RSA <$> (remaining >>= getBytes) 295 parseCKE CipherKeyExchange_DHE_RSA = parseClientDHPublic 296 parseCKE CipherKeyExchange_DHE_DSS = parseClientDHPublic 297 parseCKE CipherKeyExchange_DH_Anon = parseClientDHPublic 298 parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic 299 parseCKE CipherKeyExchange_ECDHE_ECDSA = parseClientECDHPublic 300 parseCKE _ = error "unsupported client key exchange type" 301 parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16 302 parseClientECDHPublic = CKX_ECDH <$> getOpaque8 303 304decodeServerKeyXchg_DH :: Get ServerDHParams 305decodeServerKeyXchg_DH = getServerDHParams 306 307-- We don't support ECDH_Anon at this moment 308-- decodeServerKeyXchg_ECDH :: Get ServerECDHParams 309 310decodeServerKeyXchg_RSA :: Get ServerRSAParams 311decodeServerKeyXchg_RSA = ServerRSAParams <$> getInteger16 -- modulus 312 <*> getInteger16 -- exponent 313 314decodeServerKeyXchgAlgorithmData :: Version 315 -> CipherKeyExchangeType 316 -> Get ServerKeyXchgAlgorithmData 317decodeServerKeyXchgAlgorithmData ver cke = toCKE 318 where toCKE = case cke of 319 CipherKeyExchange_RSA -> SKX_RSA . Just <$> decodeServerKeyXchg_RSA 320 CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH 321 CipherKeyExchange_DHE_RSA -> do 322 dhparams <- getServerDHParams 323 signature <- getDigitallySigned ver 324 return $ SKX_DHE_RSA dhparams signature 325 CipherKeyExchange_DHE_DSS -> do 326 dhparams <- getServerDHParams 327 signature <- getDigitallySigned ver 328 return $ SKX_DHE_DSS dhparams signature 329 CipherKeyExchange_ECDHE_RSA -> do 330 ecdhparams <- getServerECDHParams 331 signature <- getDigitallySigned ver 332 return $ SKX_ECDHE_RSA ecdhparams signature 333 CipherKeyExchange_ECDHE_ECDSA -> do 334 ecdhparams <- getServerECDHParams 335 signature <- getDigitallySigned ver 336 return $ SKX_ECDHE_ECDSA ecdhparams signature 337 _ -> do 338 bs <- remaining >>= getBytes 339 return $ SKX_Unknown bs 340 341decodeServerKeyXchg :: CurrentParams -> Get Handshake 342decodeServerKeyXchg cp = 343 case cParamsKeyXchgType cp of 344 Just cke -> ServerKeyXchg <$> decodeServerKeyXchgAlgorithmData (cParamsVersion cp) cke 345 Nothing -> ServerKeyXchg . SKX_Unparsed <$> (remaining >>= getBytes) 346 347encodeHandshake :: Handshake -> ByteString 348encodeHandshake o = 349 let content = runPut $ encodeHandshakeContent o in 350 let len = B.length content in 351 let header = case o of 352 ClientHello _ _ _ _ _ _ (Just _) -> "" -- SSLv2 ClientHello message 353 _ -> runPut $ encodeHandshakeHeader (typeOfHandshake o) len in 354 B.concat [ header, content ] 355 356encodeHandshakeHeader :: HandshakeType -> Int -> Put 357encodeHandshakeHeader ty len = putWord8 (valOfType ty) >> putWord24 len 358 359encodeHandshakeContent :: Handshake -> Put 360 361encodeHandshakeContent (ClientHello _ _ _ _ _ _ (Just deprecated)) = do 362 putBytes deprecated 363encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts Nothing) = do 364 putBinaryVersion version 365 putClientRandom32 random 366 putSession session 367 putWords16 cipherIDs 368 putWords8 compressionIDs 369 putExtensions exts 370 return () 371 372encodeHandshakeContent (ServerHello version random session cipherid compressionID exts) = do 373 putBinaryVersion version 374 putServerRandom32 random 375 putSession session 376 putWord16 cipherid 377 putWord8 compressionID 378 putExtensions exts 379 return () 380 381encodeHandshakeContent (Certificates cc) = putOpaque24 (runPut $ mapM_ putOpaque24 certs) 382 where (CertificateChainRaw certs) = encodeCertificateChain cc 383 384encodeHandshakeContent (ClientKeyXchg ckx) = do 385 case ckx of 386 CKX_RSA encryptedPreMaster -> putBytes encryptedPreMaster 387 CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic 388 CKX_ECDH bytes -> putOpaque8 bytes 389 390encodeHandshakeContent (ServerKeyXchg skg) = 391 case skg of 392 SKX_RSA _ -> error "encodeHandshakeContent SKX_RSA not implemented" 393 SKX_DH_Anon params -> putServerDHParams params 394 SKX_DHE_RSA params sig -> putServerDHParams params >> putDigitallySigned sig 395 SKX_DHE_DSS params sig -> putServerDHParams params >> putDigitallySigned sig 396 SKX_ECDHE_RSA params sig -> putServerECDHParams params >> putDigitallySigned sig 397 SKX_ECDHE_ECDSA params sig -> putServerECDHParams params >> putDigitallySigned sig 398 SKX_Unparsed bytes -> putBytes bytes 399 _ -> error ("encodeHandshakeContent: cannot handle: " ++ show skg) 400 401encodeHandshakeContent HelloRequest = return () 402encodeHandshakeContent ServerHelloDone = return () 403 404encodeHandshakeContent (CertRequest certTypes sigAlgs certAuthorities) = do 405 putWords8 (map valOfType certTypes) 406 case sigAlgs of 407 Nothing -> return () 408 Just l -> putWords16 $ map (\(x,y) -> fromIntegral (valOfType x) * 256 + fromIntegral (valOfType y)) l 409 putDNames certAuthorities 410 411encodeHandshakeContent (CertVerify digitallySigned) = putDigitallySigned digitallySigned 412 413encodeHandshakeContent (Finished opaque) = putBytes opaque 414 415------------------------------------------------------------ 416 417-- | Encode a list of distinguished names. 418putDNames :: [DistinguishedName] -> Put 419putDNames dnames = do 420 enc <- mapM encodeCA dnames 421 let totLength = sum $ map ((+) 2 . B.length) enc 422 putWord16 (fromIntegral totLength) 423 mapM_ (\ b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc 424 where 425 -- Convert a distinguished name to its DER encoding. 426 encodeCA dn = return $ encodeASN1Object dn 427 428{- FIXME make sure it return error if not 32 available -} 429getRandom32 :: Get ByteString 430getRandom32 = getBytes 32 431 432getServerRandom32 :: Get ServerRandom 433getServerRandom32 = ServerRandom <$> getRandom32 434 435getClientRandom32 :: Get ClientRandom 436getClientRandom32 = ClientRandom <$> getRandom32 437 438putRandom32 :: ByteString -> Put 439putRandom32 = putBytes 440 441putClientRandom32 :: ClientRandom -> Put 442putClientRandom32 (ClientRandom r) = putRandom32 r 443 444putServerRandom32 :: ServerRandom -> Put 445putServerRandom32 (ServerRandom r) = putRandom32 r 446 447getSession :: Get Session 448getSession = do 449 len8 <- getWord8 450 case fromIntegral len8 of 451 0 -> return $ Session Nothing 452 len -> Session . Just <$> getBytes len 453 454putSession :: Session -> Put 455putSession (Session Nothing) = putWord8 0 456putSession (Session (Just s)) = putOpaque8 s 457 458getExtensions :: Int -> Get [ExtensionRaw] 459getExtensions 0 = return [] 460getExtensions len = do 461 extty <- getWord16 462 extdatalen <- getWord16 463 extdata <- getBytes $ fromIntegral extdatalen 464 extxs <- getExtensions (len - fromIntegral extdatalen - 4) 465 return $ ExtensionRaw extty extdata : extxs 466 467putExtension :: ExtensionRaw -> Put 468putExtension (ExtensionRaw ty l) = putWord16 ty >> putOpaque16 l 469 470putExtensions :: [ExtensionRaw] -> Put 471putExtensions [] = return () 472putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) 473 474getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm 475getSignatureHashAlgorithm = do 476 h <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm" 477 s <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm" 478 return (h,s) 479 480putSignatureHashAlgorithm :: HashAndSignatureAlgorithm -> Put 481putSignatureHashAlgorithm (h,s) = 482 putWord8 (valOfType h) >> putWord8 (valOfType s) 483 484getServerDHParams :: Get ServerDHParams 485getServerDHParams = ServerDHParams <$> getBigNum16 <*> getBigNum16 <*> getBigNum16 486 487putServerDHParams :: ServerDHParams -> Put 488putServerDHParams (ServerDHParams p g y) = mapM_ putBigNum16 [p,g,y] 489 490-- RFC 4492 Section 5.4 Server Key Exchange 491getServerECDHParams :: Get ServerECDHParams 492getServerECDHParams = do 493 curveType <- getWord8 494 case curveType of 495 3 -> do -- ECParameters ECCurveType: curve name type 496 mgrp <- toEnumSafe16 <$> getWord16 -- ECParameters NamedCurve 497 case mgrp of 498 Nothing -> error "getServerECDHParams: unknown group" 499 Just grp -> do 500 mxy <- getOpaque8 -- ECPoint 501 case decodeGroupPublic grp mxy of 502 Left e -> error $ "getServerECDHParams: " ++ show e 503 Right grppub -> return $ ServerECDHParams grp grppub 504 _ -> 505 error "getServerECDHParams: unknown type for ECDH Params" 506 507-- RFC 4492 Section 5.4 Server Key Exchange 508putServerECDHParams :: ServerECDHParams -> Put 509putServerECDHParams (ServerECDHParams grp grppub) = do 510 putWord8 3 -- ECParameters ECCurveType 511 putWord16 $ fromEnumSafe16 grp -- ECParameters NamedCurve 512 putOpaque8 $ encodeGroupPublic grppub -- ECPoint 513 514getDigitallySigned :: Version -> Get DigitallySigned 515getDigitallySigned ver 516 | ver >= TLS12 = DigitallySigned <$> (Just <$> getSignatureHashAlgorithm) 517 <*> getOpaque16 518 | otherwise = DigitallySigned Nothing <$> getOpaque16 519 520putDigitallySigned :: DigitallySigned -> Put 521putDigitallySigned (DigitallySigned mhash sig) = 522 maybe (return ()) putSignatureHashAlgorithm mhash >> putOpaque16 sig 523 524{- 525 - decode and encode ALERT 526 -} 527 528decodeChangeCipherSpec :: ByteString -> Either TLSError () 529decodeChangeCipherSpec = runGetErr "changecipherspec" $ do 530 x <- getWord8 531 when (x /= 1) (fail "unknown change cipher spec content") 532 533encodeChangeCipherSpec :: ByteString 534encodeChangeCipherSpec = runPut (putWord8 1) 535 536-- rsa pre master secret 537decodePreMasterSecret :: ByteString -> Either TLSError (Version, ByteString) 538decodePreMasterSecret = runGetErr "pre-master-secret" $ 539 (,) <$> getVersion <*> getBytes 46 540 541encodePreMasterSecret :: Version -> ByteString -> ByteString 542encodePreMasterSecret version bytes = runPut (putBinaryVersion version >> putBytes bytes) 543 544-- | in certain cases, we haven't manage to decode ServerKeyExchange properly, 545-- because the decoding was too eager and the cipher wasn't been set yet. 546-- we keep the Server Key Exchange in it unparsed format, and this function is 547-- able to really decode the server key xchange if it's unparsed. 548decodeReallyServerKeyXchgAlgorithmData :: Version 549 -> CipherKeyExchangeType 550 -> ByteString 551 -> Either TLSError ServerKeyXchgAlgorithmData 552decodeReallyServerKeyXchgAlgorithmData ver cke = 553 runGetErr "server-key-xchg-algorithm-data" (decodeServerKeyXchgAlgorithmData ver cke) 554 555 556{- 557 - generate things for packet content 558 -} 559type PRF = ByteString -> ByteString -> Int -> ByteString 560 561-- | The TLS12 PRF is cipher specific, and some TLS12 algorithms use SHA384 562-- instead of the default SHA256. 563getPRF :: Version -> Cipher -> PRF 564getPRF ver ciph 565 | ver < TLS12 = prf_MD5SHA1 566 | maybe True (< TLS12) (cipherMinVer ciph) = prf_SHA256 567 | otherwise = prf_TLS ver $ fromMaybe SHA256 $ cipherPRFHash ciph 568 569generateMasterSecret_SSL :: ByteArrayAccess preMaster => preMaster -> ClientRandom -> ServerRandom -> ByteString 570generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) = 571 B.concat $ map computeMD5 ["A","BB","CCC"] 572 where computeMD5 label = hash MD5 $ B.concat [ B.convert premasterSecret, computeSHA1 label ] 573 computeSHA1 label = hash SHA1 $ B.concat [ label, B.convert premasterSecret, c, s ] 574 575generateMasterSecret_TLS :: ByteArrayAccess preMaster => PRF -> preMaster -> ClientRandom -> ServerRandom -> ByteString 576generateMasterSecret_TLS prf premasterSecret (ClientRandom c) (ServerRandom s) = 577 prf (B.convert premasterSecret) seed 48 578 where seed = B.concat [ "master secret", c, s ] 579 580generateMasterSecret :: ByteArrayAccess preMaster 581 => Version 582 -> Cipher 583 -> preMaster 584 -> ClientRandom 585 -> ServerRandom 586 -> ByteString 587generateMasterSecret SSL2 _ = generateMasterSecret_SSL 588generateMasterSecret SSL3 _ = generateMasterSecret_SSL 589generateMasterSecret v c = generateMasterSecret_TLS $ getPRF v c 590 591generateExtendedMasterSec :: ByteArrayAccess preMaster 592 => Version 593 -> Cipher 594 -> preMaster 595 -> ByteString 596 -> ByteString 597generateExtendedMasterSec v c premasterSecret sessionHash = 598 getPRF v c (B.convert premasterSecret) seed 48 599 where seed = B.append "extended master secret" sessionHash 600 601generateKeyBlock_TLS :: PRF -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString 602generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mastersecret kbsize = 603 prf mastersecret seed kbsize where seed = B.concat [ "key expansion", s, c ] 604 605generateKeyBlock_SSL :: ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString 606generateKeyBlock_SSL (ClientRandom c) (ServerRandom s) mastersecret kbsize = 607 B.concat $ map computeMD5 $ take ((kbsize `div` 16) + 1) labels 608 where labels = [ uncurry BC.replicate x | x <- zip [1..] ['A'..'Z'] ] 609 computeMD5 label = hash MD5 $ B.concat [ mastersecret, computeSHA1 label ] 610 computeSHA1 label = hash SHA1 $ B.concat [ label, mastersecret, s, c ] 611 612generateKeyBlock :: Version 613 -> Cipher 614 -> ClientRandom 615 -> ServerRandom 616 -> ByteString 617 -> Int 618 -> ByteString 619generateKeyBlock SSL2 _ = generateKeyBlock_SSL 620generateKeyBlock SSL3 _ = generateKeyBlock_SSL 621generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c 622 623generateFinished_TLS :: PRF -> ByteString -> ByteString -> HashCtx -> ByteString 624generateFinished_TLS prf label mastersecret hashctx = prf mastersecret seed 12 625 where seed = B.concat [ label, hashFinal hashctx ] 626 627generateFinished_SSL :: ByteString -> ByteString -> HashCtx -> ByteString 628generateFinished_SSL sender mastersecret hashctx = B.concat [md5hash, sha1hash] 629 where md5hash = hash MD5 $ B.concat [ mastersecret, pad2, md5left ] 630 sha1hash = hash SHA1 $ B.concat [ mastersecret, B.take 40 pad2, sha1left ] 631 632 lefthash = hashFinal $ flip hashUpdateSSL (pad1, B.take 40 pad1) 633 $ foldl hashUpdate hashctx [sender,mastersecret] 634 (md5left,sha1left) = B.splitAt 16 lefthash 635 pad2 = B.replicate 48 0x5c 636 pad1 = B.replicate 48 0x36 637 638generateClientFinished :: Version 639 -> Cipher 640 -> ByteString 641 -> HashCtx 642 -> ByteString 643generateClientFinished ver ciph 644 | ver < TLS10 = generateFinished_SSL "CLNT" 645 | otherwise = generateFinished_TLS (getPRF ver ciph) "client finished" 646 647generateServerFinished :: Version 648 -> Cipher 649 -> ByteString 650 -> HashCtx 651 -> ByteString 652generateServerFinished ver ciph 653 | ver < TLS10 = generateFinished_SSL "SRVR" 654 | otherwise = generateFinished_TLS (getPRF ver ciph) "server finished" 655 656{- returns *output* after final MD5/SHA1 -} 657generateCertificateVerify_SSL :: ByteString -> HashCtx -> ByteString 658generateCertificateVerify_SSL = generateFinished_SSL "" 659 660{- returns *input* before final SHA1 -} 661generateCertificateVerify_SSL_DSS :: ByteString -> HashCtx -> ByteString 662generateCertificateVerify_SSL_DSS mastersecret hashctx = toHash 663 where toHash = B.concat [ mastersecret, pad2, sha1left ] 664 665 sha1left = hashFinal $ flip hashUpdate pad1 666 $ hashUpdate hashctx mastersecret 667 pad2 = B.replicate 40 0x5c 668 pad1 = B.replicate 40 0x36 669 670encodeSignedDHParams :: ServerDHParams -> ClientRandom -> ServerRandom -> ByteString 671encodeSignedDHParams dhparams cran sran = runPut $ 672 putClientRandom32 cran >> putServerRandom32 sran >> putServerDHParams dhparams 673 674-- Combination of RFC 5246 and 4492 is ambiguous. 675-- Let's assume ecdhe_rsa and ecdhe_dss are identical to 676-- dhe_rsa and dhe_dss. 677encodeSignedECDHParams :: ServerECDHParams -> ClientRandom -> ServerRandom -> ByteString 678encodeSignedECDHParams dhparams cran sran = runPut $ 679 putClientRandom32 cran >> putServerRandom32 sran >> putServerECDHParams dhparams 680 681fromJustM :: MonadFail m => String -> Maybe a -> m a 682fromJustM what Nothing = fail ("fromJustM " ++ what ++ ": Nothing") 683fromJustM _ (Just x) = return x 684