commit fc3a9295ef7e0876407a89fb9019cb6c4166d4c1
parent 4ab6c492675ae8cadd151004cd1e51e07d7f89c2
Author: Jared Tobin <jared@jtobin.io>
Date: Sun, 13 Aug 2023 20:36:51 -0230
Moar fun for 5.33.
Diffstat:
5 files changed, 304 insertions(+), 48 deletions(-)
diff --git a/.ghci b/.ghci
@@ -1,5 +1,6 @@
:set prompt "> "
:set -XOverloadedStrings
+import qualified Data.Binary as DB
import qualified Data.Binary.Get as BG
import qualified Data.Binary.Put as BP
import qualified Data.Bits as B
diff --git a/cryptopals.cabal b/cryptopals.cabal
@@ -34,6 +34,7 @@ library
, Cryptopals.Util
, Cryptopals.Util.ByteString
, Cryptopals.Util.Similarity
+ , Pipes.Network
build-depends:
base
, base16
@@ -44,6 +45,11 @@ library
, cryptonite
, HTTP
, mwc-random
+ , network
+ , network-simple
+ , pipes
+ , pipes-binary
+ , pipes-parse
, primitive
, text
, time
diff --git a/docs/s5.md b/docs/s5.md
@@ -1,13 +1,13 @@
#### 5.33
The basic Diffie-Hellman algorithm for key exchange between Alice and
-Bob goes as follows. Alice and Bob agree on a cyclic group of some
-particular order to use. They each randomly and independently pick some
-number of times to perform the group operation (which must be less than
-the order of the group) and perform the group operation on the generator
-that number of times, publishing their results. For generator g, Alice's
-number x, and Bob's number y: Alice publishes g ^ x, and Bob publishes g
-^ y.
+Bob goes as follows. Alice and Bob agree on a finite cyclic group of
+some particular order to use. They each randomly and independently pick
+some number of times to perform the group operation (which must be
+greater than zero, and less than the order of the group) and perform the
+group operation on the generator that number of times, publishing their
+results. For generator g, Alice's number x, and Bob's number y: Alice
+publishes g ^ x, and Bob publishes g ^ y.
Each then performs his or her own secret number of additional group
operations on the other's public result, establishing the key g ^ xy.
@@ -22,8 +22,8 @@ group, i.e. the multiplicative group of 16-bit words modulo 37:
> gen <- MWC.create
> let p = 37
> let g = 5
- > a <- fmap (`mod` p) (MWC.uniform gen) :: IO Word16
- > b <- fmap (`mod` p) (MWC.uniform gen) :: IO Word16
+ > a <- fmap (`mod` p) (MWC.uniformR (1, p - 1) gen) :: IO Word16
+ > b <- fmap (`mod` p) (MWC.uniformR (1, p - 1) gen) :: IO Word16
> let bigA = g ^ a `mod` p
> let bigB = g ^ b `mod` p
> let s = bigB ^ a `mod` p
@@ -49,8 +49,8 @@ range. First a modular exponentiation routine:
and given that (and appropriate p, g), the key exchange:
> gen <- MWC.create
- > a <- fmap (`mod` p) (MWC.uniformRM (0, p - 1) gen)
- > b <- fmap (`mod` p) (MWC.uniformRM (0, p - 1) gen)
+ > a <- fmap (`mod` p) (MWC.uniformRM (1, p - 1) gen)
+ > b <- fmap (`mod` p) (MWC.uniformRM (1, p - 1) gen)
> let bigA = modexp g a p
> let bigB = modexp g b p
> let s = modexp bigB a p
@@ -58,23 +58,29 @@ and given that (and appropriate p, g), the key exchange:
> s == t
True
-Our SHA1 function needs a bytestring to operate on, so to hash the
-Natural key we need a quick serialization routine from Naturals
-to ByteString. I happened to write one of these a few years ago
-for [urbit-hob](http://git.jtobin.io/urbit-hob); it serializes in
-little-endian format, and here we'll use a lazy bytestring:
+That's all well and good, but let's have a bit of fun.
- unroll :: Natural -> BL.ByteString
- unroll nat = case nat of
- 0 -> BL.singleton 0
- _ -> BL.pack (L.unfoldr step nat)
- where
- step 0 = Nothing
- step i = Just (fromIntegral i, i `B.shiftR` 8)
+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.
-so we can get a key via:
+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 illustration:
- > let k = S.sha1 $ unroll s
- > k
- 6a86b02347be741dfb6f876819022ae1d7adda18
+ (cryptopals) bob: listening..
+ (cryptopals) alice: session established
+ (cryptopals) alice: sending group parameters and public key
+ (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) bob: decrypted ciphertext: "attack at 10pm"
+ (cryptopals) bob: replying with ciphertext
+ (cryptopals) alice: received ciphertext
+ (cryptopals) alice: decrypted ciphertext: "confirmed, attacking at 10pm"
+ (cryptopals) bob: ending session
diff --git a/lib/Cryptopals/DH.hs b/lib/Cryptopals/DH.hs
@@ -1,25 +1,83 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RecordWildCards #-}
module Cryptopals.DH (
p
, g
, modexp
-
- , unroll
- , roll
) where
+import Control.Concurrent (threadDelay)
+import Control.Monad
import Control.Monad.Primitive
-import qualified Control.Monad.Trans.Reader as R
-import qualified Cryptopals.Digest.Pure.SHA as S
+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 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 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
-import GHC.Word (Word16)
+
+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
+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
@@ -29,22 +87,161 @@ modexp b e m
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
--- little-endian natural serialization
-unroll :: Natural -> BL.ByteString
-unroll nat = case nat of
- 0 -> BL.singleton 0
- _ -> BL.pack (L.unfoldr step nat)
- where
- step 0 = Nothing
- step i = Just (fromIntegral i, i `B.shiftR` 8)
+-- 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
-roll :: BL.ByteString -> Natural
-roll = foldr unstep 0 . BL.unpack where
- unstep b a = a `B.shiftL` 8 .|. fromIntegral b
+-- 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)
-p :: Natural
-p = 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7edee386bfb5a899fa5ae9f24117c4b1fe649286651ece45b3dc2007cb8a163bf0598da48361c55d39a69163fa8fd24cf5f83655d23dca3ad961c62f356208552bb9ed529077096966d670c354e4abc9804f1746c08ca237327ffffffffffffffff
+-- session log
+slog :: T.Text -> T.Text -> IO ()
+slog host msg = TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg
-g :: Natural
-g = 2
+-- session eval
+seval :: T.Text -> Maybe Command -> StateT Sesh IO (Maybe Command)
+seval host = \case
+ Nothing -> liftIO $ do
+ slog host "ending session"
+ SE.exitSuccess
+ Just cmd -> do
+ liftIO $ threadDelay 1000000
+ dheval host cmd
+
+-- diffie-hellman 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 $ 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 $ 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
+
+-- await key exchange
+bob :: MonadIO m => PN.ServiceName -> m a
+bob port = PN.serve "localhost" port $ \(sock, _) -> do
+ let sesh = Sesh {
+ dhGroup = Nothing
+ , dhKeys = Nothing
+ , dhKey = Nothing
+ , dhGen = MWC.createSystemRandom
+ }
+ slog "bob" $ "listening.."
+ void $ S.runStateT (runEffect (handle "bob" sock)) sesh
+
+-- initiate key exchange
+alice :: PN.ServiceName -> IO ()
+alice port = PN.connect "localhost" port $ \(sock, _) -> do
+ slog "alice" $ "session established"
+
+ let grp = Group p g
+ gen <- MWC.createSystemRandom
+ per@Keys {..} <- genpair grp gen
+ slog "alice" $ "sending group parameters and public key"
+ runEffect $ do
+ PB.encode (Just (SendParams grp pub))
+ >-> PN.toSocket sock
+
+ let sesh = Sesh {
+ dhGroup = Just grp
+ , dhKeys = Just per
+ , 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
diff --git a/lib/Pipes/Network.hs b/lib/Pipes/Network.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE RankNTypes #-}
+
+module Pipes.Network (
+ N.Socket(..)
+ , N.SockAddr(..)
+ , NT.HostPreference(..)
+ , N.ServiceName
+
+ , fromSocket
+ , toSocket
+
+ , NT.connect
+ , NT.serve
+ , NT.send
+ , NT.recv
+ , NT.closeSock
+ ) where
+
+import Control.Monad.IO.Class
+import qualified Data.ByteString as BS
+import qualified Pipes as P
+import qualified Network.Simple.TCP as NT
+import qualified Network.Socket as N
+import qualified Network.Socket.ByteString as NB
+import GHC.Word (Word32)
+
+fromSocket
+ :: MonadIO m
+ => N.Socket
+ -> Word32
+ -> P.Producer' BS.ByteString m ()
+fromSocket s n = loop where
+ loop = do
+ b <- liftIO (NB.recv s (fromIntegral n))
+ if BS.null b
+ then pure ()
+ else do
+ P.yield b
+ loop
+
+toSocket
+ :: MonadIO m
+ => N.Socket
+ -> P.Consumer' BS.ByteString m r
+toSocket s = P.for P.cat (NT.send s)
+
