commit 7e7cff6b614334e709ae5a08c1925d15bd2df34c
parent f51db58f454ae97724cd687e07193439f2f2e62b
Author: Jared Tobin <jared@jtobin.io>
Date: Mon, 14 Aug 2023 10:23:46 -0230
Some refactoring.
Diffstat:
4 files changed, 96 insertions(+), 95 deletions(-)
diff --git a/lib/Cryptopals/Block/Attacks.hs b/lib/Cryptopals/Block/Attacks.hs
@@ -22,14 +22,11 @@ import qualified Data.Text.Encoding as TE
import GHC.Word (Word8)
import qualified System.Random.MWC as MWC
-bytes :: PrimMonad m => Int -> MWC.Gen (PrimState m) -> m BS.ByteString
-bytes n gen = fmap BS.pack $ replicateM n (MWC.uniform gen)
-
-- | An unknown AES key.
consistentKey :: BS.ByteString
consistentKey = ST.runST $ do
gen <- MWC.create
- bytes 16 gen
+ CU.bytes 16 gen
chaosEncrypter
:: PrimMonad m
@@ -37,9 +34,9 @@ chaosEncrypter
-> MWC.Gen (PrimState m)
-> m BS.ByteString
chaosEncrypter plaintext gen = do
- key <- bytes 16 gen
- pre <- MWC.uniformR (5, 10) gen >>= flip bytes gen
- pos <- MWC.uniformR (5, 10) gen >>= flip bytes gen
+ key <- CU.bytes 16 gen
+ pre <- MWC.uniformR (5, 10) gen >>= flip CU.bytes gen
+ pos <- MWC.uniformR (5, 10) gen >>= flip CU.bytes gen
let tex = pre <> plaintext <> pos
bs = CU.lpkcs7 tex
@@ -49,7 +46,7 @@ chaosEncrypter plaintext gen = do
if ecb
then pure $ AES.encryptEcbAES128 key bs
else do
- iv <- bytes 16 gen
+ iv <- CU.bytes 16 gen
pure $ AES.encryptCbcAES128 iv key bs
alienEncrypter :: BS.ByteString -> BS.ByteString
@@ -169,7 +166,7 @@ weirdEncrypter plaintext gen = do
]
bys <- MWC.uniformR (1, 256) gen
- pre <- bytes bys gen
+ pre <- CU.bytes bys gen
let par = pre <> plaintext <> pos
bs = CU.lpkcs7 par
@@ -245,7 +242,7 @@ paddingOracle gen = do
idx <- MWC.uniformR (0, length poInputs - 1) gen
let Right input = B64.decodeBase64 (poInputs !! idx)
padded = CU.lpkcs7 input
- iv <- bytes 16 gen
+ iv <- CU.bytes 16 gen
pure $ AES.encryptCbcAES128 iv consistentKey padded
poValidate :: BS.ByteString -> Bool
diff --git a/lib/Cryptopals/DH.hs b/lib/Cryptopals/DH.hs
@@ -9,7 +9,6 @@ module Cryptopals.DH (
) where
import Control.Concurrent (threadDelay)
-import Control.Monad
import Control.Monad.Primitive
import Control.Monad.Trans.State (StateT)
import qualified Control.Monad.Trans.State as S
@@ -78,9 +77,6 @@ g :: Natural
g = 2
-- XX i should really put this somewhere instead of copying it every time
-bytes :: PrimMonad m => Int -> MWC.Gen (PrimState m) -> m BS.ByteString
-bytes n gen = fmap BS.pack $ replicateM n (MWC.uniform gen)
-
-- modified from https://gist.github.com/trevordixon/6788535
modexp :: Natural -> Natural -> Natural -> Natural
modexp b e m
@@ -110,17 +106,28 @@ derivekey (Group p _) Keys {..} pk =
slog :: T.Text -> T.Text -> IO ()
slog host msg = TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg
--- session eval
-seval :: T.Text -> Maybe Command -> StateT Sesh IO (Maybe Command)
-seval host = \case
+-- 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
- dheval host cmd
+ 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 eval
+-- diffie-hellman protocol eval
dheval
:: T.Text
-> Command
@@ -154,7 +161,7 @@ dheval host = \case
pure Nothing
Just k -> do
gen <- liftIO dhGen
- iv <- liftIO $ bytes 16 gen
+ iv <- liftIO $ CU.bytes 16 gen
let msg = CU.lpkcs7 "attack at 10pm"
cip = AES.encryptCbcAES128 iv k msg
cod = B64.encodeBase64 cip
@@ -182,7 +189,7 @@ dheval host = \case
Just j -> BS.drop j msg
gen <- liftIO dhGen
- iv <- liftIO $ bytes 16 gen
+ iv <- liftIO $ CU.bytes 16 gen
let nmsg = CU.lpkcs7 $ "confirmed, attacking at " <> hourOfDestiny
ncip = AES.encryptCbcAES128 iv k nmsg
ncod = B64.encodeBase64 ncip
@@ -203,6 +210,52 @@ dheval host = \case
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
@@ -213,7 +266,7 @@ bob port = PN.serve "localhost" port $ \(sock, _) -> do
, dhGen = MWC.createSystemRandom
}
slog "bob" $ "listening.."
- void $ S.evalStateT (runEffect (handle "bob" sock)) sesh
+ void $ S.evalStateT (runEffect (session "bob" sock)) sesh
-- initiate key exchange
alice :: PN.ServiceName -> IO ()
@@ -234,18 +287,7 @@ alice port = PN.connect "localhost" port $ \(sock, _) -> do
, dhKey = Nothing
, dhGen = pure gen
}
- void $ S.runStateT (runEffect (handle "alice" sock)) sesh
-
-handle 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
+ void $ S.runStateT (runEffect (session "alice" sock)) sesh
-- await key exchange
mallory :: MonadIO m => PN.ServiceName -> PN.ServiceName -> m a
@@ -262,6 +304,19 @@ 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)
@@ -270,7 +325,7 @@ dance host asock bsock =
where
recv = rhumba asock bsock 4096
--- alternate receiving on provided sockets
+-- receive on alternate sockets
rhumba
:: MonadIO m
=> N.Socket
@@ -287,7 +342,7 @@ rhumba a b n = loop True where
yield b
loop (not lip)
--- alternate sending on provided sockets
+-- send on alternate sockets
foxtrot
:: MonadIO m
=> N.Socket
@@ -300,58 +355,3 @@ foxtrot asock bsock = loop True where
liftIO $ PN.send s b
loop (not lip)
--- mitm eval
-meval :: T.Text -> Maybe Command -> StateT Sesh IO (Maybe Command)
-meval host = \case
- Nothing -> liftIO $ do
- slog host "eNDiNg sESSiOn"
- SE.exitSuccess
- Just cmd -> do
- liftIO $ threadDelay 1000000
- mitmeval host cmd
-
-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 paRaMs"
- 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)
-
diff --git a/lib/Cryptopals/Stream/Attacks.hs b/lib/Cryptopals/Stream/Attacks.hs
@@ -16,14 +16,11 @@ import qualified Cryptopals.Util as CU
import GHC.Word (Word64, Word16, Word8)
import qualified System.Random.MWC as MWC
-bytes :: PrimMonad m => Int -> MWC.Gen (PrimState m) -> m BS.ByteString
-bytes n gen = fmap BS.pack $ replicateM n (MWC.uniform gen)
-
-- | An unknown AES key.
consistentKey :: BS.ByteString
consistentKey = ST.runST $ do
gen <- MWC.create
- bytes 16 gen
+ CU.bytes 16 gen
consistentNonce :: Word64
consistentNonce = ST.runST $ do
diff --git a/lib/Cryptopals/Util.hs b/lib/Cryptopals/Util.hs
@@ -16,8 +16,11 @@ module Cryptopals.Util (
, CUS.tally
, CUS.gtally
, unpkcs7
+ , bytes
) where
+import Control.Monad
+import Control.Monad.Primitive
import qualified Cryptopals.Util.ByteString as CUB
import qualified Cryptopals.Util.Similarity as CUS
import qualified Data.Bits as B
@@ -26,6 +29,10 @@ import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Base64 as B64
import qualified Data.Text as T
import GHC.Word (Word8)
+import qualified System.Random.MWC as MWC
+
+bytes :: PrimMonad m => Int -> MWC.Gen (PrimState m) -> m BS.ByteString
+bytes n gen = fmap BS.pack $ replicateM n (MWC.uniform gen)
fixedXor :: BS.ByteString -> BS.ByteString -> BS.ByteString
fixedXor l r = BS.pack $ BS.zipWith B.xor l r
