From c019ffde1b35cda5139ca65c80265603c23cd7b9 Mon Sep 17 00:00:00 2001 From: Cypher Date: Tue, 3 May 2022 15:19:21 -0500 Subject: Apply linting --- src/Ssb/Peer/BoxStream.hs | 6 +- src/Ssb/Peer/RPC.hs | 38 ++++++------ src/Ssb/Peer/RPC/Gossip.hs | 4 +- src/Ssb/Peer/RPC/Room.hs | 6 +- src/Ssb/Peer/SecretHandshake.hs | 129 ++++++++++++++++++++-------------------- src/Ssb/Peer/TCP.hs | 2 +- 6 files changed, 91 insertions(+), 94 deletions(-) (limited to 'src/Ssb/Peer') diff --git a/src/Ssb/Peer/BoxStream.hs b/src/Ssb/Peer/BoxStream.hs index d804e56..bb81a12 100644 --- a/src/Ssb/Peer/BoxStream.hs +++ b/src/Ssb/Peer/BoxStream.hs @@ -296,12 +296,12 @@ readStream' connState bytes = if BS.length (buffer connState) >= bytes else do let bodyLength' = bodyLength <$> (buf >>= decryptHeader key' nonce') case bodyLength' of - Left err -> return $ (connState, Left err) + Left err -> return (connState, Left err) Right bodyLength' -> do - ePayload <- (withErr errNoBody) + ePayload <- withErr errNoBody <$> read connState (fromIntegral bodyLength') case ePayload of - Left err -> return $ (connState, Left err) + Left err -> return (connState, Left err) Right payload -> case decryptMessage key' diff --git a/src/Ssb/Peer/RPC.hs b/src/Ssb/Peer/RPC.hs index 1336b5e..1de70f1 100644 --- a/src/Ssb/Peer/RPC.hs +++ b/src/Ssb/Peer/RPC.hs @@ -91,7 +91,7 @@ instance FromJSON ProcedureType where "async" -> return Async "source" -> return Source "duplex" -> return Duplex - otherwise -> fail $ "unknown value '" <> toS v <> "'" + _ -> fail $ "unknown value '" <> toS v <> "'" instance ToJSON ProcedureType where toJSON Async = "async" @@ -323,9 +323,9 @@ instance Default Router instance Handler Router where endpoints demuxer = Map.keys (endpointHandlers demuxer) - serve demuxer endpoint = case Map.lookup endpoint endpointHandlers' of - Nothing -> (notFoundHandlerFunc endpoint) - Just handler -> handler + serve demuxer endpoint = fromMaybe + (notFoundHandlerFunc endpoint) + (Map.lookup endpoint endpointHandlers') where endpointHandlers' = endpointHandlers demuxer notifyConnect demuxer id = do @@ -451,7 +451,7 @@ streamStatus :: Stream -> STM StreamStatus streamStatus stream = do table <- readTMVar $ streamTable stream return - $ fromMaybe Closed (status . fst <$> Map.lookup (streamID stream) table) + $ maybe Closed (status . fst) (Map.lookup (streamID stream) table) -- | manageStreamConn manages stream connection changes when writing messages -- to a stream. @@ -493,7 +493,7 @@ handleMessage :: Handler h => h -> ConnState -> Message -> IO Bool handleMessage handler conn msg = do nextReqNum <- atomically $ readTMVar (nextIncomingReqNum conn) if - | (header msg) == goodByeHeader -> return False + | header msg == goodByeHeader -> return False | (isRequest nextReqNum msg) -> serveRequest handler conn msg | (isEndOfStream msg) -> internalCloseStream conn msg | (isAsyncResponse msg) -> do @@ -503,7 +503,7 @@ handleMessage handler conn msg = do where internalCloseStream conn msg = do let flags = def { isStream = True, isEndOrError = True } - let requestNumber' = (requestNumber . header $ msg) + let requestNumber' = requestNumber . header $ msg let mVarTable = if requestNumber' > 0 then streamsIn conn else streamsOut conn table <- atomically $ takeTMVar mVarTable @@ -554,7 +554,7 @@ handleMessage handler conn msg = do then return $ Left errTooManyRequests else do let (reqNum', table') = if streamID stream == reqNum - then (reqNum + 1, (Map.insert reqNum (stream, chan) table)) + then (reqNum + 1, Map.insert reqNum (stream, chan) table) else (reqNum, table) putTMVar (nextIncomingReqNum conn) reqNum' putTMVar (streamsIn conn) table' @@ -566,7 +566,7 @@ handleMessage handler conn msg = do Right _ -> do -- Serving a request call, how do we close it nicely? let endpoint = Endpoint (name req) (typ req) - spawnConnection stream $ (serve handler) endpoint (args req) stream + spawnConnection stream $ serve handler endpoint (args req) stream return True where errTooManyRequests = "connection limit reached, dropping request" :: Text @@ -619,7 +619,7 @@ readBoxStream conn bytes = do readMessage :: ConnState -> IO (Either Text Message) readMessage conn = do headerBuf <- readBoxStream (boxConn conn) headerLength - header <- (return $ headerBuf >>= decode) + let header = headerBuf >>= decode case header of Left err -> return $ Left $ "RPC.readMessage header: " <> err Right header -> do @@ -627,10 +627,10 @@ readMessage conn = do let ret = liftA2 (<>) headerBuf bodyBuf >>= decode logDebug conn $ "readMessage (" - <> (Ssb.formatPublicKey $ connPeer conn) + <> Ssb.formatPublicKey (connPeer conn) <> ")" - <> (show ret) - return $ ret + <> show ret + return ret where decode :: Serialize a => ByteString -> Either Text a decode = mapLeft toS . Serialize.decode @@ -639,9 +639,9 @@ writeMessage :: ConnState -> Message -> IO (Either Text ()) writeMessage conn msg = do logDebug conn $ "writeMessage (" - <> (Ssb.formatPublicKey $ connPeer conn) + <> Ssb.formatPublicKey (connPeer conn) <> ")" - <> (show msg) + <> show msg BoxStream.sendStream (boxConn conn) $ Serialize.encode msg -- | request makes a Remote Procedure Call on the peer. @@ -673,7 +673,7 @@ request conn req session = do } let stream = Stream { streamID = reqNum - , streamType = (typ req) + , streamType = typ req , conn = conn , direction = Outgoing , status = Open @@ -788,7 +788,7 @@ newCloseErrorNotification streamID msg = do closeStreamWithError :: Stream -> Text -> IO (Either Text ()) closeStreamWithError stream err = case streamType stream of Async -> return . return $ () - otherwise -> + _ -> either (return . Left) (manageStreamConn stream) $ newCloseErrorNotification (streamID stream) err @@ -818,7 +818,7 @@ readStreamJSON stream = do resp <- readStream stream case resp of (Just (JSONPayload buf)) -> return (Just <$> decodeJSON buf) - (Just otherwise ) -> return (errPayload resp) + (Just _) -> return (errPayload resp) Nothing -> return . return $ Nothing where errPayload payload = @@ -834,7 +834,7 @@ writeStream stream flags payload = do let msgID = case direction stream of Incoming -> -1 * streamID stream Outgoing -> streamID stream - let flags' = flags { isStream = not $ (streamType stream) == Async } + let flags' = flags { isStream = streamType stream /= Async } let header' = case payload of (BinaryPayload p) -> newHeader (flags' { bodyType = Binary }) msgID p diff --git a/src/Ssb/Peer/RPC/Gossip.hs b/src/Ssb/Peer/RPC/Gossip.hs index 80e1aac..97eff4c 100644 --- a/src/Ssb/Peer/RPC/Gossip.hs +++ b/src/Ssb/Peer/RPC/Gossip.hs @@ -103,7 +103,7 @@ newGossiper = do return $ Gossiper mVar addFeed :: ToJSON a => Gossiper a -> Feed.Feed a -> IO () -addFeed (Gossiper (mFeeds)) feed = do +addFeed (Gossiper mFeeds) feed = do atomically $ do feeds <- takeTMVar mFeeds putTMVar mFeeds (Feed.insert feed feeds) @@ -115,7 +115,7 @@ writeFeed stream (Feed.Feed _ msgs) = do (\msg -> do let msg' = Feed.encodeJSONVerifiableMessage msg err <- RPC.writeStream stream def (RPC.JSONPayload msg') - either (\err -> putStrLn err) (\_ -> return ()) err + either putStrLn (\_ -> return ()) err ) instance ToJSON a => RPC.Handler (Gossiper a) where diff --git a/src/Ssb/Peer/RPC/Room.hs b/src/Ssb/Peer/RPC/Room.hs index 7be7d2c..96c19e8 100644 --- a/src/Ssb/Peer/RPC/Room.hs +++ b/src/Ssb/Peer/RPC/Room.hs @@ -287,7 +287,7 @@ instance RPC.Handler Room where case args' of Left err -> return $ Left err Right [connReq] -> connect h stream connReq - otherwise -> return $ Left "bad target argument" + _ -> return $ Left "bad target argument" serve h (RPC.Endpoint ["tunnel", "endpoints"] _) _ stream = do err <- registerPeer h stream @@ -304,7 +304,7 @@ instance RPC.Handler Room where where while f = do continue <- f - if continue then (while f) else return False + if continue then while f else return False serve room (RPC.Endpoint ["tunnel", "leave"] _) _ stream = leave' room (RPC.peer stream) @@ -317,7 +317,7 @@ instance RPC.Handler Room where RPC.writeStreamJSON stream resp -- HACK: return OK when endpoint not known to avoid disconnecting clients - serve room endpoint@otherwise arg stream = return . return $ () + serve room endpoint arg stream = return . return $ () --serve room endpoint@otherwise arg stream = (RPC.notFoundHandlerFunc endpoint) arg stream notifyConnect _ _ = return . return $ () 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' - - diff --git a/src/Ssb/Peer/TCP.hs b/src/Ssb/Peer/TCP.hs index 59d7f81..67053bb 100644 --- a/src/Ssb/Peer/TCP.hs +++ b/src/Ssb/Peer/TCP.hs @@ -53,7 +53,7 @@ serveBoxStream host port networkID id cmd = case res of Left err -> putStrLn $ "client handshake error: " <> err Right sharedSecrets -> do - let peerID = (fromMaybe undefined $ SH.secretA sharedSecrets) + let peerID = fromMaybe undefined $ SH.secretA sharedSecrets conn <- BoxStream.connectServer socket sharedSecrets case conn of Left err -> putStrLn $ "client error: " <> err -- cgit v1.2.3