cryptopals

Matasano's cryptopals challenges (cryptopals.com).
git clone git://git.jtobin.io/cryptopals.git
Log | Files | Refs | README | LICENSE

Attacks.hs (13578B)

      1 module Cryptopals.Block.Attacks (
      2     chaosEncrypter
      3   , alienEncrypter
      4   , weirdEncrypter
      5   ) where
      6 
      7 import Control.Monad
      8 import Control.Monad.Primitive
      9 import qualified Control.Monad.ST as ST
     10 import qualified Cryptopals.AES as AES
     11 import qualified Cryptopals.Util as CU
     12 import qualified Data.Bits as B
     13 import qualified Data.ByteString as BS
     14 import qualified Data.ByteString.Base16 as B16
     15 import qualified Data.ByteString.Base64 as B64
     16 import qualified Data.HashMap.Strict as HMS
     17 import qualified Data.List as L
     18 import qualified Data.Maybe as M
     19 import qualified Data.Set as S
     20 import qualified Data.Text as T
     21 import qualified Data.Text.Encoding as TE
     22 import GHC.Word (Word8)
     23 import qualified System.Random.MWC as MWC
     24 
     25 -- | An unknown AES key.
     26 consistentKey :: BS.ByteString
     27 consistentKey = ST.runST $ do
     28   gen <- MWC.create
     29   CU.bytes 16 gen
     30 
     31 chaosEncrypter
     32   :: PrimMonad m
     33   => BS.ByteString
     34   -> MWC.Gen (PrimState m)
     35   -> m BS.ByteString
     36 chaosEncrypter plaintext gen = do
     37   key  <- CU.bytes 16 gen
     38   pre  <- MWC.uniformR (5, 10) gen >>= flip CU.bytes gen
     39   pos  <- MWC.uniformR (5, 10) gen >>= flip CU.bytes gen
     40 
     41   let tex = pre <> plaintext <> pos
     42       bs  = CU.lpkcs7 tex
     43 
     44   ecb  <- MWC.uniform gen
     45 
     46   if   ecb
     47   then pure $ AES.encryptEcbAES128 key bs
     48   else do
     49     iv <- CU.bytes 16 gen
     50     pure $ AES.encryptCbcAES128 iv key bs
     51 
     52 alienEncrypter :: BS.ByteString -> BS.ByteString
     53 alienEncrypter plaintext =
     54   let pos = B64.decodeBase64Lenient $ mconcat [
     55           "Um9sbGluJyBpbiBteSA1LjAKV2l0aCBteSByYWctdG9wIGRvd24gc28gbXkg"
     56         , "aGFpciBjYW4gYmxvdwpUaGUgZ2lybGllcyBvbiBzdGFuZGJ5IHdhdmluZyBq"
     57         , "dXN0IHRvIHNheSBoaQpEaWQgeW91IHN0b3A/IE5vLCBJIGp1c3QgZHJvdmUg"
     58         , "YnkK"
     59         ]
     60 
     61       par = plaintext <> pos
     62       bs  = CU.lpkcs7 par
     63 
     64   in  AES.encryptEcbAES128 consistentKey bs
     65 
     66 ciphertextMap
     67   :: (BS.ByteString -> BS.ByteString)
     68   -> BS.ByteString
     69   -> HMS.HashMap BS.ByteString Word8
     70 ciphertextMap oracle input = loop [0..255] mempty where
     71   loop ps !acc = case ps of
     72     []    -> acc
     73     (h:t) ->
     74       let key = BS.take (CU.roundUpToMul 16 (BS.length input)) $
     75                   oracle (input <> BS.singleton h)
     76       in  loop t (HMS.insert key h acc)
     77 
     78 mciphertextMap
     79   :: PrimMonad m
     80   => (BS.ByteString -> MWC.Gen (PrimState m) -> m BS.ByteString)
     81   -> BS.ByteString
     82   -> MWC.Gen (PrimState m)
     83   -> m (HMS.HashMap BS.ByteString Word8)
     84 mciphertextMap oracle input = loop [0..255] mempty where
     85   loop ps !acc gen = case ps of
     86     []    -> pure acc
     87     (h:t) -> do
     88       ciph <- oracle (input <> BS.singleton h) gen
     89       let key = BS.take (CU.roundUpToMul 16 (BS.length input)) $ ciph
     90       loop t (HMS.insert key h acc) gen
     91 
     92 incrByteEcbAttack :: (BS.ByteString -> BS.ByteString) -> BS.ByteString
     93 incrByteEcbAttack oracle = loop input mempty where
     94   ciphertext = oracle mempty
     95   input      = BS.replicate (BS.length ciphertext - 1) 65
     96 
     97   loop !inp !plain = case BS.unsnoc inp of
     98     Nothing      -> plain
     99     Just (bs, _) ->
    100       let raw  = oracle inp
    101           quer = inp <> plain
    102           dict = ciphertextMap oracle quer
    103           key  = BS.take (CU.roundUpToMul 16 (BS.length input)) raw
    104       in  case HMS.lookup key dict of
    105             Nothing  -> plain -- XX need better stopping condition?
    106             Just byt -> loop bs (plain <> BS.singleton byt)
    107 
    108 -- XX something probably a little off here; sometimes returns truncated
    109 --    plaintexts
    110 hardIncrByteEcbAttack
    111   :: PrimMonad m
    112   => (BS.ByteString -> MWC.Gen (PrimState m) -> m BS.ByteString)
    113   -> MWC.Gen (PrimState m)
    114   -> m BS.ByteString
    115 hardIncrByteEcbAttack oracle gen = do
    116     ciphertext <- oracle mempty gen
    117     let input = BS.replicate (BS.length ciphertext - 1) 66
    118     loop input mempty gen
    119   where
    120     loop !inp !plain g = case BS.unsnoc inp of
    121       Nothing -> pure plain
    122       Just (bs, _) -> do
    123         raw <- oracle inp g
    124         let quer = inp <> plain
    125         dict <- mciphertextMap oracle quer g
    126         let key = BS.take (CU.roundUpToMul 16 (BS.length (inp <> plain))) raw
    127         case HMS.lookup key dict of
    128           Nothing  -> pure plain -- XX ?
    129           Just byt -> loop bs (plain <> BS.singleton byt) g
    130 
    131 kvParser :: T.Text -> HMS.HashMap T.Text T.Text
    132 kvParser = L.foldl' alg mempty . T.splitOn "&" where
    133   alg acc val = case T.splitOn "=" val of
    134     (h:t:[]) -> HMS.insert h t acc
    135     _        -> acc
    136 
    137 profileFor :: T.Text -> T.Text
    138 profileFor addr =
    139   let email = T.filter (`notElem` ("&=" :: String)) addr
    140   in  "email=" <> email <> "&" <> "uid=10&role=user"
    141 
    142 -- cut-and-paste ECB
    143 cpeEncrypt :: BS.ByteString -> BS.ByteString
    144 cpeEncrypt user =
    145   let tex = TE.encodeUtf8 $ profileFor (TE.decodeUtf8 user)
    146 
    147       bs  = CU.lpkcs7 tex
    148 
    149   in  AES.encryptEcbAES128 consistentKey bs
    150 
    151 -- cut-and-paste ECB
    152 cpeDecrypt :: BS.ByteString -> BS.ByteString
    153 cpeDecrypt ciphertext = AES.decryptEcbAES128 consistentKey ciphertext
    154 
    155 weirdEncrypter
    156   :: PrimMonad m
    157   => BS.ByteString
    158   -> MWC.Gen (PrimState m)
    159   -> m BS.ByteString
    160 weirdEncrypter plaintext gen = do
    161   let pos = B64.decodeBase64Lenient $ mconcat [
    162           "Um9sbGluJyBpbiBteSA1LjAKV2l0aCBteSByYWctdG9wIGRvd24gc28gbXkg"
    163         , "aGFpciBjYW4gYmxvdwpUaGUgZ2lybGllcyBvbiBzdGFuZGJ5IHdhdmluZyBq"
    164         , "dXN0IHRvIHNheSBoaQpEaWQgeW91IHN0b3A/IE5vLCBJIGp1c3QgZHJvdmUg"
    165         , "YnkK"
    166         ]
    167 
    168   bys <- MWC.uniformR (1, 256) gen
    169   pre <- CU.bytes bys gen
    170 
    171   let par = pre <> plaintext <> pos
    172       bs  = CU.lpkcs7 par
    173 
    174   pure $ AES.encryptEcbAES128 consistentKey bs
    175 
    176 -- The idea is to inject a block whose ciphertext is known, followed by
    177 -- the malicious alignment block(s). One can figure out ciphertext
    178 -- corresponding to any block of repeated bytes by just feeding in more
    179 -- than a block's worth of them -- necessarily some (plaintext) block
    180 -- will then include only that repeated byte.
    181 --
    182 -- E.g.: "AAAAAAAAAAAAAAAA" encrypts to "57eef2e16c3867b9889350eb5732c183",
    183 -- so we can look for that ciphertext in the result in order to locate
    184 -- an "origin," only analyzing ciphertexts in which it appears.
    185 --
    186 -- This function returns the ciphertext following the "identifier" block.
    187 attackProxy
    188   :: PrimMonad m
    189   => (BS.ByteString -> MWC.Gen (PrimState m) -> m BS.ByteString)
    190   -> BS.ByteString
    191   -> MWC.Gen (PrimState m)
    192   -> m BS.ByteString
    193 attackProxy oracle input = loop where
    194   identifier = BS.replicate 16 65
    195   Right knownBlock = B16.decodeBase16 "57eef2e16c3867b9889350eb5732c183"
    196 
    197   loop g = do
    198     ciph <- oracle (identifier <> input) g
    199     let (_, target) = BS.breakSubstring knownBlock ciph
    200     if   target == mempty
    201     then loop g
    202     else pure $ BS.drop 16 target
    203 
    204 -- bitflipping CBC
    205 
    206 bfcEncrypter :: BS.ByteString -> BS.ByteString
    207 bfcEncrypter input = AES.encryptCbcAES128 iv consistentKey padded where
    208   iv = BS.replicate 16 0
    209   filtered  = BS.filter (`notElem` (BS.unpack ";=")) input
    210   plaintext = "comment1=cooking%20MCs;userdata=" <> filtered <>
    211               ";comment2=%20like%20a%20pound%20of%20bacon"
    212   padded = CU.lpkcs7 plaintext
    213 
    214 bfcChecker :: BS.ByteString -> Bool
    215 bfcChecker ciphertext = target /= mempty where
    216   iv          = BS.replicate 16 0
    217   plaintext   = AES.decryptCbcAES128 consistentKey ciphertext
    218   (_, target) = BS.breakSubstring ";admin=true;" plaintext
    219 
    220 -- CBC padding oracle
    221 
    222 -- see https://en.wikipedia.org/wiki/Padding_oracle_attack
    223 poInputs :: [BS.ByteString]
    224 poInputs = [
    225     "MDAwMDAwTm93IHRoYXQgdGhlIHBhcnR5IGlzIGp1bXBpbmc="
    226   , "MDAwMDAxV2l0aCB0aGUgYmFzcyBraWNrZWQgaW4gYW5kIHRoZSBWZWdhJ3MgYXJlIHB1bXBpbic="
    227   , "MDAwMDAyUXVpY2sgdG8gdGhlIHBvaW50LCB0byB0aGUgcG9pbnQsIG5vIGZha2luZw=="
    228   , "MDAwMDAzQ29va2luZyBNQydzIGxpa2UgYSBwb3VuZCBvZiBiYWNvbg=="
    229   , "MDAwMDA0QnVybmluZyAnZW0sIGlmIHlvdSBhaW4ndCBxdWljayBhbmQgbmltYmxl"
    230   , "MDAwMDA1SSBnbyBjcmF6eSB3aGVuIEkgaGVhciBhIGN5bWJhbA=="
    231   , "MDAwMDA2QW5kIGEgaGlnaCBoYXQgd2l0aCBhIHNvdXBlZCB1cCB0ZW1wbw=="
    232   , "MDAwMDA3SSdtIG9uIGEgcm9sbCwgaXQncyB0aW1lIHRvIGdvIHNvbG8="
    233   , "MDAwMDA4b2xsaW4nIGluIG15IGZpdmUgcG9pbnQgb2g="
    234   , "MDAwMDA5aXRoIG15IHJhZy10b3AgZG93biBzbyBteSBoYWlyIGNhbiBibG93"
    235   ]
    236 
    237 paddingOracle
    238   :: PrimMonad m
    239   => MWC.Gen (PrimState m)
    240   -> m BS.ByteString
    241 paddingOracle gen = do
    242   idx <- MWC.uniformR (0, length poInputs - 1) gen
    243   let Right input = B64.decodeBase64 (poInputs !! idx)
    244       padded      = CU.lpkcs7 input
    245   iv <- CU.bytes 16 gen
    246   pure $ AES.encryptCbcAES128 iv consistentKey padded
    247 
    248 poValidate :: BS.ByteString -> Bool
    249 poValidate bs = case CU.unpkcs7 (AES.decryptCbcAES128 consistentKey bs) of
    250   Nothing -> False
    251   Just _  -> True
    252 
    253 paddingOracleAttack :: BS.ByteString -> BS.ByteString
    254 paddingOracleAttack cip = loop mempty (reverse (CU.chunks 16 cip)) where
    255   loop !acc rcs = case rcs of
    256     []     -> acc
    257     (h:[]) -> acc
    258     (h:r@(i:t)) -> loop (poAttackBlock i h <> acc) r
    259 
    260 poAttackBlock :: BS.ByteString -> BS.ByteString -> BS.ByteString
    261 poAttackBlock tol tar = byte tol tar mempty mempty where
    262   byte c0' c1 p1 i1 = case BS.unsnoc c0' of
    263     Nothing     -> p1
    264     Just (t, h) ->
    265       let ncb = next t h i1 c1
    266           il  = BS.length i1
    267           pb  = fromIntegral il + 1
    268           nib = ncb `B.xor` pb
    269           npb = BS.index tol (15 - fromIntegral il) `B.xor` nib
    270       in  byte t c1 (BS.cons npb p1) (BS.cons nib i1)
    271 
    272   next bs b i1 c1 =
    273     let l   = fromIntegral (BS.length i1) + 1
    274         c   = BS.map (B.xor l) i1
    275         c0' = BS.snoc bs b <> c
    276 
    277         roll byt =
    278           let c0' = BS.snoc bs byt <> c
    279           in  if   poValidate (c0' <> c1) && cert bs (BS.cons byt c <> c1)
    280               then byt
    281               else roll (byt + 1)
    282 
    283     in  roll b
    284 
    285   cert c0' etc = case BS.unsnoc c0' of
    286     Nothing -> True
    287     Just (bs, b)
    288       | poValidate (BS.snoc bs (b + 1) <> etc) -> True
    289       | otherwise -> False
    290 
    291 -- CTR reused-nonce
    292 
    293 rninputs :: [BS.ByteString]
    294 rninputs = [
    295     "SSBoYXZlIG1ldCB0aGVtIGF0IGNsb3NlIG9mIGRheQ=="
    296   , "Q29taW5nIHdpdGggdml2aWQgZmFjZXM="
    297   , "RnJvbSBjb3VudGVyIG9yIGRlc2sgYW1vbmcgZ3JleQ=="
    298   , "RWlnaHRlZW50aC1jZW50dXJ5IGhvdXNlcy4="
    299   , "SSBoYXZlIHBhc3NlZCB3aXRoIGEgbm9kIG9mIHRoZSBoZWFk"
    300   , "T3IgcG9saXRlIG1lYW5pbmdsZXNzIHdvcmRzLA=="
    301   , "T3IgaGF2ZSBsaW5nZXJlZCBhd2hpbGUgYW5kIHNhaWQ="
    302   , "UG9saXRlIG1lYW5pbmdsZXNzIHdvcmRzLA=="
    303   , "QW5kIHRob3VnaHQgYmVmb3JlIEkgaGFkIGRvbmU="
    304   , "T2YgYSBtb2NraW5nIHRhbGUgb3IgYSBnaWJl"
    305   , "VG8gcGxlYXNlIGEgY29tcGFuaW9u"
    306   , "QXJvdW5kIHRoZSBmaXJlIGF0IHRoZSBjbHViLA=="
    307   , "QmVpbmcgY2VydGFpbiB0aGF0IHRoZXkgYW5kIEk="
    308   , "QnV0IGxpdmVkIHdoZXJlIG1vdGxleSBpcyB3b3JuOg=="
    309   , "QWxsIGNoYW5nZWQsIGNoYW5nZWQgdXR0ZXJseTo="
    310   , "QSB0ZXJyaWJsZSBiZWF1dHkgaXMgYm9ybi4="
    311   , "VGhhdCB3b21hbidzIGRheXMgd2VyZSBzcGVudA=="
    312   , "SW4gaWdub3JhbnQgZ29vZCB3aWxsLA=="
    313   , "SGVyIG5pZ2h0cyBpbiBhcmd1bWVudA=="
    314   , "VW50aWwgaGVyIHZvaWNlIGdyZXcgc2hyaWxsLg=="
    315   , "V2hhdCB2b2ljZSBtb3JlIHN3ZWV0IHRoYW4gaGVycw=="
    316   , "V2hlbiB5b3VuZyBhbmQgYmVhdXRpZnVsLA=="
    317   , "U2hlIHJvZGUgdG8gaGFycmllcnM/"
    318   , "VGhpcyBtYW4gaGFkIGtlcHQgYSBzY2hvb2w="
    319   , "QW5kIHJvZGUgb3VyIHdpbmdlZCBob3JzZS4="
    320   , "VGhpcyBvdGhlciBoaXMgaGVscGVyIGFuZCBmcmllbmQ="
    321   , "V2FzIGNvbWluZyBpbnRvIGhpcyBmb3JjZTs="
    322   , "SGUgbWlnaHQgaGF2ZSB3b24gZmFtZSBpbiB0aGUgZW5kLA=="
    323   , "U28gc2Vuc2l0aXZlIGhpcyBuYXR1cmUgc2VlbWVkLA=="
    324   , "U28gZGFyaW5nIGFuZCBzd2VldCBoaXMgdGhvdWdodC4="
    325   , "VGhpcyBvdGhlciBtYW4gSSBoYWQgZHJlYW1lZA=="
    326   , "QSBkcnVua2VuLCB2YWluLWdsb3Jpb3VzIGxvdXQu"
    327   , "SGUgaGFkIGRvbmUgbW9zdCBiaXR0ZXIgd3Jvbmc="
    328   , "VG8gc29tZSB3aG8gYXJlIG5lYXIgbXkgaGVhcnQs"
    329   , "WWV0IEkgbnVtYmVyIGhpbSBpbiB0aGUgc29uZzs="
    330   , "SGUsIHRvbywgaGFzIHJlc2lnbmVkIGhpcyBwYXJ0"
    331   , "SW4gdGhlIGNhc3VhbCBjb21lZHk7"
    332   , "SGUsIHRvbywgaGFzIGJlZW4gY2hhbmdlZCBpbiBoaXMgdHVybiw="
    333   , "VHJhbnNmb3JtZWQgdXR0ZXJseTo="
    334   , "QSB0ZXJyaWJsZSBiZWF1dHkgaXMgYm9ybi4="
    335   ]
    336 
    337 rncrypted :: [BS.ByteString]
    338 rncrypted = fmap (enc . B64.decodeBase64Lenient) rninputs where
    339   enc = AES.encryptCtrAES128 0 "YELLOW SUBMARINE"
    340 
    341 rnscrypted :: [BS.ByteString]
    342 rnscrypted = fmap (BS.take 16) rncrypted
    343 
    344 rnrotated :: [BS.ByteString]
    345 rnrotated = CU.rotate 16 (BS.concat rnscrypted)
    346 
    347 -- FIXME replace Cryptopals.Util.best with this?
    348 rnBest :: BS.ByteString -> (Word8, Double, BS.ByteString)
    349 rnBest s = loop (0, 1 / 0, s) 0 where
    350   loop acc@(_, asc, _) b
    351     | b == 255 = acc
    352     | otherwise =
    353         let xo = CU.singleByteXor b s
    354         in  case CU.scoreAlt xo of
    355               Nothing  -> loop acc (succ b)
    356               Just sc
    357                 | sc < asc  -> loop (b, sc, xo) (succ b)
    358                 | otherwise -> loop acc (succ b)
    359 
    360 -- CBC key recovery w/IV=key
    361 
    362 -- Usually we include the IV with the ciphertext, but that won't fly here
    363 -- as it would very obviously expose the key. Instead let's omit the IV
    364 -- in the ciphertext:
    365 
    366 ivlEncryptCbcAES128
    367   :: BS.ByteString -> BS.ByteString -> BS.ByteString
    368 ivlEncryptCbcAES128 key plaintext = loop key mempty (BS.splitAt 16 plaintext)
    369   where
    370     loop las !acc (b, bs) =
    371       let xed  = CU.fixedXor las b
    372           enc  = AES.encryptEcbAES128 key xed
    373           nacc = acc <> enc
    374       in  if   BS.null bs
    375           then nacc
    376           else loop enc nacc (BS.splitAt 16 bs)
    377 
    378 ivlDecryptCbcAES128
    379   :: BS.ByteString -> BS.ByteString -> BS.ByteString
    380 ivlDecryptCbcAES128 key ciphertext =
    381     let (iv, cip) = BS.splitAt 16 (key <> ciphertext)
    382     in  loop iv mempty (BS.splitAt 16 cip)
    383   where
    384     loop !las !acc (b, bs) =
    385       let dec  = AES.decryptEcbAES128 key b
    386           nacc = acc <> CU.fixedXor dec las
    387           niv  = b
    388       in  if   BS.null bs
    389           then nacc
    390           else loop b nacc (BS.splitAt 16 bs)
    391 
    392 ivlVerifier :: BS.ByteString -> Either BS.ByteString Bool
    393 ivlVerifier cip = loop pay where
    394   pay = ivlDecryptCbcAES128 consistentKey cip
    395   loop p = case BS.uncons p of
    396     Nothing -> pure True
    397     Just (b, bs)
    398       | b > 127   -> Left pay
    399       | otherwise -> loop bs