fix off-by-one error in message splitting

This commit is contained in:
Trolli Schmittlauch 2020-05-11 11:40:50 +02:00
parent 0d91452641
commit ca383420a6
3 changed files with 22 additions and 19 deletions

View file

@ -11,7 +11,7 @@ Request ::= SEQUENCE {
requestID INTEGER,
sender NodeState,
parts INTEGER, -- number of message parts
part INTEGER, -- part number of this message
part INTEGER, -- part number of this message, starts at 1
actionPayload CHOICE {
queryIDRequestPayload QueryIDRequestPayload,
joinRequestPayload JoinRequestPayload,

View file

@ -20,6 +20,9 @@ import Hash2Pub.FediChord
import Hash2Pub.Utils
import Hash2Pub.DHTProtocol
import Debug.Trace
-- TODO: make this splitting function more intelligent, currently it creates many parts that are smaller than they could be
-- | Try splitting a payload into multiple parts to be able to reduce size of
-- individual messages.
-- Only some kinds of payloads can be split, and only to a limited number of parts.
@ -30,29 +33,29 @@ splitPayload :: Int -- number of parts to split payload into
-> [ActionPayload] -- list of smaller payloads
splitPayload numParts pl@LeaveRequestPayload{} = [
LeaveRequestPayload {
leaveSuccessors = fromMaybe [] $ headMay . drop thisPart $ listInto numParts $ leaveSuccessors pl
, leavePredecessors = fromMaybe [] $ headMay . drop thisPart $ listInto numParts $ leavePredecessors pl
} | thisPart <- [0..numParts] ]
leaveSuccessors = atDef [] (listInto numParts $ leaveSuccessors pl) (thisPart-1)
, leavePredecessors = atDef [] (listInto numParts $ leavePredecessors pl) (thisPart-1)
} | thisPart <- [1..numParts] ]
splitPayload numParts pl@StabiliseResponsePayload{} = [
StabiliseResponsePayload {
stabiliseSuccessors = fromMaybe [] $ headMay . drop thisPart $ listInto numParts $ stabiliseSuccessors pl
, stabilisePredecessors = fromMaybe [] $ headMay . drop thisPart $ listInto numParts $ stabilisePredecessors pl
} | thisPart <- [0..numParts] ]
stabiliseSuccessors = atDef [] (listInto numParts $ stabiliseSuccessors pl) (thisPart-1)
, stabilisePredecessors = atDef [] (listInto numParts $ stabilisePredecessors pl) (thisPart-1)
} | thisPart <- [1..numParts] ]
splitPayload numParts pl@PingResponsePayload{} = [
PingResponsePayload {
pingNodeStates = fromMaybe [] $ headMay . drop thisPart $ listInto numParts $ pingNodeStates pl
} | thisPart <- [0..numParts] ]
pingNodeStates = atDef [] (listInto numParts $ pingNodeStates pl) (thisPart-1)
} | thisPart <- [1..numParts] ]
splitPayload numParts pl@JoinResponsePayload{} = [
JoinResponsePayload {
joinSuccessors = fromMaybe [] $ headMay . drop thisPart $ listInto numParts $ joinSuccessors pl
, joinPredecessors = fromMaybe [] $ headMay . drop thisPart $ listInto numParts $ joinPredecessors pl
, joinCache = fromMaybe [] $ headMay . drop thisPart $ listInto numParts $ joinCache pl
} | thisPart <- [0..numParts] ]
joinSuccessors = atDef [] (listInto numParts $ joinSuccessors pl) $ thisPart-1
, joinPredecessors = atDef [] (listInto numParts $ joinPredecessors pl) $ thisPart-1
, joinCache = atDef [] (listInto numParts $ joinCache pl) $ thisPart-1
} | thisPart <- [1..numParts] ]
splitPayload _ pl@(QueryIDResponsePayload FOUND{}) = [pl]
splitPayload numParts pl@(QueryIDResponsePayload (FORWARD resSet)) = [
QueryIDResponsePayload {
queryResult = maybe (FORWARD Set.empty) FORWARD $ headMay . drop thisPart $ setInto numParts resSet
} | thisPart <- [0..numParts] ]
queryResult = FORWARD $ atDef Set.empty (setInto numParts resSet) $ thisPart-1
} | thisPart <- [1..numParts] ]
-- pass all other payloads as-is
splitPayload _ somePayload = [somePayload]
@ -94,9 +97,9 @@ serialiseMessage maxBytesLength msg =
, payload = pl
, parts = fromIntegral i
}):pls
-- part starts at 0
-- part starts at 1
payloadParts :: Int -> [(Integer, ActionPayload)]
payloadParts i = zip [0..] (splitPayload i actionPayload)
payloadParts i = zip [1..] (splitPayload i actionPayload)
actionPayload = payload msg
encodedMsgs i = map (encodeASN1' DER . encodeMessage) $ messageParts i
maxMsgLength msgs = maximum $ map BS.length msgs

View file

@ -200,7 +200,7 @@ spec = do
requestID = 2342
, sender = exampleNodeState
, parts = 1
, part = 0
, part = 1
, action = undefined
, payload = undefined
}
@ -208,7 +208,7 @@ spec = do
responseTo = 2342
, senderID = nid exampleNodeState
, parts = 1
, part = 0
, part = 1
, action = undefined
, payload = undefined
}