commit 8bd46b8164ab79a1152a9e22753c3f183acaadee
parent d007b01a5b96446cd98f35ebc0403892e96ad29f
Author: Jared Tobin <jared@jtobin.io>
Date: Mon, 14 Aug 2023 14:32:38 -0230
More refactoring.
Diffstat:
2 files changed, 236 insertions(+), 84 deletions(-)
diff --git a/lib/Cryptopals/DH.hs b/lib/Cryptopals/DH.hs
@@ -11,6 +11,7 @@ import Control.Monad.Trans.State (StateT)
import qualified Control.Monad.Trans.State as S
import Cryptopals.DH.Core
import Cryptopals.DH.Session
+import qualified Data.Binary as DB
import qualified Data.ByteString as BS
import qualified Data.Text as T
import GHC.Word (Word32)
@@ -21,50 +22,69 @@ import qualified Pipes.Network as PN
import qualified System.Random.MWC as MWC
-- await key exchange
-bob :: MonadIO m => PN.ServiceName -> m a
-bob port = PN.serve "localhost" port $ \(sock, _) -> do
- let sesh = Sesh {
+bob
+ :: (DB.Binary b, DB.Binary c)
+ => PN.ServiceName
+ -> Handler (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
}
- slog "bob" $ "listening.."
- void $ S.evalStateT (runEffect (session "bob" sock)) sesh
+ blog host "listening.."
+ void $ S.evalStateT (runEffect (session sock eval)) sesh
-- initiate key exchange
-alice :: PN.ServiceName -> IO ()
-alice port = PN.connect "localhost" port $ \(sock, _) -> do
- slog "alice" $ "session established"
+alice
+ :: (DB.Binary b, DB.Binary c)
+ => PN.ServiceName
+ -> Handler (StateT Sesh IO) b c
+ -> IO ()
+alice port eval = PN.connect "localhost" port $ \(sock, _) -> do
+ let host = "alice"
+ blog host "session established"
let grp = Group p g
gen <- MWC.createSystemRandom
per@Keys {..} <- genpair grp gen
- slog "alice" $ "sending group parameters and public key"
+ blog host "sending group parameters and public key"
runEffect $ do
PB.encode (Just (SendParams grp pub))
>-> PN.toSocket sock
let sesh = Sesh {
dhGroup = Just grp
+ , dhHost = host
, dhKeys = Just per
, dhKey = Nothing
, dhGen = pure gen
}
- void $ S.runStateT (runEffect (session "alice" sock)) sesh
+ void $ S.runStateT (runEffect (session sock eval)) sesh
--- await key exchange
-mallory :: MonadIO m => PN.ServiceName -> PN.ServiceName -> m a
-mallory port bport =
+-- await key exchange, initiate key exchange
+mallory
+ :: (DB.Binary b, DB.Binary c)
+ => PN.ServiceName
+ -> PN.ServiceName
+ -> Handler (StateT Sesh IO) b c
+ -> IO ()
+mallory port bport eval = do
+ let host = "mallory"
PN.serve "localhost" port $ \(asock, _) -> do
- slog "mallory" $ "LiSteNIng.."
+ blog host "LiSteNIng.."
PN.connect "localhost" bport $ \(bsock, _) -> do
let sesh = Sesh {
dhGroup = Nothing
+ , dhHost = host
, dhKeys = Nothing
, dhKey = Nothing
, dhGen = MWC.createSystemRandom
}
- slog "mallory" $ "eStabLisHed coNNecTion"
- void $ S.runStateT (runEffect (dance "mallory" asock bsock)) sesh
+ blog host "eStabLisHed coNNecTion"
+ void $ S.runStateT (runEffect (dance asock bsock eval)) sesh
diff --git a/lib/Cryptopals/DH/Session.hs b/lib/Cryptopals/DH/Session.hs
@@ -4,7 +4,9 @@
module Cryptopals.DH.Session (
Command(..)
, Sesh(..)
+ , Handler
+ , blog
, slog
, beval
, meval
@@ -42,58 +44,112 @@ 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
+ SendGroup Group -- group only
+ | AckGroup -- ack receipt of group params
+ | SendParams Group Natural -- group + public key
+ | SendPublic Natural -- public key only
+ | SendMessage BS.ByteString -- send initial ciphertext
+ | SendTerminal BS.ByteString -- send final ciphertext
deriving (Eq, Show, Generic)
instance DB.Binary Command
+type Handler m b c = b -> m c
+
-- session state
data Sesh = Sesh {
dhGroup :: Maybe Group
+ , dhHost :: T.Text
+ -- , dhSock :: PN.Socket -- XX add me
, dhKeys :: Maybe Keys
, dhKey :: Maybe BS.ByteString
, dhGen :: IO (MWC.Gen RealWorld)
}
+-- basic log
+blog :: T.Text -> T.Text -> IO ()
+blog host msg = TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg
+
-- session log
-slog :: T.Text -> T.Text -> IO ()
-slog host msg = TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg
+slog :: T.Text -> StateT Sesh IO ()
+slog msg = do
+ host <- S.gets dhHost
+ liftIO $ TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg
+
+-- basic TCP coordination
+session
+ :: (MonadIO m, DB.Binary b, DB.Binary c)
+ => PN.Socket
+ -> Handler m b c
+ -> Effect m (PB.DecodingError, Producer BS.ByteString m ())
+session sock eval =
+ 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
+
+-- MITM TCP coordination
+dance
+ :: (MonadIO m, DB.Binary b, DB.Binary c)
+ => PN.Socket
+ -> PN.Socket
+ -> Handler m b c
+ -> Effect m (PB.DecodingError, Producer BS.ByteString m ())
+dance asock bsock eval =
+ PP.parsed PB.decode recv
+ >-> P.mapM eval
+ >-> for cat PB.encode
+ >-> PN.foxtrot bsock asock
+ where
+ recv = PN.rhumba asock bsock 4096
-- generic session evaluator
-geval
- :: MonadIO m
- => (T.Text -> Command -> m a)
- -> T.Text
+seval
+ :: (Command -> StateT Sesh IO a)
-> Maybe Command
- -> m a
-geval cont host = \case
- Nothing -> liftIO $ do
- slog host "ending session"
- SE.exitSuccess -- XX should really just close the socket
+ -> StateT Sesh IO a
+seval cont = \case
+ Nothing -> do
+ slog "ending session"
+ liftIO $ SE.exitSuccess -- XX should really just close the socket
Just cmd -> do
- liftIO $ threadDelay 1000000
- cont host cmd
+ liftIO $ threadDelay 3000000
+ cont cmd
-- basic dh evaluation
-beval :: T.Text -> Maybe Command -> StateT Sesh IO (Maybe Command)
-beval = geval dheval
+beval :: Maybe Command -> StateT Sesh IO (Maybe Command)
+beval = seval dheval
-- mitm dh evaluation
-meval :: T.Text -> Maybe Command -> StateT Sesh IO (Maybe Command)
-meval = geval mitmeval
+meval :: Maybe Command -> StateT Sesh IO (Maybe Command)
+meval = seval mitmeval
+
+-- negotiated-group dh evaluation
+geval :: Maybe Command -> StateT Sesh IO (Maybe Command)
+geval = seval ngeval
+
+-- XX refactor some common actions, e.g. assembling ciphertexts
-- diffie-hellman protocol eval
dheval
- :: T.Text
- -> Command
+ :: Command
-> StateT Sesh IO (Maybe Command)
-dheval host = \case
+dheval = \case
+ SendGroup _ -> do
+ slog "missing public key, aborting.."
+ pure Nothing
+
+ AckGroup -> do
+ slog "didn't send group, aborting.."
+ pure Nothing
+
SendParams grp pk -> do
sesh@Sesh {..} <- S.get
- liftIO $ slog host "received group parameters and public key"
+ slog "received group parameters and public key"
gen <- liftIO dhGen
per@Keys {..} <- liftIO $ genpair grp gen
let key = derivekey grp per pk
@@ -103,19 +159,19 @@ dheval host = \case
, dhKey = Just key
}
S.put nex
- liftIO $ slog host "sending public key"
+ slog "sending public key"
pure $ Just (SendPublic pub)
SendPublic pk -> do
sesh@Sesh {..} <- S.get
- liftIO $ slog host "received public key"
+ slog "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"
+ slog "key derivation failed"
pure Nothing
Just k -> do
gen <- liftIO dhGen
@@ -123,7 +179,7 @@ dheval host = \case
let msg = CU.lpkcs7 "attack at 10pm"
cip = AES.encryptCbcAES128 iv k msg
cod = B64.encodeBase64 cip
- liftIO . slog host $ "sending ciphertext " <> cod
+ slog $ "sending ciphertext " <> cod
let rep = Just (SendMessage cip)
nex = sesh { dhKey = key }
S.put nex
@@ -132,15 +188,15 @@ dheval host = \case
SendMessage cip -> do
sesh@Sesh {..} <- S.get
let cod = B64.encodeBase64 cip
- liftIO $ slog host $ "received ciphertext " <> cod
+ slog $ "received ciphertext " <> cod
case dhKey of
Nothing -> do
- liftIO $ slog host "shared key not established"
+ slog "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 <> "\""
+ slog $ "decrypted ciphertext: \"" <> cod <> "\""
let hourOfDestiny = case B8.findIndex C.isDigit msg of
Nothing -> error "did i fat-finger a digit?"
@@ -151,87 +207,163 @@ dheval host = \case
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
+ slog $ "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
+ slog $ "received ciphertext " <> cod
case dhKey of
Nothing -> do
- liftIO $ slog host "shared key not established"
+ slog "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 <> "\""
+ slog $ "decrypted ciphertext: \"" <> cod <> "\""
pure Nothing
-- man-in-the-middle protocol eval
mitmeval
- :: T.Text
- -> Command
+ :: Command
-> StateT Sesh IO (Maybe Command)
-mitmeval host = \case
+mitmeval = \case
SendParams grp pk -> do
sesh@Sesh {..} <- S.get
- liftIO $ slog host "reCEiVed GRoUp pArAmeTErs And pUBliC kEy"
+ slog "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"
+ slog "sEnDinG BOguS paRaMeTeRs"
pure $ Just (SendParams grp p)
SendPublic pk -> do
- liftIO $ slog host "REceIvED pUBlic keY"
- liftIO $ slog host "seNDINg boGus kEy"
+ slog "REceIvED pUBlic keY"
+ slog "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
+ 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
- liftIO $ slog host $ "DEcRyptEd cIPheRTeXt: \"" <> cod <> "\""
- liftIO $ slog host $ "reLayINg cIpheRtExt"
+ slog $ "DEcRyptEd cIPheRTeXt: \"" <> cod <> "\""
+ slog "reLayINg cIpheRtExt"
pure $ Just (SendMessage cip)
SendTerminal cip -> do
sesh@Sesh {..} <- S.get
let cod = B64.encodeBase64 cip
- liftIO $ slog host $ "reCeiVeD CipHeRtExt " <> cod
+ 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
- liftIO $ slog host $ "DeCrYpteD cIphErteXt: \"" <> cod <> "\""
- liftIO $ slog host $ "ReLaYINg CiPHeRTexT"
+ slog $ "DeCrYpteD cIphErteXt: \"" <> cod <> "\""
+ slog "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
+-- negotiated-group protocol eval
+ngeval
+ :: Command
+ -> 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"
+ pure (Just AckGroup)
--- 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
+ AckGroup -> do
+ 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)
+
+ SendParams grp pk -> do
+ slog "not expecting group parameters and public key"
+ pure Nothing
+
+ SendPublic pk -> do
+ sesh@Sesh {..} <- S.get
+ slog "received public key"
+ case dhGroup 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)
+
+ 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)
+
+ SendTerminal 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 <> "\""
+ pure Nothing
