diff --git a/FediChord.asn1 b/FediChord.asn1 index f978151..eb31730 100644 --- a/FediChord.asn1 +++ b/FediChord.asn1 @@ -11,7 +11,6 @@ Action ::= ENUMERATED {queryID, join, leave, stabilise, ping, queryLoad} Request ::= SEQUENCE { action Action, requestID INTEGER (0..4294967295), -- arbitrarily restricting to an unsigned 32bit integer - receiverID NodeID, sender NodeState, part Partnum, -- part number of this message, starts at 1 finalPart BOOLEAN, -- flag indicating this `part` to be the last of this reuest @@ -105,13 +104,13 @@ PingRequestPayload ::= NULL -- do not include a node/ vserver ID, so that PingResponsePayload ::= SEQUENCE OF NodeState LoadRequestPayload ::= SEQUENCE { - upperSegmentBound NodeID + lowerBound NodeID, + upperBound NodeID } LoadResponsePayload ::= SEQUENCE { loadSum REAL, - remainingLoadTarget REAL, - lowerBound NodeID + remainingLoadTarget REAL } END diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index 7701097..e29863e 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -186,14 +186,14 @@ encodePayload payload'@PingResponsePayload{} = <> [End Sequence] encodePayload payload'@LoadRequestPayload{} = [ Start Sequence - , IntVal . getNodeID $ loadSegmentUpperBound payload' + , IntVal . getNodeID $ loadLowerBound payload' + , IntVal . getNodeID $ loadUpperBound payload' , End Sequence ] encodePayload payload'@LoadResponsePayload{} = [ Start Sequence , Real $ loadSum payload' , Real $ loadRemainingTarget payload' - , IntVal . getNodeID $ loadSegmentLowerBound payload' , End Sequence ] @@ -227,11 +227,10 @@ encodeQueryResult FORWARD{} = Enumerated 1 encodeMessage :: FediChordMessage -- ^ the 'FediChordMessage to be encoded -> [ASN1] encodeMessage - (Request requestID receiverID sender part isFinalPart action requestPayload) = + (Request requestID sender part isFinalPart action requestPayload) = Start Sequence : (Enumerated . fromIntegral . fromEnum $ action) : IntVal requestID - : (IntVal . getNodeID $ receiverID) : encodeNodeState sender <> [IntVal part , Boolean isFinalPart] @@ -275,7 +274,6 @@ parseMessage = do parseRequest :: Action -> ParseASN1 FediChordMessage parseRequest action = do requestID <- parseInteger - receiverID' <- fromInteger <$> parseInteger sender <- parseNodeState part <- parseInteger isFinalPart <- parseBool @@ -288,7 +286,7 @@ parseRequest action = do Ping -> parsePingRequestPayload QueryLoad -> parseLoadRequestPayload - pure $ Request requestID receiverID' sender part isFinalPart action payload + pure $ Request requestID sender part isFinalPart action payload parseResponse :: Integer -> ParseASN1 FediChordMessage parseResponse requestID = do @@ -463,19 +461,19 @@ parsePingResponsePayload = onNextContainer Sequence $ do parseLoadRequestPayload :: ParseASN1 ActionPayload parseLoadRequestPayload = onNextContainer Sequence $ do + loadLowerBound' <- fromInteger <$> parseInteger loadUpperBound' <- fromInteger <$> parseInteger pure LoadRequestPayload - { loadSegmentUpperBound = loadUpperBound' + { loadLowerBound = loadLowerBound' + , loadUpperBound = loadUpperBound' } parseLoadResponsePayload :: ParseASN1 ActionPayload parseLoadResponsePayload = onNextContainer Sequence $ do loadSum' <- parseReal loadRemainingTarget' <- parseReal - loadSegmentLowerBound' <- fromInteger <$> parseInteger pure LoadResponsePayload { loadSum = loadSum' , loadRemainingTarget = loadRemainingTarget' - , loadSegmentLowerBound = loadSegmentLowerBound' } diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 38c0dcb..37a1dea 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -15,7 +15,6 @@ module Hash2Pub.DHTProtocol , Action(..) , ActionPayload(..) , FediChordMessage(..) - , mkRequest , maximumParts , sendQueryIdMessages , requestQueryID @@ -485,21 +484,6 @@ respondJoin nsSTM msgSet = do -- ....... request sending ....... --- | defautl constructor for request messages, fills standard values like --- part number to avoid code repition -mkRequest :: LocalNodeState s -> NodeID -> Action -> Maybe ActionPayload -> (Integer -> FediChordMessage) -mkRequest ns targetID action pl rid = Request - { requestID = rid - , receiverID = targetID - , sender = toRemoteNodeState ns - -- part number and final flag can be changed by ASN1 encoder to make packet - -- fit the MTU restrictions - , part = 1 - , isFinalPart = True - , action = action - , payload = pl - } - -- | send a join request and return the joined 'LocalNodeState' including neighbours requestJoin :: (NodeState a, Service s (RealNodeSTM s)) => a -- ^ currently responsible node to be contacted -> LocalNodeStateSTM s -- ^ joining NodeState @@ -511,7 +495,7 @@ requestJoin toJoinOn ownStateSTM = do let srcAddr = confIP nodeConf bracket (mkSendSocket srcAddr (getDomain toJoinOn) (getDhtPort toJoinOn)) close (\sock -> do -- extract own state for getting request information - responses <- sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (mkRequest ownState (getNid toJoinOn) Join (Just JoinRequestPayload)) sock + responses <- sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid -> Request rid (toRemoteNodeState ownState) 1 True Join (Just JoinRequestPayload)) sock (cacheInsertQ, joinedState) <- atomically $ do stateSnap <- readTVar ownStateSTM let @@ -644,7 +628,7 @@ lookupMessage :: Integral i -> LocalNodeState s -- ^ sender node state -> Maybe i -- ^ optionally provide a different l parameter -> (Integer -> FediChordMessage) -lookupMessage targetID ns lParam = mkRequest ns targetID QueryID (Just $ pl ns targetID) +lookupMessage targetID ns lParam = \rID -> Request rID (toRemoteNodeState ns) 1 True QueryID (Just $ pl ns targetID) where pl ns' targetID' = QueryIDRequestPayload { queryTargetID = targetID', queryLBestNodes = maybe (fromIntegral $ lNumBestNodes ns) fromIntegral lParam } @@ -657,7 +641,16 @@ requestStabilise :: LocalNodeState s -- ^ sending node requestStabilise ns neighbour = do nodeConf <- nodeConfig <$> readTVarIO (parentRealNode ns) let srcAddr = confIP nodeConf - responses <- bracket (mkSendSocket srcAddr (getDomain neighbour) (getDhtPort neighbour)) close (fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (mkRequest ns (getNid neighbour) Stabilise (Just StabiliseRequestPayload)) + responses <- bracket (mkSendSocket srcAddr (getDomain neighbour) (getDhtPort neighbour)) close (fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid -> + Request { + requestID = rid + , sender = toRemoteNodeState ns + , part = 1 + , isFinalPart = False + , action = Stabilise + , payload = Just StabiliseRequestPayload + } + ) ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) either -- forward IO error messages @@ -692,12 +685,17 @@ requestLeave ns doMigration target = do , leavePredecessors = predecessors ns , leaveDoMigration = doMigration } - responses <- bracket - (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) - close - (fmap Right - . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (mkRequest ns (getNid target) Leave (Just leavePayload)) - ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) + responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close (fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid -> + Request { + requestID = rid + , sender = toRemoteNodeState ns + , part = 1 + , isFinalPart = False + , action = Leave + , payload = Just leavePayload + } + ) + ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) either -- forward IO error messages (pure . Left) @@ -713,7 +711,16 @@ requestPing ns target = do let srcAddr = confIP nodeConf responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close (\sock -> do - resp <- sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (mkRequest ns (getNid target) Ping (Just PingRequestPayload)) sock + resp <- sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid -> + Request { + requestID = rid + , sender = toRemoteNodeState ns + , part = 1 + , isFinalPart = False + , action = Ping + , payload = Just PingRequestPayload + } + ) sock (SockAddrInet6 _ _ peerAddr _) <- getPeerName sock pure $ Right (peerAddr, resp) ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) @@ -744,21 +751,32 @@ requestPing ns target = do requestQueryLoad :: (MonadError String m, MonadIO m) => LocalNodeState s -> NodeID + -> NodeID -> RemoteNodeState -> m SegmentLoadStats -requestQueryLoad ns upperIdBound target = do +requestQueryLoad ns lowerIdBound upperIdBound target = do nodeConf <- nodeConfig <$> liftIO (readTVarIO $ parentRealNode ns) let srcAddr = confIP nodeConf - loadReqPl = LoadRequestPayload - { loadSegmentUpperBound = upperIdBound + loadPl = LoadRequestPayload + { loadLowerBound = lowerIdBound + , loadUpperBound = upperIdBound } responses <- liftIO $ bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close - (fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (mkRequest ns (getNid target) QueryLoad (Just loadReqPl)) + (fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid -> + Request { + requestID = rid + , sender = toRemoteNodeState ns + , part = 1 + , isFinalPart = False + , action = QueryLoad + , payload = Just loadPl + } + ) ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) responseMsgSet <- liftEither responses -- throws an error if an exception happened - loadResPl <- maybe (throwError "no load response payload found") pure + loadPl <- maybe (throwError "no load response payload found") pure (foldr' (\msg acc -> case payload msg of -- just extract the first found LoadResponsePayload Just pl@LoadResponsePayload{} | isNothing acc -> Just pl @@ -768,10 +786,10 @@ requestQueryLoad ns upperIdBound target = do responseMsgSet ) pure SegmentLoadStats - { segmentLowerKeyBound = loadSegmentLowerBound loadResPl + { segmentLowerKeyBound = lowerIdBound , segmentUpperKeyBound = upperIdBound - , segmentLoad = loadSum loadResPl - , segmentOwnerLoadTarget = loadRemainingTarget loadResPl + , segmentLoad = loadSum loadPl + , segmentOwnerLoadTarget = loadRemainingTarget loadPl } diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index b5438fa..e7f1e3c 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -21,7 +21,6 @@ data Action = QueryID data FediChordMessage = Request { requestID :: Integer - , receiverID :: NodeID , sender :: RemoteNodeState , part :: Integer , isFinalPart :: Bool @@ -59,10 +58,6 @@ data ActionPayload = QueryIDRequestPayload } | StabiliseRequestPayload | PingRequestPayload - | LoadRequestPayload - { loadSegmentUpperBound :: NodeID - -- ^ upper bound of segment interested in, - } | QueryIDResponsePayload { queryResult :: QueryResponse } @@ -79,10 +74,13 @@ data ActionPayload = QueryIDRequestPayload | PingResponsePayload { pingNodeStates :: [RemoteNodeState] } + | LoadRequestPayload + { loadLowerBound :: NodeID + , loadUpperBound :: NodeID + } | LoadResponsePayload - { loadSum :: Double - , loadRemainingTarget :: Double - , loadSegmentLowerBound :: NodeID + { loadSum :: Double + , loadRemainingTarget :: Double } deriving (Show, Eq) diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 5130ab1..8756b69 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -222,14 +222,21 @@ spec = do ] } qLoadReqPayload = LoadRequestPayload - { loadSegmentUpperBound = 1025 + { loadLowerBound = fromInteger 12 + , loadUpperBound = fromInteger 1025 } qLoadResPayload = LoadResponsePayload { loadSum = 3.141 , loadRemainingTarget = -1.337 - , loadSegmentLowerBound = 12 } - + requestTemplate = Request { + requestID = 2342 + , sender = exampleNodeState + , part = 1 + , isFinalPart = True + , action = undefined + , payload = undefined + } responseTemplate = Response { requestID = 2342 , senderID = nid exampleNodeState @@ -238,7 +245,7 @@ spec = do , action = undefined , payload = undefined } - requestWith senderNode a pa = mkRequest senderNode 4545 a (Just pa) $ 2342 + requestWith a pa = requestTemplate {action = a, payload = Just pa} responseWith a pa = responseTemplate {action = a, payload = Just pa} encodeDecodeAndCheck msg = runParseASN1 parseMessage (encodeMessage msg) `shouldBe` pure msg @@ -249,19 +256,18 @@ spec = do } it "messages are encoded and decoded correctly from and to ASN1" $ do - localNS <- exampleLocalNode - encodeDecodeAndCheck $ requestWith localNS QueryID qidReqPayload - encodeDecodeAndCheck $ requestWith localNS Join jReqPayload - encodeDecodeAndCheck $ requestWith localNS Leave lReqPayload - encodeDecodeAndCheck $ requestWith localNS Stabilise stabReqPayload - encodeDecodeAndCheck $ requestWith localNS Ping pingReqPayload - encodeDecodeAndCheck $ requestWith localNS QueryLoad qLoadReqPayload + encodeDecodeAndCheck $ requestWith QueryID qidReqPayload + encodeDecodeAndCheck $ requestWith Join jReqPayload + encodeDecodeAndCheck $ requestWith Leave lReqPayload + encodeDecodeAndCheck $ requestWith Stabilise stabReqPayload + encodeDecodeAndCheck $ requestWith Ping pingReqPayload encodeDecodeAndCheck $ responseWith QueryID qidResPayload1 encodeDecodeAndCheck $ responseWith QueryID qidResPayload2 encodeDecodeAndCheck $ responseWith Join jResPayload encodeDecodeAndCheck $ responseWith Leave lResPayload encodeDecodeAndCheck $ responseWith Stabilise stabResPayload encodeDecodeAndCheck $ responseWith Ping pingResPayload + encodeDecodeAndCheck $ requestWith QueryLoad qLoadReqPayload encodeDecodeAndCheck $ responseWith QueryLoad qLoadResPayload it "messages are encoded and decoded to ASN.1 DER properly" $ deserialiseMessage (fromJust $ Map.lookup 1 (serialiseMessage 652 $ responseWith Ping pingResPayload)) `shouldBe` Right (responseWith Ping pingResPayload)