forked from schmittlauch/Hash2Pub
split FediChord messages into multiple parts for size restrictions
includes encoding of messages as ASN.1 DER
This commit is contained in:
parent
1d8d9a33fd
commit
31b73b7667
|
|
@ -46,7 +46,7 @@ category: Network
|
|||
extra-source-files: CHANGELOG.md
|
||||
|
||||
common deps
|
||||
build-depends: base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order
|
||||
build-depends: base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe
|
||||
ghc-options: -Wall
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -12,8 +12,10 @@ import Data.Time.Clock.POSIX
|
|||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Safe
|
||||
|
||||
import Hash2Pub.FediChord
|
||||
import Hash2Pub.Utils
|
||||
import Hash2Pub.DHTProtocol (QueryResponse (..))
|
||||
|
||||
data Action =
|
||||
|
|
@ -74,12 +76,147 @@ data ActionPayload =
|
|||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- ToDo: pagination so packets do not exceed maximum size
|
||||
-- probably should be taken care of by the callers of this, as the ASN.1
|
||||
-- encoding functions are layer-4 agnostic
|
||||
-- | 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.
|
||||
-- This function only deals with potentially large payload types and passes the
|
||||
-- rest as-is.
|
||||
splitPayload :: Int -> ActionPayload -> [ActionPayload]
|
||||
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] ]
|
||||
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] ]
|
||||
splitPayload numParts pl@PingResponsePayload{} = [
|
||||
PingResponsePayload {
|
||||
pingNodeStates = fromMaybe [] $ headMay . drop thisPart $ listInto numParts $ pingNodeStates pl
|
||||
} | thisPart <- [0..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] ]
|
||||
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] ]
|
||||
-- pass all other payloads as-is
|
||||
splitPayload _ somePayload = [somePayload]
|
||||
|
||||
listInto :: Int -> [a] -> [[a]]
|
||||
listInto numParts xs = chunksOf (chunkLength numParts $ length xs) xs
|
||||
|
||||
setInto :: Int -> Set.Set a -> [Set.Set a]
|
||||
setInto numParts aSet = chunkSet (chunkLength numParts $ Set.size aSet) aSet
|
||||
|
||||
chunkLength :: Int -> Int -> Int
|
||||
chunkLength numParts totalSize = ceiling $ (realToFrac totalSize :: Double) / realToFrac numParts
|
||||
|
||||
-- | Serialise a 'FediChordMessage' to one or more parts represented as a 'BS.ByteString' in ASN.1 DER,
|
||||
-- such that their length does not exceed a maximum number of bytes if possible.
|
||||
-- This is important for making sure the message fits into a certain packet size.
|
||||
-- The number of parts per message is limited to 150 for DOS protection reasons.
|
||||
-- The returned byte strings might exceed the desired maximum length, as only the payload (and not all of them)
|
||||
-- can be split into multiple parts.
|
||||
serialiseMessage :: FediChordMessage -> Int -> [BS.ByteString]
|
||||
serialiseMessage msg maxBytesLength =
|
||||
splitPayloadUntilSmallEnough 1
|
||||
where
|
||||
splitPayloadUntilSmallEnough numParts
|
||||
| maxMsgLength (encodedMsgs numParts) <= maxBytesLength = encodedMsgs numParts
|
||||
-- ToDo: log this
|
||||
-- limit to maximum number of parts to reduce DOS-potential of repeated
|
||||
-- splitting
|
||||
| numParts == maximumParts = encodedMsgs numParts
|
||||
| otherwise = splitPayloadUntilSmallEnough $ numParts + 1
|
||||
messageParts :: Int -> [FediChordMessage]
|
||||
messageParts i = foldr (modifyMessage i) [] $ payloadParts i
|
||||
-- insert payload parts into message and adjust parts metadata
|
||||
modifyMessage :: Int -> (Integer, ActionPayload) -> [FediChordMessage] -> [FediChordMessage]
|
||||
modifyMessage i (partNum, pl) pls = (msg {
|
||||
part = partNum
|
||||
, payload = pl
|
||||
, parts = fromIntegral i
|
||||
}):pls
|
||||
-- part starts at 0
|
||||
payloadParts :: Int -> [(Integer, ActionPayload)]
|
||||
payloadParts i = zip [0..] (splitPayload i actionPayload)
|
||||
actionPayload = payload msg
|
||||
encodedMsgs i = map (encodeASN1' DER . encodeMessage) $ messageParts i
|
||||
maxMsgLength msgs = maximum $ map BS.length msgs
|
||||
maximumParts = 150
|
||||
|
||||
-- ===== encoding functions =====
|
||||
|
||||
encodePayload :: ActionPayload -> [ASN1]
|
||||
encodePayload LeaveResponsePayload = [Null]
|
||||
encodePayload payload@LeaveRequestPayload{} =
|
||||
Start Sequence
|
||||
: Start Sequence
|
||||
: (map (IntVal . getNodeID) $ leaveSuccessors payload)
|
||||
++ [End Sequence
|
||||
, Start Sequence]
|
||||
++ (map (IntVal . getNodeID) $ leavePredecessors payload)
|
||||
++ [End Sequence
|
||||
, End Sequence]
|
||||
-- currently StabiliseResponsePayload and LeaveRequestPayload are equal
|
||||
encodePayload payload@StabiliseResponsePayload{} =
|
||||
Start Sequence
|
||||
: Start Sequence
|
||||
: (map (IntVal . getNodeID) $ stabiliseSuccessors payload)
|
||||
++ [End Sequence
|
||||
, Start Sequence]
|
||||
++ (map (IntVal . getNodeID) $ stabilisePredecessors payload)
|
||||
++ [End Sequence
|
||||
, End Sequence]
|
||||
encodePayload payload@StabiliseRequestPayload = [Null]
|
||||
encodePayload payload@QueryIDResponsePayload{} =
|
||||
let
|
||||
resp = queryResult payload
|
||||
in
|
||||
Start Sequence
|
||||
: encodeQueryResult resp
|
||||
: case resp of
|
||||
FOUND _ -> []
|
||||
FORWARD entrySet ->
|
||||
Start Sequence
|
||||
: (concatMap encodeCacheEntry . Set.elems $ entrySet)
|
||||
++ [End Sequence]
|
||||
++ [End Sequence]
|
||||
encodePayload payload@QueryIDResponsePayload{} = [
|
||||
Start Sequence
|
||||
, IntVal . getNodeID $ queryTargetID payload
|
||||
, IntVal $ queryLBestNodes payload
|
||||
, End Sequence
|
||||
]
|
||||
-- | encodes the @JoinResponsePayload@ ASN.1 type
|
||||
encodePayload payload@JoinResponsePayload{} =
|
||||
Start Sequence
|
||||
: Start Sequence
|
||||
: (map (IntVal . getNodeID) $ joinSuccessors payload)
|
||||
++ [End Sequence
|
||||
, Start Sequence]
|
||||
++ (map (IntVal . getNodeID) $ joinPredecessors payload)
|
||||
++ [End Sequence
|
||||
, Start Sequence]
|
||||
++ (concatMap encodeCacheEntry $ joinCache payload)
|
||||
++ [End Sequence
|
||||
, End Sequence]
|
||||
encodePayload payload@JoinRequestPayload{} = [Null]
|
||||
encodePayload PingRequestPayload{} = [Null]
|
||||
encodePayload payload@PingResponsePayload{} =
|
||||
Start Sequence
|
||||
: (concatMap encodeNodeState $ pingNodeStates payload)
|
||||
++ [End Sequence]
|
||||
|
||||
|
||||
encodeNodeState :: NodeState -> [ASN1]
|
||||
encodeNodeState ns = [
|
||||
Start Sequence
|
||||
|
|
@ -102,100 +239,15 @@ encodeCacheEntry (NodeEntry _ ns timestamp) =
|
|||
, End Sequence]
|
||||
encodeCacheEntry _ = []
|
||||
|
||||
encodeLeaveResponsePayload :: ActionPayload -> [ASN1]
|
||||
encodeLeaveResponsePayload LeaveResponsePayload = [Null]
|
||||
|
||||
encodeLeaveRequestPayload :: ActionPayload -> [ASN1]
|
||||
encodeLeaveRequestPayload payload@LeaveRequestPayload{} =
|
||||
Start Sequence
|
||||
: Start Sequence
|
||||
: (map (IntVal . getNodeID) $ leaveSuccessors payload)
|
||||
++ [End Sequence
|
||||
, Start Sequence]
|
||||
++ (map (IntVal . getNodeID) $ leavePredecessors payload)
|
||||
++ [End Sequence
|
||||
, End Sequence]
|
||||
|
||||
-- currently StabiliseResponsePayload and LeaveRequestPayload are equal
|
||||
encodeStabiliseResponsePayload :: ActionPayload -> [ASN1]
|
||||
encodeStabiliseResponsePayload payload@StabiliseResponsePayload{} =
|
||||
Start Sequence
|
||||
: Start Sequence
|
||||
: (map (IntVal . getNodeID) $ stabiliseSuccessors payload)
|
||||
++ [End Sequence
|
||||
, Start Sequence]
|
||||
++ (map (IntVal . getNodeID) $ stabilisePredecessors payload)
|
||||
++ [End Sequence
|
||||
, End Sequence]
|
||||
|
||||
encodeStabiliseRequestPayload :: ActionPayload -> [ASN1]
|
||||
encodeStabiliseRequestPayload payload@StabiliseRequestPayload = [Null]
|
||||
|
||||
encodeQueryResult :: QueryResponse -> ASN1
|
||||
encodeQueryResult FOUND{} = Enumerated 0
|
||||
encodeQueryResult FORWARD{} = Enumerated 1
|
||||
|
||||
encodeQueryIDResponsePayload :: ActionPayload -> [ASN1]
|
||||
encodeQueryIDResponsePayload payload@QueryIDResponsePayload{} =
|
||||
let
|
||||
resp = queryResult payload
|
||||
in
|
||||
Start Sequence
|
||||
: encodeQueryResult resp
|
||||
: case resp of
|
||||
FOUND _ -> []
|
||||
FORWARD entrySet ->
|
||||
Start Sequence
|
||||
: (concatMap encodeCacheEntry . Set.elems $ entrySet)
|
||||
++ [End Sequence]
|
||||
++ [End Sequence]
|
||||
|
||||
encodeQueryIDRequestPayload :: ActionPayload -> [ASN1]
|
||||
encodeQueryIDRequestPayload payload@QueryIDResponsePayload{} = [
|
||||
Start Sequence
|
||||
, IntVal . getNodeID $ queryTargetID payload
|
||||
, IntVal $ queryLBestNodes payload
|
||||
, End Sequence
|
||||
]
|
||||
|
||||
-- | encodes the @JoinResponsePayload@ ASN.1 type
|
||||
encodeJoinResponsePayload :: ActionPayload -> [ASN1]
|
||||
encodeJoinResponsePayload payload@JoinResponsePayload{} =
|
||||
Start Sequence
|
||||
: Start Sequence
|
||||
: (map (IntVal . getNodeID) $ joinSuccessors payload)
|
||||
++ [End Sequence
|
||||
, Start Sequence]
|
||||
++ (map (IntVal . getNodeID) $ joinPredecessors payload)
|
||||
++ [End Sequence
|
||||
, Start Sequence]
|
||||
++ (concatMap encodeCacheEntry $ joinCache payload)
|
||||
++ [End Sequence
|
||||
, End Sequence]
|
||||
|
||||
encodeJoinRequestPayload :: ActionPayload -> [ASN1]
|
||||
encodeJoinRequestPayload payload@JoinRequestPayload{} = [Null]
|
||||
|
||||
encodePingRequestPayload :: ActionPayload -> [ASN1]
|
||||
encodePingRequestPayload PingRequestPayload{} = [Null]
|
||||
|
||||
encodePingResponsePayload :: ActionPayload -> [ASN1]
|
||||
encodePingResponsePayload payload@PingResponsePayload{} =
|
||||
Start Sequence
|
||||
: (concatMap encodeNodeState $ pingNodeStates payload)
|
||||
++ [End Sequence]
|
||||
|
||||
-- | Encode a 'FediChordMessage' as ASN.1.
|
||||
-- The 'ActionPayload' needs to be passed separately, already encoded as ASN.1,
|
||||
-- to allow controlling message size by splitting the payload into multiple parts.
|
||||
encodeMessage :: FediChordMessage -- ^ the 'FediChordMessage to be encoded, the
|
||||
-- contained 'payload' is ignored
|
||||
-> [ASN1] -- ^ the ASN.1 encoding of
|
||||
-- the message's 'payload'
|
||||
encodeMessage :: FediChordMessage -- ^ the 'FediChordMessage to be encoded
|
||||
-> [ASN1]
|
||||
encodeMessage
|
||||
(Request requestID sender parts part action _)
|
||||
payload =
|
||||
(Request requestID sender parts part action requestPayload) =
|
||||
Start Sequence
|
||||
: (Enumerated . fromIntegral . fromEnum $ action)
|
||||
: IntVal requestID
|
||||
|
|
@ -203,17 +255,16 @@ encodeMessage
|
|||
++ [
|
||||
IntVal parts
|
||||
, IntVal part ]
|
||||
++ payload
|
||||
++ encodePayload requestPayload
|
||||
encodeMessage
|
||||
(Response responseTo senderID parts part action _)
|
||||
payload = [
|
||||
(Response responseTo senderID parts part action responsePayload) = [
|
||||
Start Sequence
|
||||
, IntVal responseTo
|
||||
, IntVal . getNodeID $ senderID
|
||||
, IntVal parts
|
||||
, IntVal part
|
||||
, Enumerated . fromIntegral . fromEnum $ action]
|
||||
++ payload
|
||||
++ encodePayload responsePayload
|
||||
|
||||
-- ===== parser combinators =====
|
||||
|
||||
|
|
|
|||
|
|
@ -326,11 +326,7 @@ ipAddrAsBS (a, b, c, d) = mconcat $ map NetworkBytes.bytestring32 [a, b, c, d]
|
|||
bsAsIpAddr :: BS.ByteString -> HostAddress6
|
||||
bsAsIpAddr bytes = (a,b,c,d)
|
||||
where
|
||||
a:b:c:d:_ = map NetworkBytes.word32 . fourBytes $ bytes
|
||||
fourBytes bs =
|
||||
case BS.splitAt 4 bs of
|
||||
(a, "") -> [a]
|
||||
(a, b) -> a: fourBytes b
|
||||
a:b:c:d:_ = map NetworkBytes.word32 . chunkBytes 4 $ bytes
|
||||
|
||||
|
||||
-- | generates a 256 bit long NodeID using SHAKE128, represented as ByteString
|
||||
|
|
|
|||
|
|
@ -1,6 +1,36 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Hash2Pub.Utils where
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Set as Set
|
||||
|
||||
-- |wraps a list into a Maybe, by replacing empty lists with Nothing
|
||||
maybeEmpty :: [a] -> Maybe [a]
|
||||
maybeEmpty [] = Nothing
|
||||
maybeEmpty nonemptyList = Just nonemptyList
|
||||
|
||||
-- | Chop a list into sublists of i elements. The last sublist might contain
|
||||
-- less than i elements.
|
||||
chunksOf :: Int -> [a] -> [[a]]
|
||||
chunksOf i xs =
|
||||
case splitAt i xs of
|
||||
(a, []) -> [a]
|
||||
(a, b) -> a : chunksOf i b
|
||||
|
||||
|
||||
-- | Chop a 'BS.ByteString' into list of substrings of i elements. The last
|
||||
-- substring might contain less than i elements.
|
||||
chunkBytes :: Int -> BS.ByteString -> [BS.ByteString]
|
||||
chunkBytes i xs =
|
||||
case BS.splitAt i xs of
|
||||
(a, "") -> [a]
|
||||
(a, b) -> a : chunkBytes i b
|
||||
|
||||
-- | Chop a 'Set.Set' into a list of disjuct subsets of i elements. The last
|
||||
-- subset might contain less than i elements.
|
||||
chunkSet :: Int -> Set.Set a -> [Set.Set a]
|
||||
chunkSet i xs
|
||||
| Set.null . snd $ splitSet = [fst splitSet]
|
||||
| otherwise = fst splitSet : chunkSet i (snd splitSet)
|
||||
where
|
||||
splitSet = Set.splitAt i xs
|
||||
|
|
|
|||
Loading…
Reference in a new issue