SRP.hs (7293B)
1 module Cryptopals.SRP 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.ByteString as BS 14 import qualified Data.ByteString.Base64 as B64 15 import qualified Data.ByteString.Lazy as BL 16 import qualified Data.Text as T 17 import qualified Data.Text.Encoding as TE 18 import qualified Data.Text.IO as TIO 19 import GHC.Generics (Generic) 20 import GHC.Word (Word64) 21 import Numeric.Natural 22 import Pipes 23 import qualified Pipes.Binary as PB 24 import qualified Pipes.Network as PN 25 import qualified System.Exit as SE 26 import qualified System.Random.MWC as MWC 27 28 -- common parameters 29 data Env = Env { 30 en :: Natural 31 , eg :: Natural 32 , ek :: Natural 33 , ei :: BS.ByteString 34 , ep :: BS.ByteString 35 } deriving (Eq, Show, Generic) 36 37 defaultEnv :: Env 38 defaultEnv = Env { 39 en = p192 40 , eg = 2 41 , ek = 3 42 , ei = "l33th4x0r@hotmail.com" 43 , ep = "hunter2" 44 } 45 46 instance DB.Binary Env 47 48 data Command = 49 Auth BS.ByteString Natural 50 | AckAuth BS.ByteString Natural 51 | SendMAC BS.ByteString 52 | End 53 deriving (Eq, Show, Generic) 54 55 instance DB.Binary Command 56 57 -- generic state 58 data Sesh = Sesh { 59 shost :: T.Text 60 , ssalt :: Maybe BS.ByteString 61 , skey :: Natural 62 , sourpub :: Natural 63 , sherpub :: Maybe Natural 64 , sv :: Maybe Natural 65 , sgen :: IO (MWC.Gen RealWorld) 66 } 67 68 type SRP m = StateT Sesh (ReaderT Env m) 69 70 server 71 :: (DB.Binary b, DB.Binary c) 72 => PN.ServiceName 73 -> PN.Protocol (SRP IO) b c 74 -> IO () 75 server port eval = PN.serve "localhost" port $ \(sock, _) -> do 76 sesh <- initServer defaultEnv 77 blog "server" "listening.." 78 let saction = runEffect (PN.session sock eval) 79 void $ runReaderT (evalStateT saction sesh) defaultEnv 80 81 client 82 :: (DB.Binary b, DB.Binary c) 83 => PN.ServiceName 84 -> PN.Protocol (SRP IO) b c 85 -> SRP IO Command 86 -> IO () 87 client port eval knit = PN.connect "localhost" port $ \(sock, _) -> do 88 sesh <- initClient defaultEnv 89 blog "client" "session established" 90 91 (cmd, nex) <- runReaderT (runStateT knit sesh) defaultEnv 92 93 runEffect $ 94 PB.encode cmd 95 >-> PN.toSocket sock 96 97 let saction = runEffect (PN.session sock eval) 98 void $ runReaderT (runStateT saction nex) defaultEnv 99 100 auth :: SRP IO Command 101 auth = do 102 Env {..} <- lift ask 103 pub <- gets sourpub 104 slog "sending authentication request" 105 pure (Auth ei pub) 106 107 authZero :: SRP IO Command 108 authZero = do 109 Env {..} <- lift ask 110 sesh <- get 111 put sesh { sourpub = 0 } 112 slog "sending authentication request with a zero key" 113 pure (Auth ei 0) 114 115 -- basic log 116 blog :: T.Text -> T.Text -> IO () 117 blog host msg = do 118 TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg 119 suspense 120 121 -- session log 122 slog :: MonadIO m => T.Text -> StateT Sesh m () 123 slog msg = do 124 host <- gets shost 125 liftIO . TIO.putStrLn $ "(cryptopals) " <> host <> ": " <> msg 126 liftIO suspense 127 128 -- dramatic effect 129 suspense :: IO () 130 suspense = threadDelay 1000000 131 132 -- 2 ^ 192 - 2 ^ 64 - 1 133 p192 :: Natural 134 p192 = 6277101735386680763835789423207666416083908700390324961279 135 136 initServer :: Env -> IO Sesh 137 initServer Env {..} = do 138 gen <- MWC.createSystemRandom 139 skey <- MWC.uniformRM (1, en - 1) gen 140 salt <- fmap DB.encode (MWC.uniform gen :: IO Word64) 141 let xH = CS.sha256 (salt <> BL.fromStrict ep) 142 x = fromIntegral (CS.integerDigest xH) 143 v = DH.modexp eg x en 144 strsalt = BL.toStrict salt 145 sourpub = ek * v + DH.modexp eg skey en 146 pure Sesh { 147 sgen = pure gen 148 , ssalt = pure strsalt 149 , sv = pure v 150 , sherpub = Nothing 151 , shost = "server" 152 , .. 153 } 154 155 initClient :: Env -> IO Sesh 156 initClient Env {..} = do 157 gen <- MWC.createSystemRandom 158 skey <- MWC.uniformRM (1, en - 1) gen 159 let sourpub = DH.modexp eg skey en 160 pure Sesh { 161 sgen = pure gen 162 , sherpub = Nothing 163 , ssalt = Nothing 164 , sv = Nothing 165 , shost = "client" 166 , .. 167 } 168 169 -- secure remote password protocol 170 srp :: MonadIO m => PN.Protocol (SRP m) Command Command 171 srp cmd = do 172 Env {..} <- lift ask 173 case cmd of 174 Auth i herpub -> do 175 let li = TE.decodeLatin1 i 176 slog $ "received authentication request for " <> li 177 if i /= ei 178 then do 179 slog $ "unknown user " <> li 180 pure End 181 else do 182 sesh@Sesh {..} <- get 183 put sesh { 184 sherpub = Just herpub 185 } 186 case ssalt of 187 Nothing -> do 188 slog "missing required parameters" 189 pure End 190 Just salt -> do 191 slog $ "acking authentication request for " <> li 192 pure (AckAuth salt sourpub) 193 194 AckAuth salt herpub -> do 195 slog "received authentication request ack" 196 sesh@Sesh {..} <- get 197 put sesh { 198 ssalt = Just salt 199 , sherpub = Just herpub 200 } 201 let u = hashpubs sourpub herpub 202 x = fromIntegral 203 . CS.integerDigest 204 . CS.sha256 205 $ BL.fromStrict (salt <> ep) 206 s = DH.modexp 207 (herpub - ek * DH.modexp eg x en) 208 (skey + u * x) 209 en 210 k = CS.bytestringDigest 211 . CS.sha256 212 . DB.encode 213 $ s 214 let mac = BL.toStrict 215 . CS.bytestringDigest 216 $ CS.hmacSha256 k (BL.fromStrict salt) 217 slog $ "sending MAC " <> B64.encodeBase64 mac 218 pure (SendMAC mac) 219 220 SendMAC mac -> do 221 slog $ "received MAC " <> B64.encodeBase64 mac 222 sesh@Sesh {..} <- get 223 case (,,) <$> ssalt <*> sv <*> sherpub of 224 Nothing -> do 225 slog "missing required parameters" 226 pure End 227 Just (salt, v, herpub) -> do 228 let u = hashpubs herpub sourpub 229 s = DH.modexp (herpub * DH.modexp v u en) skey en 230 k = CS.bytestringDigest 231 . CS.sha256 232 . DB.encode 233 $ s 234 hmac = BL.toStrict 235 . CS.bytestringDigest 236 $ CS.hmacSha256 k (BL.fromStrict salt) 237 if hmac == mac 238 then do 239 slog "OK" 240 pure End 241 else do 242 slog "couldn't verify MAC" 243 pure End 244 245 End -> do 246 slog "ending session" 247 liftIO SE.exitSuccess -- XX close the socket 248 249 srpZero :: MonadIO m => PN.Protocol (SRP m) Command Command 250 srpZero cmd = do 251 Env {..} <- lift ask 252 case cmd of 253 AckAuth salt herpub -> do 254 slog "received authentication request ack" 255 sesh@Sesh {..} <- get 256 put sesh { 257 ssalt = Just salt 258 , sherpub = Just herpub 259 } 260 let k = CS.bytestringDigest 261 . CS.sha256 262 . DB.encode 263 $ (0 :: Natural) 264 let mac = BL.toStrict 265 . CS.bytestringDigest 266 $ CS.hmacSha256 k (BL.fromStrict salt) 267 slog $ "sending MAC " <> B64.encodeBase64 mac 268 pure (SendMAC mac) 269 270 _ -> srp cmd 271 272 hashpubs :: Natural -> Natural -> Natural 273 hashpubs a b = 274 fromIntegral 275 . CS.integerDigest 276 . CS.sha256 277 $ DB.encode a <> DB.encode b 278