aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Sodium.hs3
-rw-r--r--src/Ssb/Feed.hs16
-rw-r--r--src/Ssb/Peer/BoxStream.hs6
-rw-r--r--src/Ssb/Peer/RPC.hs38
-rw-r--r--src/Ssb/Peer/RPC/Gossip.hs4
-rw-r--r--src/Ssb/Peer/RPC/Room.hs6
-rw-r--r--src/Ssb/Peer/SecretHandshake.hs129
-rw-r--r--src/Ssb/Peer/TCP.hs2
8 files changed, 99 insertions, 105 deletions
diff --git a/src/Sodium.hs b/src/Sodium.hs
index eb11bb2..fbc461f 100644
--- a/src/Sodium.hs
+++ b/src/Sodium.hs
@@ -86,7 +86,7 @@ publicKeyToCurve25519 pk = unsafePerformIO $ do
-- | Convenience function for accessing constant C strings
constByteStrings :: [ByteString] -> ([CStringLen] -> IO b) -> IO b
constByteStrings =
- foldr (\v kk -> \k -> (unsafeUseAsCStringLen v) (\a -> kk (\as -> k (a:as)))) ($ [])
+ foldr (\ v kk k -> unsafeUseAsCStringLen v (\a -> kk (\as -> k (a:as)))) ($ [])
-- | Slightly safer cousin to 'buildUnsafeByteString' that remains in the
-- 'IO' monad.
@@ -96,4 +96,3 @@ buildUnsafeByteString' n k = do
bs <- unsafePackMallocCStringLen (ph, fromIntegral n)
out <- unsafeUseAsCString bs k
return (out, bs)
-
diff --git a/src/Ssb/Feed.hs b/src/Ssb/Feed.hs
index ebdd2f4..57547a9 100644
--- a/src/Ssb/Feed.hs
+++ b/src/Ssb/Feed.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE GeneralisedNewtypeDeriving #-}
-
module Ssb.Feed where
import Protolude hiding ( Identity
@@ -220,7 +218,7 @@ withoutSignature buf =
$ snd
$ BS.breakSubstring (BS.reverse signaturePattern) (BS.reverse buf)
where
- appendToEnd = \x y -> BS.append y x
+ appendToEnd = flip BS.append
signaturePattern = ",\n \"signature\":"
newVerifiableMessage
@@ -251,9 +249,9 @@ atMayFeed i (Feed _ msgs) = atMay msgs i
-- verification fails.
append :: ToJSON a => Feed a -> VerifiableMessage a -> Either Text (Feed a)
append (Feed id msgs) msg = do
- if (verify id msg)
- then (return (Feed id (msgs ++ [msg])))
- else (error "verification failed")
+ if verify id msg
+ then return (Feed id (msgs ++ [msg]))
+ else error "verification failed"
appendContent :: ToJSON a => Feed a -> a -> IO (Either Text (Feed a))
appendContent (Feed id msgs) content = do
@@ -290,9 +288,9 @@ signMessage id msg = do
msg { signature = Just signature }
return $ do
vMsg' <- vMsg
- if (verify id vMsg')
- then (return vMsg')
- else (error "signing failed verification")
+ if verify id vMsg'
+ then return vMsg'
+ else error "signing failed verification"
Left err -> return $ error err
verify :: ToJSON a => Identity -> VerifiableMessage a -> Bool
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
generated by cgit v1.2.3 (git 2.26.2) at 2024-11-04 21:54:00 +0000