commit ad29fe190d65b857fcd4411d6f2b5ed583ea7081
parent 8bd46b8164ab79a1152a9e22753c3f183acaadee
Author: Jared Tobin <jared@jtobin.io>
Date: Tue, 15 Aug 2023 18:28:49 -0230
Add 5.35.
Diffstat:
| M | docs/s5.md | | | 162 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---------- |
| M | lib/Cryptopals/DH.hs | | | 72 | ++++++++++++++++++++++++++++++++++++++---------------------------------- |
| M | lib/Cryptopals/DH/Session.hs | | | 416 | +++++++++++++++++++++++++++++++++++++++++++++---------------------------------- |
3 files changed, 417 insertions(+), 233 deletions(-)
diff --git a/docs/s5.md b/docs/s5.md
@@ -62,13 +62,24 @@ That's all well and good, but let's have a bit of fun.
Cryptopals.DH implements the Diffie-Hellman protocol over TCP. Two
functions, 'bob' and 'alice', will initiate a TCP server and client,
-respectively. Each end will then cooperate to perform Diffie-Hellman,
-for the lulz then exchanging an AES128-encrypted message with the shared
-key à la the initial illustration in the next challenge.
+respectively. Each takes as argument a port to bind to and a protocol to
+follow, with Alice also taking an argument specifying the initial action
+she'll take. The two will then perform the specified protocol.
-Opening two instances of GHCi, we can run 'bob' in one and 'alice' in
-the other and watch the logs for fun. Here I'll interleave the relevant
-parts of the logs for readability:
+The 'dh' protocol specifies Diffie-Hellman, and for the lulz Alice and
+Bob will exchange a message, AES128-encrypted with the shared key, à la
+the initial illustration in the next challenge.
+
+Opening two instances of GHCi, we can run e.g.:
+
+ > bob "3000" dh
+
+in one, and:
+
+ > alice "3000" dh
+
+in the other and watch the logs for fun. Here I'll interleave the
+relevant parts of the logs for readability:
(cryptopals) bob: listening..
(cryptopals) alice: session established
@@ -76,26 +87,38 @@ parts of the logs for readability:
(cryptopals) bob: received group parameters and public key
(cryptopals) bob: sending public key
(cryptopals) alice: received public key
- (cryptopals) alice: sending ciphertext
- (cryptopals) bob: received ciphertext
+ (cryptopals) alice: sending ciphertext fQwcd2smXxBojyEDLrIdySNLAV3UHhl8/X2F/x4FIb0=
+ (cryptopals) bob: received ciphertext fQwcd2smXxBojyEDLrIdySNLAV3UHhl8/X2F/x4FIb0=
(cryptopals) bob: decrypted ciphertext: "attack at 10pm"
- (cryptopals) bob: replying with ciphertext
- (cryptopals) alice: received ciphertext
+ (cryptopals) bob: replying with ciphertext NaObgnz4rNShMKRGdGv+OGnI2gZnWOoXuYmCZhlcyymRbHPaprFVOz4Ls5eH9y/W
+ (cryptopals) alice: received ciphertext NaObgnz4rNShMKRGdGv+OGnI2gZnWOoXuYmCZhlcyymRbHPaprFVOz4Ls5eH9y/W
(cryptopals) alice: decrypted ciphertext: "confirmed, attacking at 10pm"
(cryptopals) bob: ending session
#### 5.34
If B = p in s = B ^ a mod p, then s = p ^ a mod p, which is zero for any
-'a' in the group. Our key is thus going to be the first 16 bytes of the
-SHA1 hash of an appropriately-serialized 0x00.
+'a' in the group. Our shared key is thus going to be the first 16 bytes
+of the SHA1 hash of an appropriately-serialized 0x00.
+
+Cryptopals.DH includes a 'mallory' agent that requires a port to listen
+on, a port to bind to, and a protocol to follow. By using the 'dhmitm'
+protocol, we get our man-in-the-middle attack on Alice and Bob's DH key
+exchange.
+
+You can get this going by opening three GHCi's, then launching e.g.:
+
+ > bob "3000" dh
+
+in one, then:
+
+ > mallory "3001" "3000" dhmitm
+
+in another, and finally:
+
+ > alice "3001" dh sendParams
-Thus, Mallory will learn the key and trivially be able to decrypt
-messages. Adding a 'mallory' agent to Cryptopals.DH, we get our MITM
-attack on the above DH key exchange. You can get this going by opening
-three GHCi's, then launching e.g. `bob "3000"` in one, `mallory "3001"
-"3000"` in another, and then `alice "3001"` in the last. Again, I'm
-interleaving the logs for readability:
+in the third. Again, I'm interleaving the logs for readability:
(cryptopals) bob: listening..
(cryptopals) mallory: LiSteNIng..
@@ -103,7 +126,7 @@ interleaving the logs for readability:
(cryptopals) mallory: eStabLisHed coNNecTion
(cryptopals) alice: sending group parameters and public key
(cryptopals) mallory: reCEiVed GRoUp pArAmeTErs And pUBliC kEy
- (cryptopals) mallory: sEnDinG BOguS paRaMs
+ (cryptopals) mallory: sEnDinG BOguS paRaMeTeRs
(cryptopals) bob: received group parameters and public key
(cryptopals) bob: sending public key
(cryptopals) mallory: REceIvED pUBlic keY
@@ -122,3 +145,104 @@ interleaving the logs for readability:
(cryptopals) alice: received ciphertext ux4PoPTCS7pz5H4IQ11AuZkMBHmEcT9Waz68y/a9nggIY38Z6mbwSrCwNO3OKcDQ
(cryptopals) alice: decrypted ciphertext: "confirmed, attacking at 10pm"
+#### 5.35
+
+Cryptopals.DH.dhng implements the negotiated-groups DH protocol, so that
+can be run by firing off e.g.:
+
+ > bob "3000" dhng
+
+in one GHCi session, and:
+
+ > alice "3000" dhng sendGroup
+
+in the other. In the meantime, we can figure out the outcomes of using
+the different malicious group parameters analytically.
+
+For g = 1, the MITM attack starts as follows:
+
+ alice sends p, g
+ bob gets p, 1
+
+If Bob receives g = 1, then Mallory knows his public key will equal 1 ^
+b mod p = 1, as will the shared key from Alice's perspective (since 1 ^
+a mod p = 1). Mallory thus needs to forward a 1 as Alice's public key in
+order for Bob to agree on the shared key.
+
+For g = p, Bob computes B = p ^ b mod p = 0, so Mallory needs to forward
+a 0 as Alice's public key in order for them to agree on the shared key.
+
+Finally, the case of g = p - 1. Note that for any p > 1 and any even b, we
+have (for appropriate coefficients a, c, etc.):
+
+ (p - 1) ^ b mod p
+ = (p^b + .. + ap^2 + cp + 1) mod p
+ = (p^b mod p + .. + ap^2 mod p + cp mod p + 1 mod p) mod p
+ = (0 + .. + 0 + 1 mod p) mod p
+ = 1
+
+whereas for any odd b, we have:
+
+ (p - 1) ^ b mod p
+ = (p^b - .. - cp^2 + dp - 1) mod p
+ = (p^b mod p - .. - ap^2 mod p + cp mod p - 1 mod p) mod p
+ = (0 + .. + 0 - 1 mod p) mod p
+ = p - 1.
+
+So Bob's public key will be either 1 or p - 1 depending on whether his
+secret key is even or odd. Alice will thus compute:
+
+ s = B ^ a mod p
+ = 1 } b even or a even
+ p - 1 } b odd and a odd.
+
+If Mallory thus forwards A = 1 to Bob, we have:
+
+ t = A ^ b mod p
+ = 1.
+
+So, Alice and Bob will agree on the key 1 (i.e., the attack succeeds)
+whenever 'b' is even or 'a' is even, an event that occurs with
+probability 1/2 + 1/2 - 1/4 = 3/4.
+
+(Mallory could ensure the attack works every time by forwarding 1's for
+*both* public keys, but that seems against the spirit of the question.)
+
+Here are the interleaved logs of a successful attack:
+
+ (cryptopals) bob: listening..
+ (cryptopals) mallory: LiSteNIng..
+ (cryptopals) alice: session established
+ (cryptopals) mallory: eStabLisHed MiTm coNNecTion
+ (cryptopals) alice: sending group parameters
+ (cryptopals) mallory: reCEiVed GRoUp pArAmeTErs
+ (cryptopals) mallory: sEnDinG BOguS GRoUp paRaMeTeRs
+ (cryptopals) bob: received group parameters
+ (cryptopals) bob: acking group parameters
+ (cryptopals) mallory: rECeiVed aCK
+ (cryptopals) mallory: ReLaYINg ACk
+ (cryptopals) alice: received ack
+ (cryptopals) alice: sending public key 3f44f49421cbb3b2ed40aa8f068236affba15335
+ (cryptopals) mallory: REceIvED pUBlic keY 3f44f49421cbb3b2ed40aa8f068236affba15335
+ (cryptopals) mallory: SeNDing BoGuS kEy d14952314d5de233ef0dd0a178617f7f07ea082c
+ (cryptopals) bob: received public key d14952314d5de233ef0dd0a178617f7f07ea082c
+ (cryptopals) bob: sending public key
+ (cryptopals) mallory: REceIvED pUBlic keY d14952314d5de233ef0dd0a178617f7f07ea082c
+ (cryptopals) mallory: ReLAyINg pUbliC KeY d14952314d5de233ef0dd0a178617f7f07ea082c
+ (cryptopals) alice: received public key d14952314d5de233ef0dd0a178617f7f07ea082c
+ (cryptopals) alice: sending ciphertext +nbU0t3nLX3WmKoY3+pdmilVcd2I6fJfGuC3RTn0h5E=
+ (cryptopals) mallory: rECeIveD CiPHeRTexT +nbU0t3nLX3WmKoY3+pdmilVcd2I6fJfGuC3RTn0h5E=
+ (cryptopals) mallory: DEcRyptEd cIPheRTeXt: "attack at 10pm"
+ (cryptopals) mallory: reLayINg cIpheRtExt
+ (cryptopals) bob: received ciphertext +nbU0t3nLX3WmKoY3+pdmilVcd2I6fJfGuC3RTn0h5E=
+ (cryptopals) bob: decrypted ciphertext: "attack at 10pm"
+ (cryptopals) bob: replying with ciphertext 3i7fLAZXJv7+cr3qrI8KDKhfe6FpJq62yVtaCt9dlrUodMiRVtJ7ZmKtJ8ku0r4x
+ (cryptopals) mallory: reCeiVeD CipHeRtExt 3i7fLAZXJv7+cr3qrI8KDKhfe6FpJq62yVtaCt9dlrUodMiRVtJ7ZmKtJ8ku0r4x
+ (cryptopals) mallory: DeCrYpteD cIphErteXt: "confirmed, attacking at 10pm"
+ (cryptopals) mallory: ReLaYINg CiPHeRTexT
+ (cryptopals) alice: received ciphertext 3i7fLAZXJv7+cr3qrI8KDKhfe6FpJq62yVtaCt9dlrUodMiRVtJ7ZmKtJ8ku0r4x
+ (cryptopals) alice: decrypted ciphertext: "confirmed, attacking at 10pm"
+ (cryptopals) mallory: ending session
+
+
+
diff --git a/lib/Cryptopals/DH.hs b/lib/Cryptopals/DH.hs
@@ -25,17 +25,11 @@ import qualified System.Random.MWC as MWC
bob
:: (DB.Binary b, DB.Binary c)
=> PN.ServiceName
- -> Handler (StateT Sesh IO) b c
+ -> Protocol (StateT Sesh IO) b c
-> IO ()
bob port eval = PN.serve "localhost" port $ \(sock, _) -> do
let host = "bob"
- sesh = Sesh {
- dhGroup = Nothing
- , dhHost = host
- , dhKeys = Nothing
- , dhKey = Nothing
- , dhGen = MWC.createSystemRandom
- }
+ sesh = open sock host
blog host "listening.."
void $ S.evalStateT (runEffect (session sock eval)) sesh
@@ -43,48 +37,58 @@ bob port eval = PN.serve "localhost" port $ \(sock, _) -> do
alice
:: (DB.Binary b, DB.Binary c)
=> PN.ServiceName
- -> Handler (StateT Sesh IO) b c
+ -> Protocol (StateT Sesh IO) b c
+ -> StateT Sesh IO Command
-> IO ()
-alice port eval = PN.connect "localhost" port $ \(sock, _) -> do
+alice port eval knit = PN.connect "localhost" port $ \(sock, _) -> do
let host = "alice"
+ sesh = open sock host
blog host "session established"
- let grp = Group p g
- gen <- MWC.createSystemRandom
- per@Keys {..} <- genpair grp gen
- blog host "sending group parameters and public key"
- runEffect $ do
- PB.encode (Just (SendParams grp pub))
+ (cmd, nex) <- S.runStateT knit sesh
+
+ runEffect $
+ PB.encode (Just cmd)
>-> PN.toSocket sock
- let sesh = Sesh {
- dhGroup = Just grp
- , dhHost = host
- , dhKeys = Just per
- , dhKey = Nothing
- , dhGen = pure gen
- }
- void $ S.runStateT (runEffect (session sock eval)) sesh
+ void $ S.runStateT (runEffect (session sock eval)) nex
--- await key exchange, initiate key exchange
+-- await key exchange
mallory
:: (DB.Binary b, DB.Binary c)
=> PN.ServiceName
-> PN.ServiceName
- -> Handler (StateT Sesh IO) b c
+ -> Protocol (StateT Sesh IO) b c
-> IO ()
mallory port bport eval = do
let host = "mallory"
PN.serve "localhost" port $ \(asock, _) -> do
+ let sesh = open asock host
blog host "LiSteNIng.."
PN.connect "localhost" bport $ \(bsock, _) -> do
- let sesh = Sesh {
- dhGroup = Nothing
- , dhHost = host
- , dhKeys = Nothing
- , dhKey = Nothing
- , dhGen = MWC.createSystemRandom
- }
- blog host "eStabLisHed coNNecTion"
+ blog host "eStabLisHed MiTm coNNecTion"
void $ S.runStateT (runEffect (dance asock bsock eval)) sesh
+-- initialize session with basic stuff
+open :: PN.Socket -> T.Text -> Sesh
+open sock host = Sesh {
+ dhGroup = Nothing
+ , dhHost = host
+ , dhSock = sock
+ , dhKeys = Nothing
+ , dhKey = Nothing
+ , dhGen = MWC.createSystemRandom
+ }
+
+sendParams :: StateT Sesh IO Command
+sendParams = do
+ grp <- genGroup p g
+ Keys {..} <- genKeypair
+ slog "sending group parameters and public key"
+ pure (SendParams grp pub)
+
+sendGroup :: StateT Sesh IO Command
+sendGroup = do
+ grp <- genGroup p g
+ slog "sending group parameters"
+ pure (SendGroup grp)
diff --git a/lib/Cryptopals/DH/Session.hs b/lib/Cryptopals/DH/Session.hs
@@ -3,13 +3,22 @@
module Cryptopals.DH.Session (
Command(..)
+ , genGroup
+ , genKeypair
+
+
, Sesh(..)
- , Handler
+ , Protocol
, blog
, slog
- , beval
- , meval
+
+ , dh
+ , dhng
+
+ , dhmitm
+ , dhngmitm
+ , dhngmitm'
, session
, dance
@@ -22,9 +31,12 @@ 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.Digest.Pure.SHA as CS
import qualified Cryptopals.Util as CU
import qualified Data.Binary as DB
import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B8
import qualified Data.Char as C
@@ -54,13 +66,13 @@ data Command =
instance DB.Binary Command
-type Handler m b c = b -> m c
+type Protocol m b c = b -> m c
-- session state
data Sesh = Sesh {
dhGroup :: Maybe Group
, dhHost :: T.Text
- -- , dhSock :: PN.Socket -- XX add me
+ , dhSock :: PN.Socket
, dhKeys :: Maybe Keys
, dhKey :: Maybe BS.ByteString
, dhGen :: IO (MWC.Gen RealWorld)
@@ -75,12 +87,17 @@ slog :: T.Text -> StateT Sesh IO ()
slog msg = do
host <- S.gets dhHost
liftIO $ TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg
+ liftIO suspense
+
+-- dramatic effect
+suspense :: IO ()
+suspense = threadDelay 1000000
-- basic TCP coordination
session
:: (MonadIO m, DB.Binary b, DB.Binary c)
=> PN.Socket
- -> Handler m b c
+ -> Protocol m b c
-> Effect m (PB.DecodingError, Producer BS.ByteString m ())
session sock eval =
deco
@@ -97,7 +114,7 @@ dance
:: (MonadIO m, DB.Binary b, DB.Binary c)
=> PN.Socket
-> PN.Socket
- -> Handler m b c
+ -> Protocol m b c
-> Effect m (PB.DecodingError, Producer BS.ByteString m ())
dance asock bsock eval =
PP.parsed PB.decode recv
@@ -117,22 +134,28 @@ seval cont = \case
slog "ending session"
liftIO $ SE.exitSuccess -- XX should really just close the socket
Just cmd -> do
- liftIO $ threadDelay 3000000
+ liftIO suspense
cont cmd
-- basic dh evaluation
-beval :: Maybe Command -> StateT Sesh IO (Maybe Command)
-beval = seval dheval
+dh :: Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command)
+dh = seval dheval
-- mitm dh evaluation
-meval :: Maybe Command -> StateT Sesh IO (Maybe Command)
-meval = seval mitmeval
+dhmitm :: Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command)
+dhmitm = seval mitmeval
-- negotiated-group dh evaluation
-geval :: Maybe Command -> StateT Sesh IO (Maybe Command)
-geval = seval ngeval
+dhng :: Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command)
+dhng = seval ngeval
+
+-- mitm negotiated-group dh evaluation
+dhngmitm :: Natural -> Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command)
+dhngmitm = seval . malgeval
--- XX refactor some common actions, e.g. assembling ciphertexts
+-- mitm negotiated-group dh evaluation, g = p - 1
+dhngmitm' :: Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command)
+dhngmitm' = seval malgeval'
-- diffie-hellman protocol eval
dheval
@@ -148,81 +171,37 @@ dheval = \case
pure Nothing
SendParams grp pk -> do
- sesh@Sesh {..} <- S.get
- slog "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
- slog "sending public key"
+ slog $ "received group parameters and public key " <> renderkey pk
+ S.modify (\sesh -> sesh { dhGroup = Just grp })
+ Keys {..} <- genKeypair
+ deriveKey pk
+ slog $ "sending public key " <> renderkey pk
pure $ Just (SendPublic pub)
SendPublic pk -> do
+ slog $ "received public key " <> renderkey pk
sesh@Sesh {..} <- S.get
- slog "received public key"
- let key = do
- per@Keys {..} <- dhKeys
- grp <- dhGroup
- pure $ derivekey grp per pk
- case key of
- Nothing -> do
- slog "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
- slog $ "sending ciphertext " <> cod
- let rep = Just (SendMessage cip)
- nex = sesh { dhKey = key }
- S.put nex
- pure rep
+ k <- deriveKey pk
+ cip <- encrypt "attack at 10pm"
+ S.put sesh { dhKey = Just k }
+ slog $ "sending ciphertext " <> B64.encodeBase64 cip
+ pure $ Just (SendMessage cip)
SendMessage cip -> do
+ slog $ "received ciphertext " <> B64.encodeBase64 cip
sesh@Sesh {..} <- S.get
- let cod = B64.encodeBase64 cip
- slog $ "received ciphertext " <> cod
- case dhKey of
- Nothing -> do
- slog "shared key not established"
- pure Nothing
- Just k -> do
- let Just msg = CU.unpkcs7 (AES.decryptCbcAES128 k cip)
- cod = TE.decodeLatin1 msg
- slog $ "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
- slog $ "replying with ciphertext " <> ncod
- pure $ Just (SendTerminal ncip)
+ msg <- decrypt cip
+ slog $ "decrypted ciphertext: \"" <> TE.decodeLatin1 msg <> "\""
+ ncip <- encrypt $ "confirmed, attacking at 10pm"
+ slog $ "replying with ciphertext " <> B64.encodeBase64 ncip
+ pure $ Just (SendTerminal ncip)
SendTerminal cip -> do
+ slog $ "received ciphertext " <> B64.encodeBase64 cip
sesh@Sesh {..} <- S.get
- let cod = B64.encodeBase64 cip
- slog $ "received ciphertext " <> cod
- case dhKey of
- Nothing -> do
- slog "shared key not established"
- pure Nothing
- Just k -> do
- let Just msg = CU.unpkcs7 (AES.decryptCbcAES128 k cip)
- cod = TE.decodeLatin1 msg
- slog $ "decrypted ciphertext: \"" <> cod <> "\""
- pure Nothing
+ msg <- decrypt cip
+ slog $ "decrypted ciphertext: \"" <> TE.decodeLatin1 msg <> "\""
+ pure Nothing
-- man-in-the-middle protocol eval
mitmeval
@@ -230,44 +209,38 @@ mitmeval
-> StateT Sesh IO (Maybe Command)
mitmeval = \case
SendParams grp pk -> do
+ slog $ "reCEiVed GRoUp pArAmeTErs And pUBliC kEy " <> renderkey pk
sesh@Sesh {..} <- S.get
- slog "reCEiVed GRoUp pArAmeTErs And pUBliC kEy"
let key = derivekey grp (Keys p 1) p
nex = sesh { dhKey = Just key }
S.put nex
- slog "sEnDinG BOguS paRaMeTeRs"
+ slog $ "sEnDinG BOguS paRaMeTeRs wIth PuBLiC kEy " <> renderkey p
pure $ Just (SendParams grp p)
SendPublic pk -> do
- slog "REceIvED pUBlic keY"
- slog "seNDINg boGus kEy"
+ slog $ "REceIvED pUBlic keY " <> renderkey pk
+ slog $ "seNDINg boGus kEy " <> renderkey p
pure $ Just (SendPublic p)
SendMessage cip -> do
+ slog $ "rECeIveD CiPHeRTexT " <> B64.encodeBase64 cip
sesh@Sesh {..} <- S.get
- let cod = B64.encodeBase64 cip
- slog $ "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
- slog $ "DEcRyptEd cIPheRTeXt: \"" <> cod <> "\""
- slog "reLayINg cIpheRtExt"
- pure $ Just (SendMessage cip)
+ msg <- decrypt cip
+ slog $ "DEcRyptEd cIPheRTeXt: \"" <> TE.decodeLatin1 msg <> "\""
+ slog "reLayINg cIpheRtExt"
+ pure $ Just (SendMessage cip)
SendTerminal cip -> do
+ slog $ "reCeiVeD CipHeRtExt " <> B64.encodeBase64 cip
sesh@Sesh {..} <- S.get
- let cod = B64.encodeBase64 cip
- slog $ "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
- slog $ "DeCrYpteD cIphErteXt: \"" <> cod <> "\""
- slog "ReLaYINg CiPHeRTexT"
- pure $ Just (SendTerminal cip)
+ msg <- decrypt cip
+ slog $ "DeCrYpteD cIphErteXt: \"" <> TE.decodeLatin1 msg <> "\""
+ slog "ReLaYINg CiPHeRTexT"
+ pure $ Just (SendTerminal cip)
+
+ cmd -> do
+ slog "RelAyInG coMmaNd"
+ pure (Just cmd)
-- negotiated-group protocol eval
ngeval
@@ -275,95 +248,178 @@ ngeval
-> StateT Sesh IO (Maybe Command)
ngeval = \case
SendGroup grp -> do
- sesh@Sesh {..} <- S.get
slog "received group parameters"
- let nex = sesh { dhGroup = Just grp }
- S.put nex
- slog "ACK"
+ sesh@Sesh {..} <- S.get
+ S.put sesh { dhGroup = Just grp }
+ slog "acking group parameters"
pure (Just AckGroup)
AckGroup -> do
+ slog "received ack"
sesh@Sesh {..} <- S.get
- slog "ACK ACK"
- gen <- liftIO dhGen
- case dhGroup of
- Nothing -> do
- slog "haven't generated group yet"
- pure Nothing
- Just grp -> do
- per@Keys {..} <- liftIO $ genpair grp gen
- let nex = sesh { dhKeys = Just per }
- S.put nex
- slog "sending public key"
- pure $ Just (SendPublic pub)
+ Keys {..} <- genKeypair
+ slog $ "sending public key " <> renderkey pub
+ pure $ Just (SendPublic pub)
- SendParams grp pk -> do
+ SendParams {} -> do
slog "not expecting group parameters and public key"
pure Nothing
SendPublic pk -> do
+ slog $ "received public key " <> renderkey pk
sesh@Sesh {..} <- S.get
- slog "received public key"
- case dhGroup of
+ case dhKeys of
Nothing -> do
- slog "don't have group parameters"
- pure Nothing
- Just grp -> case dhKeys of
- Nothing -> do
- gen <- liftIO dhGen
- per@Keys {..} <- liftIO $ genpair grp gen
- let nex = sesh { dhKeys = Just per }
- S.put nex
- slog "sending public key"
- pure (Just (SendPublic pub))
- Just per@Keys {..} -> do
- let key = derivekey grp per pk
- nex = sesh { dhKey = Just key }
- S.put nex
- gen <- liftIO dhGen
- iv <- liftIO $ CU.bytes 16 gen
- let msg = CU.lpkcs7 "attack at 10pm"
- cip = AES.encryptCbcAES128 iv key msg
- cod = B64.encodeBase64 cip
- slog $ "sending ciphertext " <> cod
- pure $ Just (SendMessage cip)
+ Keys {..} <- genKeypair
+ key <- deriveKey pk
+ slog "sending public key"
+ pure (Just (SendPublic pub))
+ Just Keys {..} -> do
+ key <- deriveKey pk
+ cip <- encrypt "attack at 10pm"
+ slog $ "sending ciphertext " <> B64.encodeBase64 cip
+ pure (Just (SendMessage cip))
+
+ cmd -> dheval cmd
+
+-- negotiated-group mitm protocol eval
+malgeval
+ :: Natural
+ -> Command
+ -> StateT Sesh IO (Maybe Command)
+malgeval malg = \case
+ SendGroup grp -> do
+ slog "reCEiVed GRoUp pArAmeTErs"
+ sesh <- S.get
+ let key = derivekey grp (Keys p malg) malg
+ S.put sesh {
+ dhGroup = Just grp
+ , dhKey = Just key
+ }
+ let malgrp = Group p malg
+ slog "sEnDinG BOguS GRoUp paRaMeTeRs"
+ pure $ Just (SendGroup malgrp)
- SendMessage cip -> do
- sesh@Sesh {..} <- S.get
- let cod = B64.encodeBase64 cip
- slog $ "received ciphertext " <> cod
- case dhKey of
- Nothing -> do
- slog "shared key not established"
- pure Nothing
- Just k -> do
- let Just msg = CU.unpkcs7 (AES.decryptCbcAES128 k cip)
- cod = TE.decodeLatin1 msg
- slog $ "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
- slog $ "replying with ciphertext " <> ncod
- pure $ Just (SendTerminal ncip)
+ AckGroup -> do
+ slog "rECeiVed aCK"
+ slog "ReLaYINg ACk"
+ pure (Just AckGroup)
- SendTerminal cip -> do
+ SendParams grp pk -> do
+ slog "nOt eXPecTinG gRoUp and PublIc KeY"
+ pure Nothing
+
+ -- only want to send bogus key on the first time
+ SendPublic pk -> do
+ slog $ "REceIvED pUBlic keY " <> renderkey pk
+ slog $ "SeNDing BoGuS kEy " <> renderkey malg
+ pure $ Just (SendPublic malg)
+
+ cmd -> mitmeval cmd
+
+-- negotiated-group mitm protocol eval, g = p - 1
+malgeval'
+ :: Command
+ -> StateT Sesh IO (Maybe Command)
+malgeval' = \case
+ AckGroup -> do
+ slog "rECeiVed aCK"
+ slog "ReLaYINg ACk"
+ pure (Just AckGroup)
+
+ SendParams grp pk -> do
+ slog "nOt eXPecTinG gRoUp and PublIc KeY"
+ pure Nothing
+
+ SendPublic pk -> do
+ slog $ "REceIvED pUBlic keY " <> renderkey pk
sesh@Sesh {..} <- S.get
- let cod = B64.encodeBase64 cip
- slog $ "received ciphertext " <> cod
- case dhKey of
+ case dhKeys of
Nothing -> do
- slog "shared key not established"
- pure Nothing
- Just k -> do
- let Just msg = CU.unpkcs7 (AES.decryptCbcAES128 k cip)
- cod = TE.decodeLatin1 msg
- slog $ "decrypted ciphertext: \"" <> cod <> "\""
- pure Nothing
-
+ S.put sesh {
+ dhKeys = Just (Keys 1 1)
+ }
+ slog $ "SeNDing BoGuS kEy " <> renderkey 1
+ pure $ Just (SendPublic 1)
+ Just Keys {..} -> do
+ slog $ "ReLAyINg pUbliC KeY " <> renderkey pk
+ pure $ Just (SendPublic pk)
+
+ cmd -> malgeval (p - 1) cmd
+
+genGroup :: Natural -> Natural -> StateT Sesh IO Group
+genGroup p g = do
+ sesh <- S.get
+ let grp = Group p g
+ S.put sesh {
+ dhGroup = Just grp
+ }
+ pure grp
+
+genKeypair :: StateT Sesh IO Keys
+genKeypair = do
+ sesh@Sesh {..} <- S.get
+ case dhGroup of
+ Nothing -> do
+ slog "missing group parameters"
+ liftIO SE.exitFailure
+ Just grp -> do
+ gen <- liftIO dhGen
+ per <- liftIO $ genpair grp gen
+ S.put sesh {
+ dhKeys = Just per
+ }
+ pure per
+
+deriveKey :: Natural -> StateT Sesh IO BS.ByteString
+deriveKey pk = do
+ sesh@Sesh {..} <- S.get
+ let params = do
+ grp <- dhGroup
+ per <- dhKeys
+ pure (grp, per)
+ case params of
+ Nothing -> do
+ slog "missing group parameters or keypair"
+ liftIO SE.exitFailure
+ Just (grp, per) -> do
+ let key = derivekey grp per pk
+ S.put sesh {
+ dhKey = Just key
+ }
+ pure key
+
+encrypt :: BS.ByteString -> StateT Sesh IO BS.ByteString
+encrypt msg = do
+ sesh@Sesh {..} <- S.get
+ case dhKey of
+ Nothing -> do
+ slog "missing shared key"
+ liftIO SE.exitFailure
+ Just k -> do
+ gen <- liftIO dhGen
+ iv <- liftIO $ CU.bytes 16 gen
+ let pad = CU.lpkcs7 msg
+ pure $ AES.encryptCbcAES128 iv k pad
+
+decrypt :: BS.ByteString -> StateT Sesh IO BS.ByteString
+decrypt cip = do
+ sesh@Sesh {..} <- S.get
+ case dhKey of
+ Nothing -> do
+ slog "missing shared key"
+ liftIO SE.exitFailure
+ Just k -> do
+ case CU.unpkcs7 (AES.decryptCbcAES128 k cip) of
+ Nothing -> do
+ slog "couldn't decrypt ciphertext"
+ liftIO SE.exitFailure
+ Just msg -> pure msg
+
+renderkey :: Natural -> T.Text
+renderkey =
+ B16.encodeBase16
+ . BL.toStrict
+ . CS.bytestringDigest
+ . CS.sha1
+ . DB.encode
