1-- |
2-- Module      : Network.TLS.Record.Disengage
3-- License     : BSD-style
4-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
5-- Stability   : experimental
6-- Portability : unknown
7--
8-- Disengage a record from the Record layer.
9-- The record is decrypted, checked for integrity and then decompressed.
10--
11-- Starting with TLS v1.3, only the "null" compression method is negotiated in
12-- the handshake, so the decompression step will be a no-op.  Decryption and
13-- integrity verification are performed using an AEAD cipher only.
14--
15{-# LANGUAGE FlexibleContexts #-}
16
17module Network.TLS.Record.Disengage
18        ( disengageRecord
19        ) where
20
21import Control.Monad.State.Strict
22
23import Crypto.Cipher.Types (AuthTag(..))
24import Network.TLS.Struct
25import Network.TLS.ErrT
26import Network.TLS.Cap
27import Network.TLS.Record.State
28import Network.TLS.Record.Types
29import Network.TLS.Cipher
30import Network.TLS.Crypto
31import Network.TLS.Compression
32import Network.TLS.Util
33import Network.TLS.Wire
34import Network.TLS.Packet
35import Network.TLS.Imports
36import qualified Data.ByteString as B
37import qualified Data.ByteArray as B (convert, xor)
38
39disengageRecord :: Record Ciphertext -> RecordM (Record Plaintext)
40disengageRecord = decryptRecord >=> uncompressRecord
41
42uncompressRecord :: Record Compressed -> RecordM (Record Plaintext)
43uncompressRecord record = onRecordFragment record $ fragmentUncompress $ \bytes ->
44    withCompression $ compressionInflate bytes
45
46decryptRecord :: Record Ciphertext -> RecordM (Record Compressed)
47decryptRecord record@(Record ct ver fragment) = do
48    st <- get
49    case stCipher st of
50        Nothing -> noDecryption
51        _       -> do
52            recOpts <- getRecordOptions
53            let mver = recordVersion recOpts
54            if recordTLS13 recOpts
55                then decryptData13 mver (fragmentGetBytes fragment) st
56                else onRecordFragment record $ fragmentUncipher $ \e ->
57                        decryptData mver record e st
58  where
59    noDecryption = onRecordFragment record $ fragmentUncipher return
60    decryptData13 mver e st
61        | ct == ProtocolType_AppData = do
62            inner <- decryptData mver record e st
63            case unInnerPlaintext inner of
64                Left message   -> throwError $ Error_Protocol (message, True, UnexpectedMessage)
65                Right (ct', d) -> return $ Record ct' ver (fragmentCompressed d)
66        | otherwise = noDecryption
67
68unInnerPlaintext :: ByteString -> Either String (ProtocolType, ByteString)
69unInnerPlaintext inner =
70    case B.unsnoc dc of
71        Nothing         -> Left $ unknownContentType13 (0 :: Word8)
72        Just (bytes,c)  ->
73            case valToType c of
74                Nothing -> Left $ unknownContentType13 c
75                Just ct
76                    | B.null bytes && ct `elem` nonEmptyContentTypes ->
77                        Left ("empty " ++ show ct ++ " record disallowed")
78                    | otherwise -> Right (ct, bytes)
79  where
80    (dc,_pad) = B.spanEnd (== 0) inner
81    nonEmptyContentTypes   = [ ProtocolType_Handshake, ProtocolType_Alert ]
82    unknownContentType13 c = "unknown TLS 1.3 content type: " ++ show c
83
84getCipherData :: Record a -> CipherData -> RecordM ByteString
85getCipherData (Record pt ver _) cdata = do
86    -- check if the MAC is valid.
87    macValid <- case cipherDataMAC cdata of
88        Nothing     -> return True
89        Just digest -> do
90            let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata)
91            expected_digest <- makeDigest new_hdr $ cipherDataContent cdata
92            return (expected_digest `bytesEq` digest)
93
94    -- check if the padding is filled with the correct pattern if it exists
95    -- (before TLS10 this checks instead that the padding length is minimal)
96    paddingValid <- case cipherDataPadding cdata of
97        Nothing           -> return True
98        Just (pad, blksz) -> do
99            cver <- getRecordVersion
100            let b = B.length pad - 1
101            return $ if cver < TLS10
102                then b < blksz
103                else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad
104
105    unless (macValid &&! paddingValid) $
106        throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)
107
108    return $ cipherDataContent cdata
109
110decryptData :: Version -> Record Ciphertext -> ByteString -> RecordState -> RecordM ByteString
111decryptData ver record econtent tst = decryptOf (cstKey cst)
112  where cipher     = fromJust "cipher" $ stCipher tst
113        bulk       = cipherBulk cipher
114        cst        = stCryptState tst
115        macSize    = hashDigestSize $ cipherHash cipher
116        blockSize  = bulkBlockSize bulk
117        econtentLen = B.length econtent
118
119        explicitIV = hasExplicitBlockIV ver
120
121        sanityCheckError = throwError (Error_Packet "encrypted content too small for encryption parameters")
122
123        decryptOf :: BulkState -> RecordM ByteString
124        decryptOf (BulkStateBlock decryptF) = do
125            let minContent = (if explicitIV then bulkIVSize bulk else 0) + max (macSize + 1) blockSize
126
127            -- check if we have enough bytes to cover the minimum for this cipher
128            when ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent) sanityCheckError
129
130            {- update IV -}
131            (iv, econtent') <- if explicitIV
132                                  then get2o econtent (bulkIVSize bulk, econtentLen - bulkIVSize bulk)
133                                  else return (cstIV cst, econtent)
134            let (content', iv') = decryptF iv econtent'
135            modify $ \txs -> txs { stCryptState = cst { cstIV = iv' } }
136
137            let paddinglength = fromIntegral (B.last content') + 1
138            let contentlen = B.length content' - paddinglength - macSize
139            (content, mac, padding) <- get3i content' (contentlen, macSize, paddinglength)
140            getCipherData record CipherData
141                    { cipherDataContent = content
142                    , cipherDataMAC     = Just mac
143                    , cipherDataPadding = Just (padding, blockSize)
144                    }
145
146        decryptOf (BulkStateStream (BulkStream decryptF)) = do
147            -- check if we have enough bytes to cover the minimum for this cipher
148            when (econtentLen < macSize) sanityCheckError
149
150            let (content', bulkStream') = decryptF econtent
151            {- update Ctx -}
152            let contentlen        = B.length content' - macSize
153            (content, mac) <- get2i content' (contentlen, macSize)
154            modify $ \txs -> txs { stCryptState = cst { cstKey = BulkStateStream bulkStream' } }
155            getCipherData record CipherData
156                    { cipherDataContent = content
157                    , cipherDataMAC     = Just mac
158                    , cipherDataPadding = Nothing
159                    }
160
161        decryptOf (BulkStateAEAD decryptF) = do
162            let authTagLen  = bulkAuthTagLen bulk
163                nonceExpLen = bulkExplicitIV bulk
164                cipherLen   = econtentLen - authTagLen - nonceExpLen
165
166            -- check if we have enough bytes to cover the minimum for this cipher
167            when (econtentLen < (authTagLen + nonceExpLen)) sanityCheckError
168
169            (enonce, econtent', authTag) <- get3o econtent (nonceExpLen, cipherLen, authTagLen)
170            let encodedSeq = encodeWord64 $ msSequence $ stMacState tst
171                iv = cstIV (stCryptState tst)
172                ivlen = B.length iv
173                Header typ v _ = recordToHeader record
174                hdrLen = if ver >= TLS13 then econtentLen else cipherLen
175                hdr = Header typ v $ fromIntegral hdrLen
176                ad | ver >= TLS13 = encodeHeader hdr
177                   | otherwise    = B.concat [ encodedSeq, encodeHeader hdr ]
178                sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq
179                nonce | nonceExpLen == 0 = B.xor iv sqnc
180                      | otherwise = iv `B.append` enonce
181                (content, authTag2) = decryptF nonce econtent' ad
182
183            when (AuthTag (B.convert authTag) /= authTag2) $
184                throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)
185
186            modify incrRecordState
187            return content
188
189        decryptOf BulkStateUninitialized =
190            throwError $ Error_Protocol ("decrypt state uninitialized", True, InternalError)
191
192        -- handling of outer format can report errors with Error_Packet
193        get3o s ls = maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls
194        get2o s (d1,d2) = get3o s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2)
195
196        -- all format errors related to decrypted content are reported
197        -- externally as integrity failures, i.e. BadRecordMac
198        get3i s ls = maybe (throwError $ Error_Protocol ("record bad format", True, BadRecordMac)) return $ partition3 s ls
199        get2i s (d1,d2) = get3i s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2)
200