diff options
Diffstat (limited to 'src/Ssb/Peer/SecretHandshake.hs')
| -rw-r--r-- | src/Ssb/Peer/SecretHandshake.hs | 129 |
1 files changed, 63 insertions, 66 deletions
diff --git a/src/Ssb/Peer/SecretHandshake.hs b/src/Ssb/Peer/SecretHandshake.hs index 4245542..5247a6e 100644 --- a/src/Ssb/Peer/SecretHandshake.hs +++ b/src/Ssb/Peer/SecretHandshake.hs @@ -284,16 +284,16 @@ decodeClientAuthMessage state buf = do $ SecretBox.secretboxOpen key nonce buf -- TODO: Make the client auth message length a constant - msg3 <- if (BS.length msg3 == 96) - then (return msg3) - else (Left badMessageLength) + msg3 <- if BS.length msg3 == 96 + then return msg3 + else Left badMessageLength let detachedSignatureA = BS.take 64 msg3 clientLongTermPubKey <- naclDecode "client Long Term Public Key" $ BS.drop 64 msg3 let msg = (network :: ByteString) - <> (extractPublicKey serverPublicKey) + <> extractPublicKey serverPublicKey <> SHA256.hash (Nacl.encode sharedSecretab) if Sign.signVerifyDetached clientLongTermPubKey @@ -383,7 +383,7 @@ newDetachedSignatureB network detachedSignatureA clientPublicKey sharedSecretab let msg = (network :: ByteString) <> detachedSignatureA - <> (extractPublicKey clientPublicKey) + <> extractPublicKey clientPublicKey <> SHA256.hash (Nacl.encode sharedSecretab) return $ Sign.signDetached key msg where @@ -484,8 +484,7 @@ encode state msg = case msg of key <- maybeToEither badKeyMsg $ Nacl.decode - $ SHA256.hash - $ ((network :: ByteString) + $ SHA256.hash ((network :: ByteString) <> Nacl.encode ssab <> Nacl.encode ssaB <> Nacl.encode ssAb) @@ -498,71 +497,71 @@ encode state msg = case msg of -- TODO: Process secretAb process :: ConnState -> Message -> IO (Either Text (ConnState, Maybe Message)) process state (ClientHello hmac cliEphPubKey network) = do - stateUpdate <- return $ do - srvLTPrivKey <- must "server Private Key" - $ serverPrivateKey state - srvEphPrivKey <- must "server ephemeral Private Key" - $ serverEphemeralPrivKey state - - ssab <- calcSharedSecretab srvEphPrivKey cliEphPubKey - -- TODO: srvLTPubKey should be curved Process sk_to_curve25519 - ssaB <- serverCalcSharedSecretaB srvLTPrivKey cliEphPubKey - - return $ state { connState = AwaitingClientAuthentication - , clientEphemeralPubKey = Just cliEphPubKey - , serverHMAC = Just hmac - , sharedSecretab = Just ssab - , sharedSecretaB = Just ssaB - } + let stateUpdate = do + srvLTPrivKey <- must "server Private Key" + $ serverPrivateKey state + srvEphPrivKey <- must "server ephemeral Private Key" + $ serverEphemeralPrivKey state + + ssab <- calcSharedSecretab srvEphPrivKey cliEphPubKey + -- TODO: srvLTPubKey should be curved Process sk_to_curve25519 + ssaB <- serverCalcSharedSecretaB srvLTPrivKey cliEphPubKey + + return $ state { connState = AwaitingClientAuthentication + , clientEphemeralPubKey = Just cliEphPubKey + , serverHMAC = Just hmac + , sharedSecretab = Just ssab + , sharedSecretaB = Just ssaB + } return $ stateUpdate >>= \state' -> case newServerHello state' of - Right msg' -> return $ (state', Just msg') + Right msg' -> return (state', Just msg') Left err -> Left err process state (ServerHello hmac ephPubKey network) = do - stateUpdate <- return $ do - cliLTPrivKey <- must "client Private Key" $ clientPrivateKey state - cliEphPrivKey <- must "ephemeral client Private Key" - $ clientEphemeralPrivKey state - srvLTPubKey <- must "server Public Key" $ serverPublicKey state - - ssab <- calcSharedSecretab cliEphPrivKey ephPubKey - ssaB <- clientCalcSharedSecretaB cliEphPrivKey srvLTPubKey - ssAb <- calcSharedSecretAb cliLTPrivKey ephPubKey - - return $ state { connState = AwaitingServerAccept - , serverHMAC = Just hmac - , serverEphemeralPubKey = Just ephPubKey - , sharedSecretab = Just ssab - , sharedSecretaB = Just ssaB - , sharedSecretAb = Just ssAb - } + let stateUpdate = do + cliLTPrivKey <- must "client Private Key" $ clientPrivateKey state + cliEphPrivKey <- must "ephemeral client Private Key" + $ clientEphemeralPrivKey state + srvLTPubKey <- must "server Public Key" $ serverPublicKey state + + ssab <- calcSharedSecretab cliEphPrivKey ephPubKey + ssaB <- clientCalcSharedSecretaB cliEphPrivKey srvLTPubKey + ssAb <- calcSharedSecretAb cliLTPrivKey ephPubKey + + return $ state { connState = AwaitingServerAccept + , serverHMAC = Just hmac + , serverEphemeralPubKey = Just ephPubKey + , sharedSecretab = Just ssab + , sharedSecretaB = Just ssaB + , sharedSecretAb = Just ssAb + } return $ stateUpdate >>= \state' -> case newClientAuthMessage state' of - Right msg' -> return $ (state', Just msg') + Right msg' -> return (state', Just msg') Left err -> Left err process state (ClientAuthMessage detachedSignatureA clientLongTermPubKey) = do - stateUpdate <- return $ do - let network = networkID state - srvPrivKey <- must "server private key" - $ serverPrivateKey state - srvEphPrivKey <- must "server Long Term ephemeral private key" - $ serverEphemeralPrivKey state - sharedSecretAb <- serverCalcSharedSecretAb srvEphPrivKey clientLongTermPubKey - sharedSecretab <- must "shared secret ab" $ sharedSecretab state - - detachedSignatureB <- newDetachedSignatureB - network - detachedSignatureA - clientLongTermPubKey - sharedSecretab - srvPrivKey - - return $ state { connState = HandshakeComplete - , detachedSignatureA = Just detachedSignatureA - , detachedSignatureB = Just detachedSignatureB - , clientPublicKey = Just clientLongTermPubKey - , sharedSecretAb = Just sharedSecretAb - } + let stateUpdate = do + let network = networkID state + srvPrivKey <- must "server private key" + $ serverPrivateKey state + srvEphPrivKey <- must "server Long Term ephemeral private key" + $ serverEphemeralPrivKey state + sharedSecretAb <- serverCalcSharedSecretAb srvEphPrivKey clientLongTermPubKey + sharedSecretab <- must "shared secret ab" $ sharedSecretab state + + detachedSignatureB <- newDetachedSignatureB + network + detachedSignatureA + clientLongTermPubKey + sharedSecretab + srvPrivKey + + return $ state { connState = HandshakeComplete + , detachedSignatureA = Just detachedSignatureA + , detachedSignatureB = Just detachedSignatureB + , clientPublicKey = Just clientLongTermPubKey + , sharedSecretAb = Just sharedSecretAb + } return $ stateUpdate >>= \state' -> case newServerAccept state' of Right msg' -> return $ (state', Just msg') Left err -> Left err @@ -691,5 +690,3 @@ welcomeHandshake send recv network serverID = do case connState state' of HandshakeComplete -> return $ Right state' _ -> loop state' - - |