cryptopals

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

Attacks.hs (6513B)

      1 {-# LANGUAGE ApplicativeDo #-}
      2 
      3 module Cryptopals.MAC.Attacks where
      4 
      5 import qualified Control.Monad.Trans.Reader as R
      6 import qualified Data.Binary.Get as BG
      7 import qualified Data.Binary.Put as BP
      8 import qualified Data.Bits as B
      9 import qualified Data.ByteString as BS
     10 import qualified Data.ByteString.Base16 as B16
     11 import qualified Data.ByteString.Char8 as B8
     12 import qualified Data.ByteString.Lazy as BSL
     13 import qualified Data.ByteString.Lazy.Char8 as BL8
     14 import qualified Data.IntMap.Strict as IMS
     15 import qualified Data.List as L
     16 import qualified Data.Text as T
     17 import qualified Data.Time as TI
     18 import qualified Cryptopals.MAC as CM
     19 import qualified Cryptopals.Digest.Pure.MD4 as M
     20 import qualified Cryptopals.Digest.Pure.SHA as S
     21 import GHC.Word (Word8, Word32, Word64)
     22 import qualified Network.HTTP as H
     23 import Numeric (showHex)
     24 import qualified System.Random.MWC as MWC
     25 
     26 data SHA1Registers = SHA1Registers !Word32 !Word32 !Word32 !Word32 !Word32
     27   deriving (Eq, Show)
     28 
     29 data MD4Registers = MD4Registers !Word32 !Word32 !Word32 !Word32
     30   deriving (Eq, Show)
     31 
     32 sha1 :: SHA1Registers -> Word64 -> BSL.ByteString -> BSL.ByteString
     33 sha1 (SHA1Registers a b c d e) n s =
     34   S.bytestringDigest $ S.sha1' a b c d e n s
     35 
     36 md4 :: MD4Registers -> Word64 -> BSL.ByteString -> BSL.ByteString
     37 md4 (MD4Registers a b c d) n s = M.md4' a b c d n s
     38 
     39 raw :: BSL.ByteString
     40 raw = mconcat [
     41     "comment1=cooking%20MCs;userdata=foo;"
     42   , "comment2=%20like%20a%20pound%20of%20bacon"
     43   ]
     44 
     45 mal :: BSL.ByteString
     46 mal = ";admin=true"
     47 
     48 key :: IO BSL.ByteString
     49 key = do
     50   gen <- MWC.createSystemRandom
     51   idx <- MWC.uniformR (0, 235885) gen
     52   dict <- BL8.readFile "/usr/share/dict/words"
     53   let ls = BL8.lines dict
     54   pure $ ls !! idx
     55 
     56 -- pad a message using the specified message length
     57 pad :: Word64 -> BSL.ByteString -> BSL.ByteString
     58 pad n bs = bs <> padding n where
     59   padding n = BP.runPut $ do
     60     BP.putWord8 128
     61     loop (pred (pbytes n))
     62 
     63   loop l
     64     | l == 0    = BP.putWord64be (n * 8)
     65     | otherwise = do
     66         BP.putWord8 0
     67         loop (pred l)
     68 
     69   pbytes ((\k -> 64 - k `mod` 64) -> l)
     70     | l == 0    = l + 56
     71     | otherwise = l - 8
     72 
     73 -- sha1-keyed MAC via length extension
     74 
     75 injectSha1 :: BSL.ByteString -> SHA1Registers
     76 injectSha1 = BG.runGet $ do
     77   a <- BG.getWord32be
     78   b <- BG.getWord32be
     79   c <- BG.getWord32be
     80   d <- BG.getWord32be
     81   e <- BG.getWord32be
     82   pure $ SHA1Registers a b c d e
     83 
     84 extractSha1 :: SHA1Registers -> BSL.ByteString
     85 extractSha1 (SHA1Registers a b c d e) = BP.runPut $ do
     86   BP.putWord32be a
     87   BP.putWord32be b
     88   BP.putWord32be c
     89   BP.putWord32be d
     90   BP.putWord32be e
     91 
     92 leasha1
     93   :: BSL.ByteString
     94   -> BSL.ByteString
     95   -> BSL.ByteString
     96   -> R.Reader BSL.ByteString (BSL.ByteString, BSL.ByteString)
     97 leasha1 input mac addl = loop 0 where
     98   loop j = do
     99     let len = fromIntegral $ BSL.length input
    100         evil = pad (len + j) input <> addl
    101         rs   = injectSha1 mac
    102         p    = fromIntegral (BSL.length evil) + j
    103         forged = sha1 rs p addl
    104     validates <- oracleValidates evil forged
    105     if   validates
    106     then pure (evil, forged)
    107     else loop (succ j)
    108 
    109   oracleValidates msg mac = do
    110     k <- R.ask
    111     pure $ CM.verifysha1mac k mac msg
    112 
    113 -- md4-keyed MAC via length extension
    114 
    115 -- little-endian 'pad'
    116 padle :: Word64 -> BSL.ByteString -> BSL.ByteString
    117 padle n bs = bs <> padding n where
    118   padding n = BP.runPut $ do
    119     BP.putWord8 128
    120     loop (pred (pbytes n))
    121 
    122   loop l
    123     | l == 0    = BP.putWord64le (n * 8)
    124     | otherwise = do
    125         BP.putWord8 0
    126         loop (pred l)
    127 
    128   pbytes ((\k -> 64 - k `mod` 64) -> l)
    129     | l == 0    = l + 56
    130     | otherwise = l - 8
    131 
    132 injectMd4 :: BSL.ByteString -> MD4Registers
    133 injectMd4 = BG.runGet $ do
    134   a <- BG.getWord32le
    135   b <- BG.getWord32le
    136   c <- BG.getWord32le
    137   d <- BG.getWord32le
    138   pure $ MD4Registers a b c d
    139 
    140 extractMd4 :: MD4Registers -> BSL.ByteString
    141 extractMd4 (MD4Registers a b c d) = BP.runPut $ do
    142   BP.putWord32le a
    143   BP.putWord32le b
    144   BP.putWord32le c
    145   BP.putWord32le d
    146 
    147 leamd4
    148   :: BSL.ByteString
    149   -> BSL.ByteString
    150   -> BSL.ByteString
    151   -> R.Reader BSL.ByteString (BSL.ByteString, BSL.ByteString)
    152 leamd4 input mac addl = loop 0 where
    153   loop j = do
    154     let len = fromIntegral $ BSL.length input
    155         evil = padle (len + j) input <> addl
    156         rs   = injectMd4 mac
    157         p    = fromIntegral (BSL.length evil) + j
    158         forged = md4 rs p addl
    159     validates <- oracleValidates evil forged
    160     if   validates
    161     then pure (evil, forged)
    162     else loop (succ j)
    163 
    164   oracleValidates msg mac = do
    165     k <- R.ask
    166     pure $ CM.verifymd4mac k mac msg
    167 
    168 -- timing attack on HMAC-SHA1
    169 
    170 hmacValidates :: BS.ByteString -> BS.ByteString -> IO Bool
    171 hmacValidates fil sig = do
    172   let f = B8.unpack fil
    173       s = T.unpack . B16.encodeBase16 $ sig
    174   res <- H.simpleHTTP . H.getRequest $
    175     "http://localhost:3000/hmac?safe=false&delay=5&file=" <> f <> "&" <>
    176     "signature=" <> s
    177   cod <- H.getResponseCode res
    178   pure $ cod == (2, 0, 0)
    179 
    180 collect
    181   :: BS.ByteString -- message
    182   -> Int           -- number of samples
    183   -> BS.ByteString -- got so far
    184   -> BS.ByteString -- remaining
    185   -> IO (IMS.IntMap [TI.NominalDiffTime])
    186 collect !fil sam pre etc = loop mempty 0 0 where
    187   loop !acc cyc b
    188     | cyc == sam = pure acc
    189     | otherwise = do
    190         let !can = pre <> BS.cons b etc
    191         org <- TI.getCurrentTime
    192         cod <- hmacValidates fil can
    193         end <- TI.getCurrentTime
    194         let dif = TI.diffUTCTime end org
    195             nac = IMS.alter (add dif) (fromIntegral b) acc
    196             sik | b == 255  = succ cyc
    197                 | otherwise = cyc
    198         loop nac sik (b + 1)
    199 
    200   add d ma = case ma of
    201     Nothing -> Just (d : [])
    202     Just a  -> Just (d : a)
    203 
    204 crackByte
    205   :: BS.ByteString
    206   -> BS.ByteString
    207   -> BS.ByteString
    208   -> IO Word8
    209 crackByte fil pre etc = do
    210   samples <- collect fil 7 pre etc
    211   let ver = fmap med samples
    212       chu = IMS.foldlWithKey'
    213               (\acc k v -> if v > snd acc then (k, v) else acc)
    214               (256, 0)
    215               ver
    216   pure $ fromIntegral (fst chu)
    217 
    218 crackHmac :: BS.ByteString -> IO BS.ByteString
    219 crackHmac fil = loop mempty (BS.replicate 20 0) where
    220   loop !acc sig = case BS.uncons sig of
    221     Nothing     -> pure acc
    222     Just (_, t) -> do
    223       byt <- crackByte fil acc t
    224       let nex = BS.snoc acc byt
    225       putStrLn $ "current guess: " <> show (B16.encodeBase16 nex)
    226       loop nex t
    227 
    228 avg :: (Foldable f, Fractional a) => f a -> a
    229 avg l = sum l / fromIntegral (length l)
    230 
    231 -- -- hacky median for container with known length 7
    232 med :: Ord a => [a] -> a
    233 med l = L.sort l !! 3