From 7c87a578d3fc3f7bce6da28ccc49508a098a48a4 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 8 Jun 2020 18:57:53 +0200 Subject: [PATCH 1/3] move Main executable to app/ closes #18 --- Hash2Pub.cabal | 2 +- {src/Hash2Pub => app}/Main.hs | 0 2 files changed, 1 insertion(+), 1 deletion(-) rename {src/Hash2Pub => app}/Main.hs (100%) diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal index 084b096..4906c08 100644 --- a/Hash2Pub.cabal +++ b/Hash2Pub.cabal @@ -86,7 +86,7 @@ executable Hash2Pub other-extensions: GeneralizedNewtypeDeriving -- Directories containing source files. - hs-source-dirs: src/Hash2Pub + hs-source-dirs: app -- Base language which the package is written in. default-language: Haskell2010 diff --git a/src/Hash2Pub/Main.hs b/app/Main.hs similarity index 100% rename from src/Hash2Pub/Main.hs rename to app/Main.hs From 2c827ea326ca1abd504c08d5a2f1a67ef4f1eddd Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 8 Jun 2020 20:31:18 +0200 Subject: [PATCH 2/3] rename responseTo -> requestID to avoid partial record accessors --- FediChord.asn1 | 3 ++- src/Hash2Pub/ASN1Coding.hs | 8 ++++---- src/Hash2Pub/DHTProtocol.hs | 15 ++++++++------- src/Hash2Pub/ProtocolTypes.hs | 8 ++++++-- test/FediChordSpec.hs | 2 +- 5 files changed, 21 insertions(+), 15 deletions(-) diff --git a/FediChord.asn1 b/FediChord.asn1 index a907bb1..41f9650 100644 --- a/FediChord.asn1 +++ b/FediChord.asn1 @@ -27,7 +27,8 @@ Request ::= SEQUENCE { -- request and response instead of explicit flag Response ::= SEQUENCE { - responseTo INTEGER (0..4294967295), -- arbitrarily restricting to an unsigned 32bit integer + -- requestID of the request responding to + requestID INTEGER (0..4294967295), -- arbitrarily restricting to an unsigned 32bit integer senderID NodeID, part Partnum, finalPart BOOLEAN, -- flag indicating this `part` to be the last of this response diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index 25e435b..d476809 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -226,9 +226,9 @@ encodeMessage <> maybe [] encodePayload requestPayload <> [End Sequence] encodeMessage - (Response responseTo senderID part isFinalPart action responsePayload) = [ + (Response requestID senderID part isFinalPart action responsePayload) = [ Start Sequence - , IntVal responseTo + , IntVal requestID , IntVal . getNodeID $ senderID , IntVal part , Boolean isFinalPart @@ -277,7 +277,7 @@ parseRequest action = do pure $ Request requestID sender part isFinalPart action payload parseResponse :: Integer -> ParseASN1 FediChordMessage -parseResponse responseTo = do +parseResponse requestID = do senderID <- fromInteger <$> parseInteger :: ParseASN1 NodeID part <- parseInteger isFinalPart <- parseBool @@ -290,7 +290,7 @@ parseResponse responseTo = do Stabilise -> parseStabiliseResponse Ping -> parsePingResponse - pure $ Response responseTo senderID part isFinalPart action payload + pure $ Response requestID senderID part isFinalPart action payload parseBool :: ParseASN1 Bool parseBool = do diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 89a429b..626cd2b 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -161,13 +161,14 @@ sendMessageSize = 1200 -- encode the response to a request that just signals successful receipt ackRequest :: NodeID -> FediChordMessage -> Map.Map Integer BS.ByteString ackRequest ownID req@Request{} = serialiseMessage sendMessageSize $ Response { - responseTo = requestID req + requestID = requestID req , senderID = ownID , part = part req , isFinalPart = False , action = action req , payload = Nothing } +ackRequest _ _ = Map.empty -- | Dispatch incoming requests to the dedicated handling and response function, and enqueue @@ -232,7 +233,7 @@ respondQueryID nsSTM msgSet = do queryResult = queryLocalCache nsSnap cache (fromIntegral $ queryLBestNodes senderPayload') (queryTargetID senderPayload') } queryResponseMsg = Response { - responseTo = requestID aRequestPart + requestID = requestID aRequestPart , senderID = getNid nsSnap , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 , isFinalPart = False @@ -266,7 +267,7 @@ respondLeave nsSTM msgSet = do . setSuccessors (delete senderID $ requestSuccs <> successors nsSnap) $ nsSnap -- TODO: handle handover of key data let leaveResponse = Response { - responseTo = requestID aRequestPart + requestID = requestID aRequestPart , senderID = getNid nsSnap , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 , isFinalPart = False @@ -287,7 +288,7 @@ respondStabilise nsSTM msgSet = do , stabilisePredecessors = predecessors nsSnap } stabiliseResponse = Response { - responseTo = requestID aRequestPart + requestID = requestID aRequestPart , senderID = getNid nsSnap , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 , isFinalPart = False @@ -307,7 +308,7 @@ respondPing nsSTM msgSet = do aRequestPart = Set.elemAt 0 msgSet responsePayload = PingResponsePayload { pingNodeStates = [ toRemoteNodeState nsSnap ] } pingResponse = Response { - responseTo = requestID aRequestPart + requestID = requestID aRequestPart , senderID = getNid nsSnap , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 , isFinalPart = False @@ -343,7 +344,7 @@ respondJoin nsSTM msgSet = do , joinCache = toRemoteCache cache } joinResponse = Response { - responseTo = requestID aRequestPart + requestID = requestID aRequestPart , senderID = getNid joinedNS , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 , isFinalPart = False @@ -354,7 +355,7 @@ respondJoin nsSTM msgSet = do pure joinResponse -- otherwise respond with empty payload else pure Response { - responseTo = requestID aRequestPart + requestID = requestID aRequestPart , senderID = getNid nsSnap , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 , isFinalPart = False diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index c6348b3..d56a257 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -30,7 +30,7 @@ data FediChordMessage = Request , payload :: Maybe ActionPayload } | Response - { responseTo :: Integer + { requestID :: Integer , senderID :: NodeID , part :: Integer , isFinalPart :: Bool @@ -40,8 +40,12 @@ data FediChordMessage = Request deriving (Show, Eq) instance Ord FediChordMessage where - compare a b | requestID a == requestID b = part a `compare` part b + compare a@Request{} b@Request{} | requestID a == requestID b = part a `compare` part b | otherwise = requestID a `compare` requestID b + compare a@Response{} b@Response{} | requestID a == requestID b = part a `compare` part b + | otherwise = requestID a `compare` requestID b + -- comparing different constructor types always yields "not equal" + compare _ _ = LT data ActionPayload = QueryIDRequestPayload { queryTargetID :: NodeID diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index b6f08ad..146afcd 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -201,7 +201,7 @@ spec = do , payload = undefined } responseTemplate = Response { - responseTo = 2342 + requestID = 2342 , senderID = nid exampleNodeState , part = 1 , isFinalPart = True From 4e359775ec3d42e43e7640cc8bd8de3305590559 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 8 Jun 2020 20:31:22 +0200 Subject: [PATCH 3/3] add some debug output prints --- src/Hash2Pub/DHTProtocol.hs | 6 +++++- src/Hash2Pub/FediChord.hs | 2 ++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 626cd2b..64e4602 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -213,6 +213,7 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do -- | execute a key ID lookup on local cache and respond with the result respondQueryID :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) respondQueryID nsSTM msgSet = do + putStrLn "responding to a QueryID request" -- this message cannot be split reasonably, so just -- consider the first payload let @@ -487,7 +488,10 @@ sendRequestTo :: Int -- ^ timeout in seconds sendRequestTo timeoutMillis numAttempts msgIncomplete sock = do -- give the message a random request ID randomID <- randomRIO (0, 2^32-1) - let requests = serialiseMessage sendMessageSize $ msgIncomplete randomID + let + msgComplete = msgIncomplete randomID + requests = serialiseMessage sendMessageSize msgComplete + putStrLn $ "sending request message " <> show msgComplete -- create a queue for passing received response messages back, even after a timeout responseQ <- newTBQueueIO $ 2*maximumParts -- keep room for duplicate packets -- start sendAndAck with timeout diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 795772b..f66cafc 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -128,6 +128,7 @@ fediChordBootstrapJoin :: LocalNodeStateSTM -- ^ the local 'NodeSta fediChordBootstrapJoin nsSTM (joinHost, joinPort) = -- can be invoked multiple times with all known bootstrapping nodes until successfully joined bracket (mkSendSocket joinHost joinPort) close (\sock -> do + putStrLn "BootstrapJoin" -- 1. get routed to placement of own ID until FOUND: -- Initialise an empty cache only with the responses from a bootstrapping node ns <- readTVarIO nsSTM @@ -145,6 +146,7 @@ fediChordBootstrapJoin nsSTM (joinHost, joinPort) = Just (FORWARD resultset) -> foldr' (addCacheEntryPure now) cacheAcc resultset ) initCache bootstrapResponse + putStrLn "initialised bootstrap cache" fediChordJoin bootstrapCache nsSTM ) `catch` (\e -> pure . Left $ "Error at bootstrap joining: " <> displayException (e :: IOException))