Simple.hs (9707B)
1 module Cryptopals.SRP.Simple where 2 3 import Control.Concurrent (threadDelay) 4 import Control.Monad 5 import Control.Monad.Primitive 6 import Control.Monad.IO.Class 7 import Control.Monad.Trans.Class 8 import Control.Monad.Trans.Reader 9 import Control.Monad.Trans.State 10 import qualified Cryptopals.Digest.Pure.SHA as CS 11 import qualified Cryptopals.DH as DH (modexp) 12 import qualified Data.Binary as DB 13 import qualified Data.Bits as B 14 import qualified Data.ByteString as BS 15 import qualified Data.ByteString.Base16 as B16 16 import qualified Data.ByteString.Lazy as BL 17 import qualified Data.ByteString.Lazy.Char8 as BL8 18 import qualified Data.Text as T 19 import qualified Data.Text.Encoding as TE 20 import qualified Data.Text.IO as TIO 21 import GHC.Generics (Generic) 22 import GHC.Word (Word64) 23 import Numeric.Natural 24 import Pipes 25 import qualified Pipes.Binary as PB 26 import qualified Pipes.Network as PN 27 import qualified System.Exit as SE 28 import qualified System.Random.MWC as MWC 29 30 data Word128 = Word128 !Word64 !Word64 31 deriving (Eq, Show, Generic) 32 33 instance DB.Binary Word128 34 35 genWord128 :: PrimMonad m => MWC.Gen (PrimState m) -> m Word128 36 genWord128 gen = Word128 <$> MWC.uniform gen <*> MWC.uniform gen 37 38 word128toNat :: Word128 -> Natural 39 word128toNat w = foldr alg 0 . BS.unpack . BL.toStrict $ bs where 40 bs = DB.encode w 41 alg b a = a `B.shiftL` 8 B..|. fromIntegral b 42 43 -- common parameters 44 data Env = Env { 45 en :: Natural 46 , eg :: Natural 47 , ek :: Natural 48 , ei :: BS.ByteString 49 , ep :: BS.ByteString 50 } deriving (Eq, Show, Generic) 51 52 defaultEnv :: Env 53 defaultEnv = Env { 54 en = p192 55 , eg = 2 56 , ek = 3 57 , ei = "l33th4x0r@hotmail.com" 58 , ep = "hunter2" 59 } 60 61 genPassword :: MWC.Gen RealWorld -> IO BS.ByteString 62 genPassword gen = do 63 idx <- MWC.uniformR (0, 235885) gen 64 dict <- BL8.readFile "/usr/share/dict/words" 65 let ls = BL8.lines dict 66 pure . BL.toStrict $ ls !! idx 67 68 initEnv :: MWC.Gen RealWorld -> IO Env 69 initEnv gen = do 70 ep <- genPassword gen 71 pure Env { 72 en = p192 73 , eg = 2 74 , ek = 3 75 , ei = "l33th4x0r@hotmail.com" 76 , .. 77 } 78 79 instance DB.Binary Env 80 81 data Command = 82 Auth BS.ByteString Natural 83 | AckAuth BS.ByteString Natural Natural 84 | SendMAC BS.ByteString 85 | End 86 deriving (Eq, Show, Generic) 87 88 instance DB.Binary Command 89 90 -- generic state 91 data Sesh = Sesh { 92 shost :: T.Text 93 , ssalt :: Maybe BS.ByteString 94 , skey :: Natural 95 , sourpub :: Natural 96 , sherpub :: Maybe Natural 97 , sv :: Maybe Natural 98 , su :: Maybe Natural 99 , sgen :: IO (MWC.Gen RealWorld) 100 } 101 102 instance Show Sesh where 103 show Sesh {..} = mconcat [ 104 "Sesh {\n" 105 , " shost = " <> show shost <> "\n" 106 , " ssalt = " <> show ssalt <> "\n" 107 , " skey = " <> show skey <> "\n" 108 , " sourpub = " <> show sourpub <> "\n" 109 , " sherpub = " <> show sherpub <> "\n" 110 , " sv = " <> show sv <> "\n" 111 , " su = " <> show su <> "\n" 112 , " sgen = <MWC.Gen>\n" 113 , "}" 114 ] 115 116 type SRP m = StateT Sesh (ReaderT Env m) 117 118 server 119 :: (DB.Binary b, DB.Binary c) 120 => PN.ServiceName 121 -> PN.Protocol (SRP IO) b c 122 -> IO () 123 server port eval = PN.serve "localhost" port $ \(sock, _) -> do 124 gen <- MWC.createSystemRandom 125 env <- initEnv gen 126 sesh <- initServer env gen 127 blog "server" "listening.." 128 let saction = runEffect (PN.session sock eval) 129 void $ runReaderT (evalStateT saction sesh) defaultEnv 130 131 mallory 132 :: (DB.Binary b, DB.Binary c) 133 => PN.ServiceName 134 -> PN.Protocol (SRP IO) b c 135 -> IO () 136 mallory port eval = PN.serve "localhost" port $ \(sock, _) -> do 137 gen <- MWC.createSystemRandom 138 env <- initEnv gen 139 sesh <- initMallory env gen 140 blog "mallory" "LiSteNiNG.." 141 let saction = runEffect (PN.session sock eval) 142 void $ runReaderT (evalStateT saction sesh) defaultEnv 143 144 client 145 :: (DB.Binary b, DB.Binary c) 146 => PN.ServiceName 147 -> PN.Protocol (SRP IO) b c 148 -> SRP IO Command 149 -> IO () 150 client port eval knit = PN.connect "localhost" port $ \(sock, _) -> do 151 gen <- MWC.createSystemRandom 152 env <- initEnv gen 153 sesh <- initClient defaultEnv gen 154 blog "client" "session established" 155 156 (cmd, nex) <- runReaderT (runStateT knit sesh) defaultEnv 157 158 runEffect $ 159 PB.encode cmd 160 >-> PN.toSocket sock 161 162 let saction = runEffect (PN.session sock eval) 163 void $ runReaderT (runStateT saction nex) defaultEnv 164 165 auth :: SRP IO Command 166 auth = do 167 Env {..} <- lift ask 168 pub <- gets sourpub 169 slog "sending authentication request" 170 pure (Auth ei pub) 171 172 -- basic log 173 blog :: T.Text -> T.Text -> IO () 174 blog host msg = do 175 TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg 176 suspense 177 178 -- session log 179 slog :: MonadIO m => T.Text -> StateT Sesh m () 180 slog msg = do 181 host <- gets shost 182 liftIO . TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg 183 liftIO suspense 184 185 -- dramatic effect 186 suspense :: IO () 187 suspense = threadDelay 1000000 188 189 -- 2 ^ 192 - 2 ^ 64 - 1 190 p192 :: Natural 191 p192 = 6277101735386680763835789423207666416083908700390324961279 192 193 initServer :: Env -> MWC.Gen RealWorld -> IO Sesh 194 initServer Env {..} gen = do 195 skey <- MWC.uniformRM (1, en - 1) gen 196 u <- word128toNat <$> genWord128 gen 197 salt <- DB.encode <$> (MWC.uniform gen :: IO Word64) 198 let xH = CS.sha256 (salt <> BL.fromStrict ep) 199 x = fromIntegral (CS.integerDigest xH) 200 v = DH.modexp eg x en 201 strsalt = BL.toStrict salt 202 sourpub = DH.modexp eg skey en 203 pure Sesh { 204 sgen = pure gen 205 , ssalt = pure strsalt 206 , sv = pure v 207 , su = pure u 208 , sherpub = Nothing 209 , shost = "server" 210 , .. 211 } 212 213 initMallory :: Env -> MWC.Gen RealWorld -> IO Sesh 214 initMallory Env {..} gen = do 215 let skey = 1 216 u = 1 217 sourpub = 2 218 pure Sesh { 219 sgen = pure gen 220 , ssalt = pure mempty 221 , sv = Nothing 222 , su = pure u 223 , sherpub = Nothing 224 , shost = "mallory" 225 , .. 226 } 227 228 initClient :: Env -> MWC.Gen RealWorld -> IO Sesh 229 initClient Env {..} gen = do 230 skey <- MWC.uniformRM (1, en - 1) gen 231 let sourpub = DH.modexp eg skey en 232 pure Sesh { 233 sgen = pure gen 234 , sherpub = Nothing 235 , ssalt = Nothing 236 , sv = Nothing 237 , su = Nothing 238 , shost = "client" 239 , .. 240 } 241 242 -- simple secure remote password protocol 243 srpsimple :: MonadIO m => PN.Protocol (SRP m) Command Command 244 srpsimple cmd = do 245 Env {..} <- lift ask 246 case cmd of 247 Auth i herpub -> do 248 let li = TE.decodeLatin1 i 249 slog $ "received authentication request for " <> li 250 if i /= ei 251 then do 252 slog $ "unknown user " <> li 253 pure End 254 else do 255 sesh@Sesh {..} <- get 256 put sesh { 257 sherpub = Just herpub 258 } 259 case (,) <$> ssalt <*> su of 260 Nothing -> do 261 slog "missing required parameters" 262 pure End 263 Just (salt, u) -> do 264 slog $ "acking authentication request for " <> li 265 pure (AckAuth salt sourpub u) 266 267 AckAuth salt herpub u -> do 268 slog "received authentication request ack" 269 sesh@Sesh {..} <- get 270 put sesh { 271 ssalt = Just salt 272 , sherpub = Just herpub 273 , su = Just u 274 } 275 let x = fromIntegral 276 . CS.integerDigest 277 . CS.sha256 278 $ BL.fromStrict (salt <> ep) 279 s = DH.modexp herpub (skey + u * x) en 280 k = CS.bytestringDigest 281 . CS.sha256 282 . DB.encode 283 $ s 284 let mac = BL.toStrict 285 . CS.bytestringDigest 286 $ CS.hmacSha256 k (BL.fromStrict salt) 287 slog $ "sending MAC " <> B16.encodeBase16 mac 288 pure (SendMAC mac) 289 290 SendMAC mac -> do 291 slog $ "received MAC " <> B16.encodeBase16 mac 292 sesh@Sesh {..} <- get 293 case (,,,) <$> ssalt <*> sv <*> sherpub <*> su of 294 Nothing -> do 295 slog "missing required parameters" 296 pure End 297 Just (salt, v, herpub, u) -> do 298 let s = DH.modexp (herpub * DH.modexp v u en) skey en 299 k = CS.bytestringDigest 300 . CS.sha256 301 . DB.encode 302 $ s 303 hmac = BL.toStrict 304 . CS.bytestringDigest 305 $ CS.hmacSha256 k (BL.fromStrict salt) 306 if hmac == mac 307 then do 308 slog "OK" 309 pure End 310 else do 311 slog "couldn't verify MAC" 312 pure End 313 314 End -> do 315 slog "ending session" 316 liftIO SE.exitSuccess -- XX close the socket 317 318 -- MITM on simple secure remote password protocol 319 mitm :: MonadIO m => PN.Protocol (SRP m) Command Command 320 mitm cmd = do 321 Env {..} <- lift ask 322 case cmd of 323 Auth i herpub -> do 324 let li = TE.decodeLatin1 i 325 slog $ "rECeIvEd aUTheNtICaTioN ReQUesT fOr " <> li 326 slog $ "wiTh PuBLiC kEy " <> (T.pack . show) herpub 327 if i /= ei 328 then do 329 slog $ "unknown user " <> li 330 pure End 331 else do 332 sesh@Sesh {..} <- get 333 put sesh { 334 sherpub = Just herpub 335 } 336 case (,) <$> ssalt <*> su of 337 Nothing -> do 338 slog "missing required parameters" 339 pure End 340 Just (salt, u) -> do 341 slog $ "aCKiNg AuTheNTicAtIon ReQueST FOr " <> li 342 pure (AckAuth salt sourpub u) 343 344 SendMAC mac -> do 345 slog $ "rECeIvEd MAC " <> B16.encodeBase16 mac 346 sesh@Sesh {..} <- get 347 348 case sherpub of 349 Nothing -> do 350 slog "missing required parameters" 351 pure End 352 Just (T.pack . show -> herpub) -> do 353 slog $ "USiNg PaRaMeTeRs " <> herpub 354 <> " aNd " <> B16.encodeBase16 mac 355 slog "GoINg ofFLinE.." 356 pure End 357 358 _ -> srpsimple cmd 359