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