forked from schmittlauch/Hash2Pub
fix off-by-one error in message splitting
This commit is contained in:
parent
0d91452641
commit
ca383420a6
|
@ -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,
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
}
|
||||
|
|
Loading…
Reference in a new issue