diff --git a/Hash2Pub/Hash2Pub.cabal b/Hash2Pub/Hash2Pub.cabal index 471a475..d487de4 100644 --- a/Hash2Pub/Hash2Pub.cabal +++ b/Hash2Pub/Hash2Pub.cabal @@ -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 diff --git a/Hash2Pub/src/Hash2Pub/ASN1Coding.hs b/Hash2Pub/src/Hash2Pub/ASN1Coding.hs index 8a2e76c..bf5a81a 100644 --- a/Hash2Pub/src/Hash2Pub/ASN1Coding.hs +++ b/Hash2Pub/src/Hash2Pub/ASN1Coding.hs @@ -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 ===== diff --git a/Hash2Pub/src/Hash2Pub/FediChord.hs b/Hash2Pub/src/Hash2Pub/FediChord.hs index 4a59689..19d8046 100644 --- a/Hash2Pub/src/Hash2Pub/FediChord.hs +++ b/Hash2Pub/src/Hash2Pub/FediChord.hs @@ -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 diff --git a/Hash2Pub/src/Hash2Pub/Utils.hs b/Hash2Pub/src/Hash2Pub/Utils.hs index 5e04a9c..f2e15ab 100644 --- a/Hash2Pub/src/Hash2Pub/Utils.hs +++ b/Hash2Pub/src/Hash2Pub/Utils.hs @@ -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