commit 96facaa3b06e241027cb237adfccfebf8515492c
parent 68413610696fcf046bb1ca04491c6d130f8fe7ce
Author: Jared Tobin <jared@jtobin.io>
Date: Wed, 16 Aug 2023 15:27:18 -0230
Add 5.36, plus some refactoring.
Diffstat:
7 files changed, 335 insertions(+), 60 deletions(-)
diff --git a/cryptopals.cabal b/cryptopals.cabal
@@ -30,6 +30,7 @@ library
, Cryptopals.Digest.Pure.SHA
, Cryptopals.MAC
, Cryptopals.MAC.Attacks
+ , Cryptopals.SRP
, Cryptopals.Stream.Attacks
, Cryptopals.Stream.RNG
, Cryptopals.Stream.RNG.MT19937
diff --git a/docs/s5.md b/docs/s5.md
@@ -252,3 +252,24 @@ e.g. the `dhngmitm 1`, `dhngmitm p`, or `dhngmitm (p - 1)` protocol:
(cryptopals) alice: decrypted ciphertext: "confirmed, attacking at 10pm"
(cryptopals) mallory: ending session
+#### 5.36
+
+SRP (Secure Remote Password) is an authentication protocol for which
+a client authenticates with a server via a zero-knowledge proof.
+Cryptopals.SRP implements it much in the same way that Cryptopals.DH
+implements Diffie-Hellman; here one can perform the protocol via the
+'server' and 'client' functions analogously:
+
+Interleaved logs for 'server "3000" srp' and 'client "3000" srp auth':
+
+ (cryptopals) server: listening..
+ (cryptopals) client: session established
+ (cryptopals) client: sending authentication request
+ (cryptopals) server: received authentication request for l33th4x0r@hotmail.com
+ (cryptopals) server: acking authentication request for l33th4x0r@hotmail.com
+ (cryptopals) client: received authentication request ack
+ (cryptopals) client: sending MAC 6p7eE/pTSijdReePtswOKDZZUFYhLkJfeKps0GD4Yc4=
+ (cryptopals) server: received MAC 6p7eE/pTSijdReePtswOKDZZUFYhLkJfeKps0GD4Yc4=
+ (cryptopals) server: OK
+ (cryptopals) client: ending session
+
diff --git a/lib/Cryptopals/DH.hs b/lib/Cryptopals/DH.hs
@@ -4,6 +4,7 @@ module Cryptopals.DH (
p
, g
, modexp
+ , encodekey
) where
import Control.Monad.Primitive
@@ -25,19 +26,19 @@ import qualified System.Random.MWC as MWC
bob
:: (DB.Binary b, DB.Binary c)
=> PN.ServiceName
- -> Protocol (StateT Sesh IO) b c
+ -> PN.Protocol (StateT Sesh IO) b c
-> IO ()
bob port eval = PN.serve "localhost" port $ \(sock, _) -> do
let host = "bob"
sesh = open sock host
blog host "listening.."
- void $ S.evalStateT (runEffect (session sock eval)) sesh
+ void $ S.evalStateT (runEffect (PN.session sock eval)) sesh
-- initiate key exchange
alice
:: (DB.Binary b, DB.Binary c)
=> PN.ServiceName
- -> Protocol (StateT Sesh IO) b c
+ -> PN.Protocol (StateT Sesh IO) b c
-> StateT Sesh IO Command
-> IO ()
alice port eval knit = PN.connect "localhost" port $ \(sock, _) -> do
@@ -51,14 +52,14 @@ alice port eval knit = PN.connect "localhost" port $ \(sock, _) -> do
PB.encode (Just cmd)
>-> PN.toSocket sock
- void $ S.runStateT (runEffect (session sock eval)) nex
+ void $ S.runStateT (runEffect (PN.session sock eval)) nex
-- await key exchange
mallory
:: (DB.Binary b, DB.Binary c)
=> PN.ServiceName
-> PN.ServiceName
- -> Protocol (StateT Sesh IO) b c
+ -> PN.Protocol (StateT Sesh IO) b c
-> IO ()
mallory port bport eval = do
let host = "mallory"
@@ -67,7 +68,7 @@ mallory port bport eval = do
blog host "LiSteNIng.."
PN.connect "localhost" bport $ \(bsock, _) -> do
blog host "eStabLisHed MiTm coNNecTion"
- void $ S.runStateT (runEffect (dance asock bsock eval)) sesh
+ void $ S.runStateT (runEffect (PN.dance asock bsock eval)) sesh
-- initialize session with basic stuff
open :: PN.Socket -> T.Text -> Sesh
diff --git a/lib/Cryptopals/DH/Core.hs b/lib/Cryptopals/DH/Core.hs
@@ -8,6 +8,7 @@ module Cryptopals.DH.Core (
, Keys(..)
, modexp
+
, genpair
, derivekey
, encodekey
@@ -72,4 +73,3 @@ encodekey =
. CS.sha1
. DB.encode
-
diff --git a/lib/Cryptopals/DH/Session.hs b/lib/Cryptopals/DH/Session.hs
@@ -6,9 +6,7 @@ module Cryptopals.DH.Session (
, genGroup
, genKeypair
-
, Sesh(..)
- , Protocol
, blog
, slog
@@ -18,9 +16,6 @@ module Cryptopals.DH.Session (
, dhmitm
, dhngmitm
-
- , session
- , dance
) where
import Control.Concurrent (threadDelay)
@@ -65,8 +60,6 @@ data Command =
instance DB.Binary Command
-type Protocol m b c = b -> m c
-
-- session state
data Sesh = Sesh {
dhGroup :: Maybe Group
@@ -92,37 +85,6 @@ slog msg = do
suspense :: IO ()
suspense = threadDelay 1000000
--- basic TCP coordination
-session
- :: (MonadIO m, DB.Binary b, DB.Binary c)
- => PN.Socket
- -> Protocol 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
- -> Protocol 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
seval
:: (Command -> StateT Sesh IO a)
@@ -137,19 +99,21 @@ seval cont = \case
cont cmd
-- basic dh evaluation
-dh :: Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command)
+dh :: PN.Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command)
dh = seval dheval
-- mitm dh evaluation
-dhmitm :: Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command)
+dhmitm :: PN.Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command)
dhmitm = seval mitmeval
-- negotiated-group dh evaluation
-dhng :: Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command)
+dhng :: PN.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
+ :: Natural
+ -> PN.Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command)
dhngmitm = seval . malgeval
-- diffie-hellman protocol eval
diff --git a/lib/Cryptopals/SRP.hs b/lib/Cryptopals/SRP.hs
@@ -0,0 +1,250 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Cryptopals.SRP where
+
+import Control.Concurrent (threadDelay)
+import Control.Monad
+import Control.Monad.Primitive
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State
+import qualified Cryptopals.Digest.Pure.SHA as CS
+import qualified Cryptopals.DH as DH (modexp)
+import qualified Data.Binary as DB
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Lazy as BL
+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 (Word64)
+import Numeric.Natural
+import Pipes
+import qualified Pipes.Binary as PB
+import qualified Pipes.Network as PN
+import qualified System.Exit as SE
+import qualified System.Random.MWC as MWC
+
+-- common parameters
+data Env = Env {
+ en :: Natural
+ , eg :: Natural
+ , ek :: Natural
+ , ei :: BS.ByteString
+ , ep :: BS.ByteString
+ } deriving (Eq, Show, Generic)
+
+defaultEnv :: Env
+defaultEnv = Env {
+ en = p192
+ , eg = 2
+ , ek = 3
+ , ei = "l33th4x0r@hotmail.com"
+ , ep = "hunter2"
+ }
+
+instance DB.Binary Env
+
+data Command =
+ Auth BS.ByteString Natural
+ | AckAuth BS.ByteString Natural
+ | SendMAC BS.ByteString
+ | End
+ deriving (Eq, Show, Generic)
+
+instance DB.Binary Command
+
+-- generic state
+data Sesh = Sesh {
+ shost :: T.Text
+ , ssalt :: Maybe BS.ByteString
+ , skey :: Natural
+ , sourpub :: Natural
+ , sherpub :: Maybe Natural
+ , sv :: Maybe Natural
+ , sgen :: IO (MWC.Gen RealWorld)
+ }
+
+type SRP m = StateT Sesh (ReaderT Env m)
+
+server
+ :: (DB.Binary b, DB.Binary c)
+ => PN.ServiceName
+ -> PN.Protocol (SRP IO) b c
+ -> IO ()
+server port eval = PN.serve "localhost" port $ \(sock, _) -> do
+ sesh <- initServer defaultEnv
+ blog "server" "listening.."
+ let saction = runEffect (PN.session sock eval)
+ void $ runReaderT (evalStateT saction sesh) defaultEnv
+
+client
+ :: (DB.Binary b, DB.Binary c)
+ => PN.ServiceName
+ -> PN.Protocol (SRP IO) b c
+ -> SRP IO Command
+ -> IO ()
+client port eval knit = PN.connect "localhost" port $ \(sock, _) -> do
+ sesh <- initClient defaultEnv
+ blog "client" "session established"
+
+ (cmd, nex) <- runReaderT (runStateT knit sesh) defaultEnv
+
+ runEffect $
+ PB.encode cmd
+ >-> PN.toSocket sock
+
+ let saction = runEffect (PN.session sock eval)
+ void $ runReaderT (runStateT saction nex) defaultEnv
+
+auth :: SRP IO Command
+auth = do
+ Env {..} <- lift ask
+ pub <- gets sourpub
+ slog "sending authentication request"
+ pure (Auth ei pub)
+
+-- basic log
+blog :: T.Text -> T.Text -> IO ()
+blog host msg = do
+ TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg
+ suspense
+
+-- session log
+slog :: MonadIO m => T.Text -> StateT Sesh m ()
+slog msg = do
+ host <- gets shost
+ liftIO . TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg
+ liftIO suspense
+
+-- dramatic effect
+suspense :: IO ()
+suspense = threadDelay 1000000
+
+-- 2 ^ 192 - 2 ^ 64 - 1
+p192 :: Natural
+p192 = 6277101735386680763835789423207666416083908700390324961279
+
+initServer :: Env -> IO Sesh
+initServer Env {..} = do
+ gen <- MWC.createSystemRandom
+ skey <- MWC.uniformRM (1, en - 1) gen
+ salt <- fmap DB.encode (MWC.uniform gen :: IO Word64)
+ let xH = CS.sha256 (salt <> BL.fromStrict ep)
+ x = fromIntegral (CS.integerDigest xH)
+ v = DH.modexp eg x en
+ strsalt = BL.toStrict salt
+ sourpub = ek * v + DH.modexp eg skey en
+ pure Sesh {
+ sgen = pure gen
+ , ssalt = pure strsalt
+ , sv = pure v
+ , sherpub = Nothing
+ , shost = "server"
+ , ..
+ }
+
+initClient :: Env -> IO Sesh
+initClient Env {..} = do
+ gen <- MWC.createSystemRandom
+ skey <- MWC.uniformRM (1, en - 1) gen
+ let sourpub = DH.modexp eg skey en
+ pure Sesh {
+ sgen = pure gen
+ , sherpub = Nothing
+ , ssalt = Nothing
+ , sv = Nothing
+ , shost = "client"
+ , ..
+ }
+
+-- secure remote password protocol
+srp :: MonadIO m => PN.Protocol (SRP m) Command Command
+srp cmd = do
+ Env {..} <- lift ask
+ case cmd of
+ Auth i herpub -> do
+ let li = TE.decodeLatin1 i
+ slog $ "received authentication request for " <> li
+ if i /= ei
+ then do
+ slog $ "unknown user " <> li
+ pure End
+ else do
+ sesh@Sesh {..} <- get
+ put sesh {
+ sherpub = Just herpub
+ }
+ case ssalt of
+ Nothing -> do
+ slog "missing required parameters"
+ pure End
+ Just salt -> do
+ slog $ "acking authentication request for " <> li
+ pure (AckAuth salt sourpub)
+
+ AckAuth salt herpub -> do
+ slog "received authentication request ack"
+ sesh@Sesh {..} <- get
+ put sesh {
+ ssalt = Just salt
+ , sherpub = Just herpub
+ }
+ let u = hashpubs sourpub herpub
+ x = fromIntegral
+ . CS.integerDigest
+ . CS.sha256
+ $ BL.fromStrict (salt <> ep)
+ s = DH.modexp
+ (herpub - ek * DH.modexp eg x en)
+ (skey + u * x)
+ en
+ k = CS.bytestringDigest
+ . CS.sha256
+ . DB.encode
+ $ s
+ let mac = BL.toStrict
+ . CS.bytestringDigest
+ $ CS.hmacSha256 k (BL.fromStrict salt)
+ slog $ "sending MAC " <> B64.encodeBase64 mac
+ pure (SendMAC mac)
+
+ SendMAC mac -> do
+ slog $ "received MAC " <> B64.encodeBase64 mac
+ sesh@Sesh {..} <- get
+ case (,,) <$> ssalt <*> sv <*> sherpub of
+ Nothing -> do
+ slog "missing required parameters"
+ pure End
+ Just (salt, v, herpub) -> do
+ let u = hashpubs herpub sourpub
+ s = DH.modexp (herpub * DH.modexp v u en) skey en
+ k = CS.bytestringDigest
+ . CS.sha256
+ . DB.encode
+ $ s
+ hmac = BL.toStrict
+ . CS.bytestringDigest
+ $ CS.hmacSha256 k (BL.fromStrict salt)
+ if hmac == mac
+ then do
+ slog "OK"
+ pure End
+ else do
+ slog "couldn't verify MAC"
+ pure End
+
+ End -> do
+ slog "ending session"
+ liftIO SE.exitSuccess -- XX close the socket
+
+hashpubs :: Natural -> Natural -> Natural
+hashpubs a b =
+ fromIntegral
+ . CS.integerDigest
+ . CS.sha256
+ $ DB.encode a <> DB.encode b
+
diff --git a/lib/Pipes/Network.hs b/lib/Pipes/Network.hs
@@ -5,11 +5,12 @@ module Pipes.Network (
, N.SockAddr(..)
, NT.HostPreference(..)
, N.ServiceName
+ , Protocol
, fromSocket
, toSocket
- , rhumba
- , foxtrot
+ , session
+ , dance
, NT.connect
, NT.serve
@@ -19,34 +20,40 @@ module Pipes.Network (
) where
import Control.Monad.IO.Class
+import qualified Data.Binary as DB
import qualified Data.ByteString as BS
-import qualified Pipes as P
+import Pipes
+import qualified Pipes.Binary as PB
+import qualified Pipes.Parse as PP
+import qualified Pipes.Prelude 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)
+type Protocol m b c = b -> m c
+
-- receive on socket
fromSocket
:: MonadIO m
=> N.Socket
-> Word32
- -> P.Producer' BS.ByteString m ()
+ -> 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
+ 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)
+ -> Consumer' BS.ByteString m r
+toSocket s = for cat (NT.send s)
-- receive on alternate sockets
rhumba
@@ -54,7 +61,7 @@ rhumba
=> N.Socket
-> N.Socket
-> Word32
- -> P.Producer' BS.ByteString m ()
+ -> Producer' BS.ByteString m ()
rhumba a b n = loop True where
loop lip = do
let s = if lip then a else b
@@ -62,7 +69,7 @@ rhumba a b n = loop True where
if BS.null b
then pure ()
else do
- P.yield b
+ yield b
loop (not lip)
-- send on alternate sockets
@@ -70,11 +77,42 @@ foxtrot
:: MonadIO m
=> N.Socket
-> N.Socket
- -> P.Consumer BS.ByteString m b
+ -> Consumer BS.ByteString m b
foxtrot asock bsock = loop True where
loop lip = do
- b <- P.await
+ b <- await
let s = if lip then asock else bsock
liftIO $ NT.send s b
loop (not lip)
+-- basic TCP coordination
+session
+ :: (MonadIO m, DB.Binary b, DB.Binary c)
+ => N.Socket
+ -> Protocol 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 = fromSocket sock 4096
+ deco = PP.parsed PB.decode recv
+ send = toSocket sock
+
+-- MITM TCP coordination
+dance
+ :: (MonadIO m, DB.Binary b, DB.Binary c)
+ => N.Socket
+ -> N.Socket
+ -> Protocol 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
+ >-> foxtrot bsock asock
+ where
+ recv = rhumba asock bsock 4096
+
