431 lines
17 KiB
Haskell
431 lines
17 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Hash2Pub.ASN1Coding where
|
|
|
|
import Control.Exception (displayException)
|
|
import Data.ASN1.BinaryEncoding
|
|
import Data.ASN1.Encoding
|
|
import Data.ASN1.Error ()
|
|
import Data.ASN1.Parse
|
|
import Data.ASN1.Types
|
|
import Data.Bifunctor (first)
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Maybe (fromMaybe, isNothing, mapMaybe)
|
|
import qualified Data.Set as Set
|
|
import Data.Time.Clock.POSIX ()
|
|
import Safe
|
|
|
|
import Hash2Pub.DHTProtocol
|
|
import Hash2Pub.FediChord
|
|
import Hash2Pub.Utils
|
|
|
|
import Debug.Trace
|
|
|
|
-- TODO: make this splitting function more intelligent, currently it creates many parts that are smaller than they could be, see #18
|
|
-- | 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.
|
|
--
|
|
-- The common IPv6 path MTU is 1280 bytes. When substracting 40 bytes TCP header (minimum) and 8 bytes UDP header, that gives remaining 1232 bytes for the payload.
|
|
-- Leaving room for IPv6 header extensions, 1200 bytes appear to be a good default.
|
|
splitPayload :: Int -- number of parts to split payload into
|
|
-> ActionPayload -- payload to be split
|
|
-> [ActionPayload] -- list of smaller payloads
|
|
splitPayload numParts pl@LeaveRequestPayload{} = [
|
|
LeaveRequestPayload {
|
|
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 = atDef [] (listInto numParts $ stabiliseSuccessors pl) (thisPart-1)
|
|
, stabilisePredecessors = atDef [] (listInto numParts $ stabilisePredecessors pl) (thisPart-1)
|
|
} | thisPart <- [1..numParts] ]
|
|
splitPayload numParts pl@PingResponsePayload{} = [
|
|
PingResponsePayload {
|
|
pingNodeStates = atDef [] (listInto numParts $ pingNodeStates pl) (thisPart-1)
|
|
} | thisPart <- [1..numParts] ]
|
|
splitPayload numParts pl@JoinResponsePayload{} = [
|
|
JoinResponsePayload {
|
|
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 = FORWARD $ atDef Set.empty (setInto numParts resSet) $ thisPart-1
|
|
} | thisPart <- [1..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 :: Int -- maximum message size in bytes
|
|
-> FediChordMessage -- mesage to be serialised in preparation for sending
|
|
-> Map.Map Integer BS.ByteString -- list of ASN.1 DER encoded messages together representing
|
|
-- the contents of the input message
|
|
-- messages without payload are not split
|
|
serialiseMessage _ msg | isNothing (payload msg) = Map.singleton 1 $ encodeMsg msg
|
|
serialiseMessage maxBytesLength msg =
|
|
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 -> Map.Map Integer FediChordMessage
|
|
messageParts i = Map.fromAscList $ foldr (modifyMessage i) [] $ fromMaybe [] $ payloadParts i
|
|
-- insert payload parts into message and adjust parts metadata
|
|
modifyMessage :: Int -> (Integer, ActionPayload) -> [(Integer, FediChordMessage)] -> [(Integer, FediChordMessage)]
|
|
modifyMessage i (partNum, pl) pls = (partNum, msg {
|
|
part = partNum
|
|
, payload = Just pl
|
|
, parts = fromIntegral i
|
|
}):pls
|
|
-- part starts at 1
|
|
payloadParts :: Int -> Maybe [(Integer, ActionPayload)]
|
|
payloadParts i = zip [1..] . splitPayload i <$> actionPayload
|
|
actionPayload = payload msg
|
|
encodedMsgs i = Map.map encodeMsg $ messageParts i
|
|
maxMsgLength = maximum . fmap BS.length . Map.elems
|
|
|
|
-- | encode a 'FediChordMessage' to a bytestring without further modification
|
|
encodeMsg :: FediChordMessage -> BS.ByteString
|
|
encodeMsg = encodeASN1' DER . encodeMessage
|
|
|
|
-- | Deserialise a ASN.1 DER encoded bytesstring of a single 'FediChordMessage'.
|
|
deserialiseMessage :: BS.ByteString
|
|
-> Either String FediChordMessage
|
|
deserialiseMessage msgBytes = first displayException (decodeASN1' DER msgBytes) >>= runParseASN1 parseMessage
|
|
|
|
-- ===== encoding functions =====
|
|
|
|
-- encode a message 'ActionPayload' according to its type,
|
|
-- indicated by the data constructor, as ASN.1
|
|
encodePayload :: ActionPayload -> [ASN1]
|
|
encodePayload LeaveResponsePayload = [Null]
|
|
encodePayload payload'@LeaveRequestPayload{} =
|
|
Start Sequence
|
|
: Start Sequence
|
|
: fmap (IntVal . getNodeID) (leaveSuccessors payload')
|
|
<> [End Sequence
|
|
, Start Sequence]
|
|
<> fmap (IntVal . getNodeID) (leavePredecessors payload')
|
|
<> [End Sequence
|
|
, End Sequence]
|
|
-- currently StabiliseResponsePayload and LeaveRequestPayload are equal
|
|
encodePayload payload'@StabiliseResponsePayload{} =
|
|
Start Sequence
|
|
: Start Sequence
|
|
: fmap (IntVal . getNodeID) (stabiliseSuccessors payload')
|
|
<> [End Sequence
|
|
, Start Sequence]
|
|
<> fmap (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 ns -> encodeNodeState ns
|
|
FORWARD entrySet ->
|
|
Start Sequence
|
|
: (concatMap encodeCacheEntry . Set.elems $ entrySet)
|
|
<> [End Sequence]
|
|
<> [End Sequence]
|
|
encodePayload payload'@QueryIDRequestPayload{} = [
|
|
Start Sequence
|
|
, IntVal . getNodeID $ queryTargetID payload'
|
|
, IntVal $ queryLBestNodes payload'
|
|
, End Sequence
|
|
]
|
|
-- | encodes the @JoinResponsePayload@ ASN.1 type
|
|
encodePayload payload'@JoinResponsePayload{} =
|
|
Start Sequence
|
|
: Start Sequence
|
|
: fmap (IntVal . getNodeID) (joinSuccessors payload')
|
|
<> [End Sequence
|
|
, Start Sequence]
|
|
<> fmap (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
|
|
, IntVal (getNodeID . nid $ ns)
|
|
, ASN1String . asn1CharacterString Visible $ domain ns
|
|
, OctetString (ipAddrAsBS $ ipAddr ns)
|
|
, IntVal (toInteger . dhtPort $ ns)
|
|
, IntVal (maybe 0 toInteger $ apPort ns)
|
|
, IntVal (vServerID ns)
|
|
, End Sequence
|
|
]
|
|
|
|
encodeCacheEntry :: RemoteCacheEntry -> [ASN1]
|
|
encodeCacheEntry (RemoteCacheEntry ns timestamp) =
|
|
Start Sequence
|
|
: encodeNodeState ns
|
|
-- ToDo: possibly optimise this by using dlists
|
|
<> [
|
|
IntVal . fromIntegral . fromEnum $ timestamp
|
|
, End Sequence]
|
|
encodeCacheEntry _ = []
|
|
|
|
encodeQueryResult :: QueryResponse -> ASN1
|
|
encodeQueryResult FOUND{} = Enumerated 0
|
|
encodeQueryResult FORWARD{} = Enumerated 1
|
|
|
|
-- | Encode a 'FediChordMessage' as ASN.1.
|
|
encodeMessage :: FediChordMessage -- ^ the 'FediChordMessage to be encoded
|
|
-> [ASN1]
|
|
encodeMessage
|
|
(Request requestID sender parts part action requestPayload) =
|
|
Start Sequence
|
|
: (Enumerated . fromIntegral . fromEnum $ action)
|
|
: IntVal requestID
|
|
: encodeNodeState sender
|
|
<> [
|
|
IntVal parts
|
|
, IntVal part ]
|
|
<> maybe [] encodePayload requestPayload
|
|
<> [End Sequence]
|
|
encodeMessage
|
|
(Response responseTo senderID parts part action responsePayload) = [
|
|
Start Sequence
|
|
, IntVal responseTo
|
|
, IntVal . getNodeID $ senderID
|
|
, IntVal parts
|
|
, IntVal part
|
|
, Enumerated . fromIntegral . fromEnum $ action]
|
|
<> maybe [] encodePayload responsePayload
|
|
<> [End Sequence]
|
|
|
|
-- ===== parser combinators =====
|
|
|
|
parseMessage :: ParseASN1 FediChordMessage
|
|
parseMessage = do
|
|
begin <- getNext
|
|
case begin of
|
|
Start Sequence -> pure ()
|
|
x -> throwParseError $ "unexpected ASN.1 element " <> show x
|
|
-- request and response messages are distiguishable by their structure,
|
|
-- see ASN.1 schema
|
|
firstElem <- getNext
|
|
message <- case firstElem of
|
|
Enumerated a -> parseRequest . toEnum . fromIntegral $ a
|
|
IntVal i -> parseResponse i
|
|
other -> throwParseError $ "unexpected first ASN1 element: " <> show other
|
|
-- consume sequence end
|
|
end <- getNext
|
|
case end of
|
|
End Sequence -> pure ()
|
|
x -> throwParseError $ "unexpected ASN.1 element " <> show x
|
|
pure message
|
|
|
|
|
|
|
|
parseRequest :: Action -> ParseASN1 FediChordMessage
|
|
parseRequest action = do
|
|
requestID <- parseInteger
|
|
sender <- parseNodeState
|
|
parts <- parseInteger
|
|
part <- parseInteger
|
|
hasPayload <- hasNext
|
|
payload <- if not hasPayload then pure Nothing else Just <$> case action of
|
|
QueryID -> parseQueryIDRequest
|
|
Join -> parseJoinRequest
|
|
Leave -> parseLeaveRequest
|
|
Stabilise -> parseStabiliseRequest
|
|
Ping -> parsePingRequest
|
|
|
|
pure $ Request requestID sender parts part action payload
|
|
|
|
parseResponse :: Integer -> ParseASN1 FediChordMessage
|
|
parseResponse responseTo = do
|
|
senderID <- fromInteger <$> parseInteger :: ParseASN1 NodeID
|
|
parts <- parseInteger
|
|
part <- parseInteger
|
|
action <- parseEnum :: ParseASN1 Action
|
|
hasPayload <- hasNext
|
|
payload <- if not hasPayload then pure Nothing else Just <$> case action of
|
|
QueryID -> parseQueryIDResponse
|
|
Join -> parseJoinResponse
|
|
Leave -> parseLeaveResponse
|
|
Stabilise -> parseStabiliseResponse
|
|
Ping -> parsePingResponse
|
|
|
|
pure $ Response responseTo senderID parts part action payload
|
|
|
|
parseInteger :: ParseASN1 Integer
|
|
parseInteger = do
|
|
i <- getNext
|
|
case i of
|
|
IntVal parsed -> pure parsed
|
|
x -> throwParseError $ "Expected IntVal but got " <> show x
|
|
|
|
parseEnum :: Enum a => ParseASN1 a
|
|
parseEnum = do
|
|
e <- getNext
|
|
case e of
|
|
Enumerated en -> pure $ toEnum . fromIntegral $ en
|
|
x -> throwParseError $ "Expected Enumerated but got " <> show x
|
|
|
|
parseString :: ParseASN1 String
|
|
parseString = do
|
|
s <- getNext
|
|
case s of
|
|
ASN1String toBeParsed -> maybe (throwParseError "string parsing failed") pure $ asn1CharacterToString toBeParsed
|
|
x -> throwParseError $ "Expected a ASN1String but got " <> show x
|
|
|
|
parseOctets :: ParseASN1 BS.ByteString
|
|
parseOctets = do
|
|
os <- getNext
|
|
case os of
|
|
OctetString bs -> pure bs
|
|
x -> throwParseError $ "Expected an OctetString but got " <> show x
|
|
|
|
parseNull :: ParseASN1 ()
|
|
parseNull = do
|
|
n <- getNext
|
|
case n of
|
|
Null -> pure ()
|
|
x -> throwParseError $ "Expected Null but got " <> show x
|
|
|
|
parseNodeState :: ParseASN1 NodeState
|
|
parseNodeState = onNextContainer Sequence $ do
|
|
nid' <- fromInteger <$> parseInteger
|
|
domain' <- parseString
|
|
ip' <- bsAsIpAddr <$> parseOctets
|
|
dhtPort' <- fromInteger <$> parseInteger
|
|
apPort' <- fromInteger <$> parseInteger
|
|
vServer' <- parseInteger
|
|
pure NodeState {
|
|
nid = nid'
|
|
, domain = domain'
|
|
, dhtPort = dhtPort'
|
|
, apPort = if apPort' == 0 then Nothing else Just apPort'
|
|
, vServerID = vServer'
|
|
, ipAddr = ip'
|
|
, internals = Nothing
|
|
}
|
|
|
|
|
|
parseCacheEntry :: ParseASN1 RemoteCacheEntry
|
|
parseCacheEntry = onNextContainer Sequence $ do
|
|
node <- parseNodeState
|
|
timestamp <- toEnum . fromIntegral <$> parseInteger
|
|
pure $ RemoteCacheEntry node timestamp
|
|
|
|
parseNodeCache :: ParseASN1 [RemoteCacheEntry]
|
|
parseNodeCache = onNextContainer Sequence $ getMany parseCacheEntry
|
|
|
|
parseJoinRequest :: ParseASN1 ActionPayload
|
|
parseJoinRequest = do
|
|
parseNull
|
|
pure JoinRequestPayload
|
|
|
|
parseJoinResponse :: ParseASN1 ActionPayload
|
|
parseJoinResponse = onNextContainer Sequence $ do
|
|
succ' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
|
pred' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
|
cache <- parseNodeCache
|
|
pure $ JoinResponsePayload {
|
|
joinSuccessors = succ'
|
|
, joinPredecessors = pred'
|
|
, joinCache = cache
|
|
}
|
|
|
|
parseQueryIDRequest :: ParseASN1 ActionPayload
|
|
parseQueryIDRequest = onNextContainer Sequence $ do
|
|
targetID <- fromInteger <$> parseInteger
|
|
lBestNodes <- parseInteger
|
|
pure $ QueryIDRequestPayload {
|
|
queryTargetID = targetID
|
|
, queryLBestNodes = lBestNodes
|
|
}
|
|
|
|
parseQueryIDResponse :: ParseASN1 ActionPayload
|
|
parseQueryIDResponse = onNextContainer Sequence $ do
|
|
Enumerated resultType <- getNext
|
|
result <- case resultType of
|
|
0 -> FOUND <$> parseNodeState
|
|
1 -> FORWARD . Set.fromList <$> parseNodeCache
|
|
_ -> throwParseError "invalid QueryIDResponse type"
|
|
pure $ QueryIDResponsePayload {
|
|
queryResult = result
|
|
}
|
|
|
|
parseStabiliseRequest :: ParseASN1 ActionPayload
|
|
parseStabiliseRequest = do
|
|
parseNull
|
|
pure StabiliseRequestPayload
|
|
|
|
parseStabiliseResponse :: ParseASN1 ActionPayload
|
|
parseStabiliseResponse = onNextContainer Sequence $ do
|
|
succ' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
|
pred' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
|
pure $ StabiliseResponsePayload {
|
|
stabiliseSuccessors = succ'
|
|
, stabilisePredecessors = pred'
|
|
}
|
|
|
|
parseLeaveRequest :: ParseASN1 ActionPayload
|
|
parseLeaveRequest = onNextContainer Sequence $ do
|
|
succ' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
|
pred' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
|
pure $ LeaveRequestPayload {
|
|
leaveSuccessors = succ'
|
|
, leavePredecessors = pred'
|
|
}
|
|
|
|
parseLeaveResponse :: ParseASN1 ActionPayload
|
|
parseLeaveResponse = do
|
|
parseNull
|
|
pure LeaveResponsePayload
|
|
|
|
parsePingRequest :: ParseASN1 ActionPayload
|
|
parsePingRequest = do
|
|
parseNull
|
|
pure PingRequestPayload
|
|
|
|
parsePingResponse :: ParseASN1 ActionPayload
|
|
parsePingResponse = onNextContainer Sequence $ do
|
|
handledNodes <- getMany parseNodeState
|
|
pure $ PingResponsePayload {
|
|
pingNodeStates = handledNodes
|
|
}
|