split FediChord messages into multiple parts for size restrictions

includes encoding of messages as ASN.1 DER

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
 
 

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
+-- | Try splitting a payload into multiple parts to be able to reduce size of
--- probably should be taken care of by the callers of this, as the ASN.1
+-- individual messages.
--- encoding functions are layer-4 agnostic
+-- 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,
+encodeMessage :: FediChordMessage   -- ^ the 'FediChordMessage to be encoded
--- 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'
               -> [ASN1]
 encodeMessage
-    (Request requestID sender parts part action _)
+    (Request requestID sender parts part action requestPayload) =
-    payload =
         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 _)
+    (Response responseTo senderID parts part action responsePayload) = [
-    payload = [
         Start Sequence
       , IntVal responseTo
       , IntVal . getNodeID $ senderID
       , IntVal parts
       , IntVal part
       , Enumerated . fromIntegral . fromEnum $ action]
-      ++ payload
+      ++ encodePayload responsePayload
 
 -- ===== parser combinators =====
 

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 
+        a:b:c:d:_ = map NetworkBytes.word32 . chunkBytes 4 $ bytes 
-        fourBytes bs =
-            case BS.splitAt 4 bs of
-              (a, "") -> [a]
-              (a, b) -> a: fourBytes b
 
 
 -- | generates a 256 bit long NodeID using SHAKE128, represented as ByteString

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