Session.hs (9995B)
1 module Cryptopals.DH.Session ( 2 Command(..) 3 , genGroup 4 , genKeypair 5 6 , Sesh(..) 7 8 , blog 9 , slog 10 11 , dh 12 , dhng 13 14 , dhmitm 15 , dhngmitm 16 ) where 17 18 import Control.Concurrent (threadDelay) 19 import Control.Monad.Primitive 20 import Control.Monad.IO.Class 21 import Control.Monad.Trans.State (StateT) 22 import qualified Control.Monad.Trans.State as S 23 import qualified Cryptopals.AES as AES 24 import Cryptopals.DH.Core 25 import qualified Cryptopals.Digest.Pure.SHA as CS 26 import qualified Cryptopals.Util as CU 27 import qualified Data.Binary as DB 28 import qualified Data.ByteString as BS 29 import qualified Data.ByteString.Lazy as BL 30 import qualified Data.ByteString.Base16 as B16 31 import qualified Data.ByteString.Base64 as B64 32 import qualified Data.ByteString.Char8 as B8 33 import qualified Data.Char as C 34 import qualified Data.Text as T 35 import qualified Data.Text.Encoding as TE 36 import qualified Data.Text.IO as TIO 37 import GHC.Generics (Generic) 38 import GHC.Word (Word32) 39 import qualified Network.Socket.ByteString as NB 40 import Numeric.Natural 41 import Pipes 42 import qualified Pipes.Binary as PB 43 import qualified Pipes.Network as PN 44 import qualified Pipes.Parse as PP 45 import qualified Pipes.Prelude as P 46 import qualified System.Exit as SE 47 import qualified System.Random.MWC as MWC 48 49 data Command = 50 SendGroup Group -- group only 51 | AckGroup -- ack receipt of group params 52 | SendParams Group Natural -- group + public key 53 | SendPublic Natural -- public key only 54 | SendMessage BS.ByteString -- send initial ciphertext 55 | SendTerminal BS.ByteString -- send final ciphertext 56 deriving (Eq, Show, Generic) 57 58 instance DB.Binary Command 59 60 -- session state 61 data Sesh = Sesh { 62 dhGroup :: Maybe Group 63 , dhHost :: T.Text 64 , dhSock :: PN.Socket 65 , dhKeys :: Maybe Keys 66 , dhKey :: Maybe BS.ByteString 67 , dhGen :: IO (MWC.Gen RealWorld) 68 } 69 70 -- basic log 71 blog :: T.Text -> T.Text -> IO () 72 blog host msg = TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg 73 74 -- session log 75 slog :: T.Text -> StateT Sesh IO () 76 slog msg = do 77 host <- S.gets dhHost 78 liftIO $ TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg 79 liftIO suspense 80 81 -- dramatic effect 82 suspense :: IO () 83 suspense = threadDelay 1000000 84 85 -- generic session evaluator 86 seval 87 :: (Command -> StateT Sesh IO a) 88 -> Maybe Command 89 -> StateT Sesh IO a 90 seval cont = \case 91 Nothing -> do 92 slog "ending session" 93 liftIO $ SE.exitSuccess -- XX should really just close the socket 94 Just cmd -> do 95 liftIO suspense 96 cont cmd 97 98 -- basic dh evaluation 99 dh :: PN.Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command) 100 dh = seval dheval 101 102 -- mitm dh evaluation 103 dhmitm :: PN.Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command) 104 dhmitm = seval mitmeval 105 106 -- negotiated-group dh evaluation 107 dhng :: PN.Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command) 108 dhng = seval ngeval 109 110 -- mitm negotiated-group dh evaluation 111 dhngmitm 112 :: Natural 113 -> PN.Protocol (StateT Sesh IO) (Maybe Command) (Maybe Command) 114 dhngmitm = seval . malgeval 115 116 -- diffie-hellman protocol eval 117 dheval 118 :: Command 119 -> StateT Sesh IO (Maybe Command) 120 dheval = \case 121 SendGroup _ -> do 122 slog "missing public key, aborting.." 123 pure Nothing 124 125 AckGroup -> do 126 slog "didn't send group, aborting.." 127 pure Nothing 128 129 SendParams grp pk -> do 130 slog $ "received group parameters and public key " <> renderkey pk 131 S.modify (\sesh -> sesh { dhGroup = Just grp }) 132 Keys {..} <- genKeypair 133 deriveKey pk 134 slog $ "sending public key " <> renderkey pk 135 pure $ Just (SendPublic pub) 136 137 SendPublic pk -> do 138 slog $ "received public key " <> renderkey pk 139 sesh@Sesh {..} <- S.get 140 k <- deriveKey pk 141 cip <- encrypt "attack at 10pm" 142 S.put sesh { dhKey = Just k } 143 slog $ "sending ciphertext " <> B64.encodeBase64 cip 144 pure $ Just (SendMessage cip) 145 146 SendMessage cip -> do 147 slog $ "received ciphertext " <> B64.encodeBase64 cip 148 sesh@Sesh {..} <- S.get 149 msg <- decrypt cip 150 slog $ "decrypted ciphertext: \"" <> TE.decodeLatin1 msg <> "\"" 151 ncip <- encrypt $ "confirmed, attacking at 10pm" 152 slog $ "replying with ciphertext " <> B64.encodeBase64 ncip 153 pure $ Just (SendTerminal ncip) 154 155 SendTerminal cip -> do 156 slog $ "received ciphertext " <> B64.encodeBase64 cip 157 sesh@Sesh {..} <- S.get 158 msg <- decrypt cip 159 slog $ "decrypted ciphertext: \"" <> TE.decodeLatin1 msg <> "\"" 160 pure Nothing 161 162 -- man-in-the-middle protocol eval 163 mitmeval 164 :: Command 165 -> StateT Sesh IO (Maybe Command) 166 mitmeval = \case 167 SendParams grp pk -> do 168 slog $ "reCEiVed GRoUp pArAmeTErs And pUBliC kEy " <> renderkey pk 169 sesh@Sesh {..} <- S.get 170 let key = derivekey grp (Keys p 1) p 171 nex = sesh { dhKey = Just key } 172 S.put nex 173 slog $ "sEnDinG BOguS paRaMeTeRs wIth PuBLiC kEy " <> renderkey p 174 pure $ Just (SendParams grp p) 175 176 SendPublic pk -> do 177 slog $ "REceIvED pUBlic keY " <> renderkey pk 178 slog $ "seNDINg boGus kEy " <> renderkey p 179 pure $ Just (SendPublic p) 180 181 SendMessage cip -> do 182 slog $ "rECeIveD CiPHeRTexT " <> B64.encodeBase64 cip 183 sesh@Sesh {..} <- S.get 184 mmsg <- decryptLenient cip 185 case mmsg of 186 Nothing -> 187 slog "couLdN'T DeCRyPt CiPHertExT" 188 Just msg -> 189 slog $ "DEcRyptEd cIPheRTeXt: \"" <> TE.decodeLatin1 msg <> "\"" 190 slog "reLayINg cIpheRtExt" 191 pure $ Just (SendMessage cip) 192 193 SendTerminal cip -> do 194 slog $ "reCeiVeD CipHeRtExt " <> B64.encodeBase64 cip 195 sesh@Sesh {..} <- S.get 196 mmsg <- decryptLenient cip 197 case mmsg of 198 Nothing -> 199 slog "couLdN'T DeCRyPt CiPHertExT" 200 Just msg -> 201 slog $ "DeCrYpteD cIphErteXt: \"" <> TE.decodeLatin1 msg <> "\"" 202 slog "ReLaYINg CiPHeRTexT" 203 pure (Just (SendTerminal cip)) 204 205 cmd -> do 206 slog "RelAyInG coMmaNd" 207 pure (Just cmd) 208 209 -- negotiated-group protocol eval 210 ngeval 211 :: Command 212 -> StateT Sesh IO (Maybe Command) 213 ngeval = \case 214 SendGroup grp -> do 215 slog "received group parameters" 216 sesh@Sesh {..} <- S.get 217 S.put sesh { dhGroup = Just grp } 218 slog "acking group parameters" 219 pure (Just AckGroup) 220 221 AckGroup -> do 222 slog "received ack" 223 sesh@Sesh {..} <- S.get 224 Keys {..} <- genKeypair 225 slog $ "sending public key " <> renderkey pub 226 pure $ Just (SendPublic pub) 227 228 SendParams {} -> do 229 slog "not expecting group parameters and public key" 230 pure Nothing 231 232 SendPublic pk -> do 233 slog $ "received public key " <> renderkey pk 234 sesh@Sesh {..} <- S.get 235 case dhKeys of 236 Nothing -> do 237 Keys {..} <- genKeypair 238 key <- deriveKey pk 239 slog "sending public key" 240 pure (Just (SendPublic pub)) 241 Just Keys {..} -> do 242 key <- deriveKey pk 243 cip <- encrypt "attack at 10pm" 244 slog $ "sending ciphertext " <> B64.encodeBase64 cip 245 pure (Just (SendMessage cip)) 246 247 cmd -> dheval cmd 248 249 -- negotiated-group mitm protocol eval 250 malgeval 251 :: Natural 252 -> Command 253 -> StateT Sesh IO (Maybe Command) 254 malgeval malg = \case 255 SendGroup grp -> do 256 slog "reCEiVed GRoUp pArAmeTErs" 257 sesh <- S.get 258 let key = derivekey grp (Keys p malg) malg 259 S.put sesh { 260 dhGroup = Just grp 261 , dhKey = Just key 262 } 263 let malgrp = Group p malg 264 slog "sEnDinG BOguS GRoUp paRaMeTeRs" 265 pure $ Just (SendGroup malgrp) 266 267 AckGroup -> do 268 slog "rECeiVed aCK" 269 slog "ReLaYINg ACk" 270 pure (Just AckGroup) 271 272 SendParams grp pk -> do 273 slog "nOt eXPecTinG gRoUp and PublIc KeY" 274 pure Nothing 275 276 SendPublic pk -> do 277 slog $ "REceIvED pUBlic keY " <> renderkey pk 278 slog $ "SeNDing BoGuS kEy " <> renderkey malg 279 pure $ Just (SendPublic malg) 280 281 cmd -> mitmeval cmd 282 283 genGroup :: Natural -> Natural -> StateT Sesh IO Group 284 genGroup p g = do 285 sesh <- S.get 286 let grp = Group p g 287 S.put sesh { 288 dhGroup = Just grp 289 } 290 pure grp 291 292 genKeypair :: StateT Sesh IO Keys 293 genKeypair = do 294 sesh@Sesh {..} <- S.get 295 case dhGroup of 296 Nothing -> do 297 slog "missing group parameters" 298 liftIO SE.exitFailure 299 Just grp -> do 300 gen <- liftIO dhGen 301 per <- liftIO $ genpair grp gen 302 S.put sesh { 303 dhKeys = Just per 304 } 305 pure per 306 307 deriveKey :: Natural -> StateT Sesh IO BS.ByteString 308 deriveKey pk = do 309 sesh@Sesh {..} <- S.get 310 let params = do 311 grp <- dhGroup 312 per <- dhKeys 313 pure (grp, per) 314 case params of 315 Nothing -> do 316 slog "missing group parameters or keypair" 317 liftIO SE.exitFailure 318 Just (grp, per) -> do 319 let key = derivekey grp per pk 320 S.put sesh { 321 dhKey = Just key 322 } 323 pure key 324 325 encrypt :: BS.ByteString -> StateT Sesh IO BS.ByteString 326 encrypt msg = do 327 sesh@Sesh {..} <- S.get 328 case dhKey of 329 Nothing -> do 330 slog "missing shared key" 331 liftIO SE.exitFailure 332 Just k -> do 333 gen <- liftIO dhGen 334 iv <- liftIO $ CU.bytes 16 gen 335 let pad = CU.lpkcs7 msg 336 pure $ AES.encryptCbcAES128 iv k pad 337 338 decrypt :: BS.ByteString -> StateT Sesh IO BS.ByteString 339 decrypt cip = do 340 sesh@Sesh {..} <- S.get 341 case dhKey of 342 Nothing -> do 343 slog "missing shared key" 344 liftIO SE.exitFailure 345 Just k -> do 346 case CU.unpkcs7 (AES.decryptCbcAES128 k cip) of 347 Nothing -> do 348 slog "couldn't decrypt ciphertext" 349 liftIO SE.exitFailure 350 Just msg -> pure msg 351 352 decryptLenient :: BS.ByteString -> StateT Sesh IO (Maybe BS.ByteString) 353 decryptLenient cip = do 354 sesh@Sesh {..} <- S.get 355 case dhKey of 356 Nothing -> do 357 slog "missing shared key" 358 liftIO SE.exitFailure 359 Just k -> do 360 case CU.unpkcs7 (AES.decryptCbcAES128 k cip) of 361 Nothing -> do 362 slog "couldn't decrypt ciphertext" 363 pure Nothing 364 Just msg -> pure (Just msg) 365 366 renderkey :: Natural -> T.Text 367 renderkey = 368 B16.encodeBase16 369 . BL.toStrict 370 . CS.bytestringDigest 371 . CS.sha1 372 . DB.encode