cryptopals

Matasano's cryptopals challenges (cryptopals.com).
Log | Files | Refs | README | LICENSE

commit d007b01a5b96446cd98f35ebc0403892e96ad29f
parent 7e7cff6b614334e709ae5a08c1925d15bd2df34c
Author: Jared Tobin <jared@jtobin.io>
Date:   Mon, 14 Aug 2023 11:13:40 -0230

Further DH refactoring.

Diffstat:
Mcryptopals.cabal | 2++
Mlib/Cryptopals/DH.hs | 293+------------------------------------------------------------------------------
Alib/Cryptopals/DH/Core.hs | 65+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Alib/Cryptopals/DH/Session.hs | 237+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Mlib/Pipes/Network.hs | 34++++++++++++++++++++++++++++++++++
5 files changed, 341 insertions(+), 290 deletions(-)

diff --git a/cryptopals.cabal b/cryptopals.cabal @@ -24,6 +24,8 @@ library , Cryptopals.Block.Attacks , Cryptopals.Block.Tools , Cryptopals.DH + , Cryptopals.DH.Core + , Cryptopals.DH.Session , Cryptopals.Digest.Pure.MD4 , Cryptopals.Digest.Pure.SHA , Cryptopals.MAC diff --git a/lib/Cryptopals/DH.hs b/lib/Cryptopals/DH.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module Cryptopals.DH ( @@ -8,254 +6,20 @@ module Cryptopals.DH ( , modexp ) where -import Control.Concurrent (threadDelay) import Control.Monad.Primitive import Control.Monad.Trans.State (StateT) import qualified Control.Monad.Trans.State as S -import qualified Cryptopals.AES as AES -import qualified Cryptopals.Digest.Pure.SHA as CS -import qualified Cryptopals.Util as CU -import Data.Binary as DB -import qualified Data.Binary.Get as BG -import qualified Data.Binary.Put as BP -import Data.Bits ((.|.)) -import qualified Data.Bits as B +import Cryptopals.DH.Core +import Cryptopals.DH.Session import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Lazy as BL -import qualified Data.Char as C -import qualified Data.List as L import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.IO as TIO -import GHC.Generics (Generic) -import GHC.Word (Word16) -import qualified Network.Simple.TCP as N -import qualified Network.Socket.ByteString as NB +import GHC.Word (Word32) import Numeric.Natural import Pipes import qualified Pipes.Binary as PB import qualified Pipes.Network as PN -import qualified Pipes.Prelude as P -import qualified Pipes.Parse as PP -import qualified System.Exit as SE import qualified System.Random.MWC as MWC -data Group = Group Natural Natural - deriving (Eq, Show, Generic) - -instance DB.Binary Group - -data Command = - SendParams Group Natural - | SendPublic Natural - | SendMessage BS.ByteString - | SendTerminal BS.ByteString - deriving (Eq, Show, Generic) - -instance DB.Binary Command - -data Keys = Keys { - pub :: Natural - , sec :: Natural - } - --- session state -data Sesh = Sesh { - dhGroup :: Maybe Group - , dhKeys :: Maybe Keys - , dhKey :: Maybe BS.ByteString - , dhGen :: IO (MWC.Gen RealWorld) - } - -p :: Natural -p = 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7edee386bfb5a899fa5ae9f24117c4b1fe649286651ece45b3dc2007cb8a163bf0598da48361c55d39a69163fa8fd24cf5f83655d23dca3ad961c62f356208552bb9ed529077096966d670c354e4abc9804f1746c08ca237327ffffffffffffffff - -g :: Natural -g = 2 - --- XX i should really put this somewhere instead of copying it every time --- modified from https://gist.github.com/trevordixon/6788535 -modexp :: Natural -> Natural -> Natural -> Natural -modexp b e m - | e == 0 = 1 - | otherwise = - let t = if B.testBit e 0 then b `mod` m else 1 - in t * modexp ((b * b) `mod` m) (B.shiftR e 1) m `mod` m - --- generate public, private keypair -genpair - :: PrimMonad m - => Group - -> MWC.Gen (PrimState m) - -> m Keys -genpair (Group p g) gen = do - sk <- fmap (`mod` p) (MWC.uniformRM (1, p - 1) gen) - let pk = modexp g sk p - pure $ Keys pk sk - --- derive shared key from secret and other public -derivekey :: Group -> Keys -> Natural -> BS.ByteString -derivekey (Group p _) Keys {..} pk = - let nat = modexp pk sec p - in BS.take 16 . BL.toStrict . CS.bytestringDigest $ CS.sha1 (DB.encode nat) - --- session log -slog :: T.Text -> T.Text -> IO () -slog host msg = TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg - --- generic session evaluator -geval - :: MonadIO m - => (T.Text -> Command -> m a) - -> T.Text - -> Maybe Command - -> m a -geval cont host = \case - Nothing -> liftIO $ do - slog host "ending session" - SE.exitSuccess - Just cmd -> do - liftIO $ threadDelay 1000000 - cont host cmd - -seval :: T.Text -> Maybe Command -> StateT Sesh IO (Maybe Command) -seval = geval dheval - -meval :: T.Text -> Maybe Command -> StateT Sesh IO (Maybe Command) -meval = geval mitmeval - --- diffie-hellman protocol eval -dheval - :: T.Text - -> Command - -> StateT Sesh IO (Maybe Command) -dheval host = \case - SendParams grp pk -> do - sesh@Sesh {..} <- S.get - liftIO $ slog host "received group parameters and public key" - gen <- liftIO dhGen - per@Keys {..} <- liftIO $ genpair grp gen - let key = derivekey grp per pk - nex = sesh { - dhGroup = Just grp - , dhKeys = Just per - , dhKey = Just key - } - S.put nex - liftIO $ slog host "sending public key" - pure $ Just (SendPublic pub) - - SendPublic pk -> do - sesh@Sesh {..} <- S.get - liftIO $ slog host "received public key" - let key = do - per@Keys {..} <- dhKeys - grp <- dhGroup - pure $ derivekey grp per pk - case key of - Nothing -> do - liftIO $ slog host "key derivation failed" - pure Nothing - Just k -> do - gen <- liftIO dhGen - iv <- liftIO $ CU.bytes 16 gen - let msg = CU.lpkcs7 "attack at 10pm" - cip = AES.encryptCbcAES128 iv k msg - cod = B64.encodeBase64 cip - liftIO . slog host $ "sending ciphertext " <> cod - let rep = Just (SendMessage cip) - nex = sesh { dhKey = key } - S.put nex - pure rep - - SendMessage cip -> do - sesh@Sesh {..} <- S.get - let cod = B64.encodeBase64 cip - liftIO $ slog host $ "received ciphertext " <> cod - case dhKey of - Nothing -> do - liftIO $ slog host "shared key not established" - pure Nothing - Just k -> do - let Just msg = CU.unpkcs7 (AES.decryptCbcAES128 k cip) - cod = TE.decodeLatin1 msg - liftIO $ slog host $ "decrypted ciphertext: \"" <> cod <> "\"" - - let hourOfDestiny = case B8.findIndex C.isDigit msg of - Nothing -> error "did i fat-finger a digit?" - Just j -> BS.drop j msg - - gen <- liftIO dhGen - iv <- liftIO $ CU.bytes 16 gen - let nmsg = CU.lpkcs7 $ "confirmed, attacking at " <> hourOfDestiny - ncip = AES.encryptCbcAES128 iv k nmsg - ncod = B64.encodeBase64 ncip - liftIO $ slog host $ "replying with ciphertext " <> ncod - pure $ Just (SendTerminal ncip) - - SendTerminal cip -> do - sesh@Sesh {..} <- S.get - let cod = B64.encodeBase64 cip - liftIO $ slog host $ "received ciphertext " <> cod - case dhKey of - Nothing -> do - liftIO $ slog host "shared key not established" - pure Nothing - Just k -> do - let Just msg = CU.unpkcs7 (AES.decryptCbcAES128 k cip) - cod = TE.decodeLatin1 msg - liftIO $ slog host $ "decrypted ciphertext: \"" <> cod <> "\"" - pure Nothing - --- man-in-the-middle protocol eval -mitmeval - :: T.Text - -> Command - -> StateT Sesh IO (Maybe Command) -mitmeval host = \case - SendParams grp pk -> do - sesh@Sesh {..} <- S.get - liftIO $ slog host "reCEiVed GRoUp pArAmeTErs And pUBliC kEy" - let key = derivekey grp (Keys p 1) p - nex = sesh { dhKey = Just key } - S.put nex - liftIO $ slog host "sEnDinG BOguS paRaMeTeRs" - pure $ Just (SendParams grp p) - - SendPublic pk -> do - liftIO $ slog host "REceIvED pUBlic keY" - liftIO $ slog host "seNDINg boGus kEy" - pure $ Just (SendPublic p) - - SendMessage cip -> do - sesh@Sesh {..} <- S.get - let cod = B64.encodeBase64 cip - liftIO $ slog host $ "rECeIveD CiPHeRTexT " <> cod - case dhKey of - Nothing -> error "mallory knows key" - Just k -> do - let Just msg = CU.unpkcs7 (AES.decryptCbcAES128 k cip) - cod = TE.decodeLatin1 msg - liftIO $ slog host $ "DEcRyptEd cIPheRTeXt: \"" <> cod <> "\"" - liftIO $ slog host $ "reLayINg cIpheRtExt" - pure $ Just (SendMessage cip) - - SendTerminal cip -> do - sesh@Sesh {..} <- S.get - let cod = B64.encodeBase64 cip - liftIO $ slog host $ "reCeiVeD CipHeRtExt " <> cod - case dhKey of - Nothing -> error "mallory knows key" - Just k -> do - let Just msg = CU.unpkcs7 (AES.decryptCbcAES128 k cip) - cod = TE.decodeLatin1 msg - liftIO $ slog host $ "DeCrYpteD cIphErteXt: \"" <> cod <> "\"" - liftIO $ slog host $ "ReLaYINg CiPHeRTexT" - pure $ Just (SendTerminal cip) - -- await key exchange bob :: MonadIO m => PN.ServiceName -> m a bob port = PN.serve "localhost" port $ \(sock, _) -> do @@ -304,54 +68,3 @@ mallory port bport = slog "mallory" $ "eStabLisHed coNNecTion" void $ S.runStateT (runEffect (dance "mallory" asock bsock)) sesh --- basic TCP coordination -session host sock = - deco - >-> P.mapM eval - >-> for cat PB.encode - >-> send - where - recv = PN.fromSocket sock 4096 - deco = PP.parsed PB.decode recv - send = PN.toSocket sock - eval = seval host - --- MITM TCP coordination -dance host asock bsock = - PP.parsed PB.decode recv - >-> P.mapM (meval host) - >-> for cat PB.encode - >-> foxtrot bsock asock - where - recv = rhumba asock bsock 4096 - --- receive on alternate sockets -rhumba - :: MonadIO m - => N.Socket - -> N.Socket - -> Word32 - -> Producer' BS.ByteString m () -rhumba a b n = loop True where - loop lip = do - let s = if lip then a else b - b <- liftIO (NB.recv s (fromIntegral n)) - if BS.null b - then pure () - else do - yield b - loop (not lip) - --- send on alternate sockets -foxtrot - :: MonadIO m - => N.Socket - -> N.Socket - -> Consumer BS.ByteString m b -foxtrot asock bsock = loop True where - loop lip = do - b <- await - let s = if lip then asock else bsock - liftIO $ PN.send s b - loop (not lip) - diff --git a/lib/Cryptopals/DH/Core.hs b/lib/Cryptopals/DH/Core.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Cryptopals.DH.Core ( + Group(..) + , p + , g + + , Keys(..) + + , modexp + , genpair + , derivekey + ) where + +import Control.Monad.Primitive +import qualified Cryptopals.Digest.Pure.SHA as CS +import Data.Binary as DB +import qualified Data.Bits as B +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import GHC.Generics (Generic) +import Numeric.Natural +import qualified System.Random.MWC as MWC + +data Group = Group Natural Natural + deriving (Eq, Show, Generic) + +instance DB.Binary Group + +p :: Natural +p = 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7edee386bfb5a899fa5ae9f24117c4b1fe649286651ece45b3dc2007cb8a163bf0598da48361c55d39a69163fa8fd24cf5f83655d23dca3ad961c62f356208552bb9ed529077096966d670c354e4abc9804f1746c08ca237327ffffffffffffffff + +g :: Natural +g = 2 + +data Keys = Keys { + pub :: Natural + , sec :: Natural + } + +-- modified from https://gist.github.com/trevordixon/6788535 +modexp :: Natural -> Natural -> Natural -> Natural +modexp b e m + | e == 0 = 1 + | otherwise = + let t = if B.testBit e 0 then b `mod` m else 1 + in t * modexp ((b * b) `mod` m) (B.shiftR e 1) m `mod` m + +-- generate public, private keypair +genpair + :: PrimMonad m + => Group + -> MWC.Gen (PrimState m) + -> m Keys +genpair (Group p g) gen = do + sk <- fmap (`mod` p) (MWC.uniformRM (1, p - 1) gen) + let pk = modexp g sk p + pure $ Keys pk sk + +-- derive shared key from secret and other public +derivekey :: Group -> Keys -> Natural -> BS.ByteString +derivekey (Group p _) Keys {..} pk = + let nat = modexp pk sec p + in BS.take 16 . BL.toStrict . CS.bytestringDigest $ CS.sha1 (DB.encode nat) + diff --git a/lib/Cryptopals/DH/Session.hs b/lib/Cryptopals/DH/Session.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} + +module Cryptopals.DH.Session ( + Command(..) + , Sesh(..) + + , slog + , beval + , meval + + , session + , dance + ) where + +import Control.Concurrent (threadDelay) +import Control.Monad.Primitive +import Control.Monad.IO.Class +import Control.Monad.Trans.State (StateT) +import qualified Control.Monad.Trans.State as S +import qualified Cryptopals.AES as AES +import Cryptopals.DH.Core +import qualified Cryptopals.Util as CU +import qualified Data.Binary as DB +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Char as C +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO +import GHC.Generics (Generic) +import GHC.Word (Word32) +import qualified Network.Socket.ByteString as NB +import Numeric.Natural +import Pipes +import qualified Pipes.Binary as PB +import qualified Pipes.Network as PN +import qualified Pipes.Parse as PP +import qualified Pipes.Prelude as P +import qualified System.Exit as SE +import qualified System.Random.MWC as MWC + +data Command = + SendParams Group Natural + | SendPublic Natural + | SendMessage BS.ByteString + | SendTerminal BS.ByteString + deriving (Eq, Show, Generic) + +instance DB.Binary Command + +-- session state +data Sesh = Sesh { + dhGroup :: Maybe Group + , dhKeys :: Maybe Keys + , dhKey :: Maybe BS.ByteString + , dhGen :: IO (MWC.Gen RealWorld) + } + +-- session log +slog :: T.Text -> T.Text -> IO () +slog host msg = TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg + +-- generic session evaluator +geval + :: MonadIO m + => (T.Text -> Command -> m a) + -> T.Text + -> Maybe Command + -> m a +geval cont host = \case + Nothing -> liftIO $ do + slog host "ending session" + SE.exitSuccess -- XX should really just close the socket + Just cmd -> do + liftIO $ threadDelay 1000000 + cont host cmd + +-- basic dh evaluation +beval :: T.Text -> Maybe Command -> StateT Sesh IO (Maybe Command) +beval = geval dheval + +-- mitm dh evaluation +meval :: T.Text -> Maybe Command -> StateT Sesh IO (Maybe Command) +meval = geval mitmeval + +-- diffie-hellman protocol eval +dheval + :: T.Text + -> Command + -> StateT Sesh IO (Maybe Command) +dheval host = \case + SendParams grp pk -> do + sesh@Sesh {..} <- S.get + liftIO $ slog host "received group parameters and public key" + gen <- liftIO dhGen + per@Keys {..} <- liftIO $ genpair grp gen + let key = derivekey grp per pk + nex = sesh { + dhGroup = Just grp + , dhKeys = Just per + , dhKey = Just key + } + S.put nex + liftIO $ slog host "sending public key" + pure $ Just (SendPublic pub) + + SendPublic pk -> do + sesh@Sesh {..} <- S.get + liftIO $ slog host "received public key" + let key = do + per@Keys {..} <- dhKeys + grp <- dhGroup + pure $ derivekey grp per pk + case key of + Nothing -> do + liftIO $ slog host "key derivation failed" + pure Nothing + Just k -> do + gen <- liftIO dhGen + iv <- liftIO $ CU.bytes 16 gen + let msg = CU.lpkcs7 "attack at 10pm" + cip = AES.encryptCbcAES128 iv k msg + cod = B64.encodeBase64 cip + liftIO . slog host $ "sending ciphertext " <> cod + let rep = Just (SendMessage cip) + nex = sesh { dhKey = key } + S.put nex + pure rep + + SendMessage cip -> do + sesh@Sesh {..} <- S.get + let cod = B64.encodeBase64 cip + liftIO $ slog host $ "received ciphertext " <> cod + case dhKey of + Nothing -> do + liftIO $ slog host "shared key not established" + pure Nothing + Just k -> do + let Just msg = CU.unpkcs7 (AES.decryptCbcAES128 k cip) + cod = TE.decodeLatin1 msg + liftIO $ slog host $ "decrypted ciphertext: \"" <> cod <> "\"" + + let hourOfDestiny = case B8.findIndex C.isDigit msg of + Nothing -> error "did i fat-finger a digit?" + Just j -> BS.drop j msg + + gen <- liftIO dhGen + iv <- liftIO $ CU.bytes 16 gen + let nmsg = CU.lpkcs7 $ "confirmed, attacking at " <> hourOfDestiny + ncip = AES.encryptCbcAES128 iv k nmsg + ncod = B64.encodeBase64 ncip + liftIO $ slog host $ "replying with ciphertext " <> ncod + pure $ Just (SendTerminal ncip) + + SendTerminal cip -> do + sesh@Sesh {..} <- S.get + let cod = B64.encodeBase64 cip + liftIO $ slog host $ "received ciphertext " <> cod + case dhKey of + Nothing -> do + liftIO $ slog host "shared key not established" + pure Nothing + Just k -> do + let Just msg = CU.unpkcs7 (AES.decryptCbcAES128 k cip) + cod = TE.decodeLatin1 msg + liftIO $ slog host $ "decrypted ciphertext: \"" <> cod <> "\"" + pure Nothing + +-- man-in-the-middle protocol eval +mitmeval + :: T.Text + -> Command + -> StateT Sesh IO (Maybe Command) +mitmeval host = \case + SendParams grp pk -> do + sesh@Sesh {..} <- S.get + liftIO $ slog host "reCEiVed GRoUp pArAmeTErs And pUBliC kEy" + let key = derivekey grp (Keys p 1) p + nex = sesh { dhKey = Just key } + S.put nex + liftIO $ slog host "sEnDinG BOguS paRaMeTeRs" + pure $ Just (SendParams grp p) + + SendPublic pk -> do + liftIO $ slog host "REceIvED pUBlic keY" + liftIO $ slog host "seNDINg boGus kEy" + pure $ Just (SendPublic p) + + SendMessage cip -> do + sesh@Sesh {..} <- S.get + let cod = B64.encodeBase64 cip + liftIO $ slog host $ "rECeIveD CiPHeRTexT " <> cod + case dhKey of + Nothing -> error "mallory knows key" + Just k -> do + let Just msg = CU.unpkcs7 (AES.decryptCbcAES128 k cip) + cod = TE.decodeLatin1 msg + liftIO $ slog host $ "DEcRyptEd cIPheRTeXt: \"" <> cod <> "\"" + liftIO $ slog host $ "reLayINg cIpheRtExt" + pure $ Just (SendMessage cip) + + SendTerminal cip -> do + sesh@Sesh {..} <- S.get + let cod = B64.encodeBase64 cip + liftIO $ slog host $ "reCeiVeD CipHeRtExt " <> cod + case dhKey of + Nothing -> error "mallory knows key" + Just k -> do + let Just msg = CU.unpkcs7 (AES.decryptCbcAES128 k cip) + cod = TE.decodeLatin1 msg + liftIO $ slog host $ "DeCrYpteD cIphErteXt: \"" <> cod <> "\"" + liftIO $ slog host $ "ReLaYINg CiPHeRTexT" + pure $ Just (SendTerminal cip) + +-- basic TCP coordination +session host sock = + deco + >-> P.mapM eval + >-> for cat PB.encode + >-> send + where + recv = PN.fromSocket sock 4096 + deco = PP.parsed PB.decode recv + send = PN.toSocket sock + eval = beval host + +-- MITM TCP coordination +dance host asock bsock = + PP.parsed PB.decode recv + >-> P.mapM (meval host) + >-> for cat PB.encode + >-> PN.foxtrot bsock asock + where + recv = PN.rhumba asock bsock 4096 + diff --git a/lib/Pipes/Network.hs b/lib/Pipes/Network.hs @@ -8,6 +8,8 @@ module Pipes.Network ( , fromSocket , toSocket + , rhumba + , foxtrot , NT.connect , NT.serve @@ -24,6 +26,7 @@ import qualified Network.Socket as N import qualified Network.Socket.ByteString as NB import GHC.Word (Word32) +-- receive on socket fromSocket :: MonadIO m => N.Socket @@ -38,9 +41,40 @@ fromSocket s n = loop where P.yield b loop +-- send on socket toSocket :: MonadIO m => N.Socket -> P.Consumer' BS.ByteString m r toSocket s = P.for P.cat (NT.send s) +-- receive on alternate sockets +rhumba + :: MonadIO m + => N.Socket + -> N.Socket + -> Word32 + -> P.Producer' BS.ByteString m () +rhumba a b n = loop True where + loop lip = do + let s = if lip then a else b + b <- liftIO (NB.recv s (fromIntegral n)) + if BS.null b + then pure () + else do + P.yield b + loop (not lip) + +-- send on alternate sockets +foxtrot + :: MonadIO m + => N.Socket + -> N.Socket + -> P.Consumer BS.ByteString m b +foxtrot asock bsock = loop True where + loop lip = do + b <- P.await + let s = if lip then asock else bsock + liftIO $ NT.send s b + loop (not lip) +