implement ASN.1 parsing with parser combinators

Hash2Pub/FediChord.asn1

@@ -9,15 +9,15 @@ Action ::= ENUMERATED {queryID, join, leave, stabilise, ping}
 Request ::= SEQUENCE {
 	action			Action,
 	requestID		INTEGER,
-	senderID		NodeID,
+	sender			NodeState,
 	parts			INTEGER,	-- number of message parts
 	part			INTEGER,	-- part number of this message
 	actionPayload	CHOICE {
-		queryIDSendPayload		QueryIDSendPayload,
+		queryIDRequestPayload		QueryIDRequestPayload,
-		joinSendPayload			JoinSendPayload,
+		joinRequestPayload			JoinRequestPayload,
-		leaveSendPayload		LeaveSendPayload,
+		leaveRequestPayload		LeaveRequestPayload,
-		stabiliseSendPayload	StabiliseSendPayload,
+		stabiliseRequestPayload	StabiliseRequestPayload,
-		pingSendPayload			PingSendPayload
+		pingRequestPayload			PingRequestPayload
 		}
 	}
 
@@ -31,11 +31,11 @@ Response ::= SEQUENCE {
 	part			INTEGER,
 	action			Action,
 	actionPayload	CHOICE {
-		queryIDReceivePayload	QueryIDReceivePayload,
+		queryIDResponsePayload	QueryIDResponsePayload,
-		joinReceivePayload		JoinReceivePayload,
+		joinResponsePayload		JoinResponsePayload,
-		leaveReceivePayload		LeaveReceivePayload,
+		leaveResponsePayload		LeaveResponsePayload,
-		stabiliseReceivePayload	StabiliseReceivePayload,
+		stabiliseResponsePayload	StabiliseResponsePayload,
-		pingReceivePayload		PingReceivePayload
+		pingResponsePayload		PingResponsePayload
 		}
 	}
 
@@ -45,7 +45,7 @@ NodeState ::= SEQUENCE {
 	ipAddr			OCTET STRING (SIZE(16)),
 	dhtPort			INTEGER,
 	apPort			INTEGER,
-	vServer			INTEGER
+	vServerID		INTEGER
 	}
 
 CacheEntry ::= SEQUENCE {
@@ -56,47 +56,47 @@ CacheEntry ::= SEQUENCE {
 
 NodeCache ::= SEQUENCE OF CacheEntry
 
-JoinSendPayload ::= NodeState
+JoinRequestPayload ::= NULL
 
-JoinReceivePayload ::= SEQUENCE {
+JoinResponsePayload ::= SEQUENCE {
 	successors		SEQUENCE OF NodeID,
 	predecessors	SEQUENCE OF NodeID,
 	cache			NodeCache
 	}
 
-QueryIDSendPayload ::= SEQUENCE {
+QueryResult ::= ENUMERATED { found, forward }
+
+QueryIDRequestPayload ::= SEQUENCE {
 	targetID		NodeID,
 	lBestNodes		INTEGER
 	}
 
-QueryResult ::= ENUMERATED { found, forward }
+QueryIDResponsePayload ::= SEQUENCE {
-
-QueryIDReceivePayload ::= SEQUENCE {
 	result			QueryResult,
-	nodeData		NodeCache OPTIONAL -- empty if `found`
+	nodeData		CHOICE {NodeState, NodeCache}
 	}
 
-StabiliseSendPayload ::= NodeState
+StabiliseRequestPayload ::= NULL
 
-StabiliseReceivePayload ::= SEQUENCE {
+StabiliseResponsePayload ::= SEQUENCE {
 	successors		SEQUENCE OF NodeID,
 	predecessors	SEQUENCE OF NodeID
 	-- ToDo: transfer of handled key data, if newly responsible for it
 	}
 
-LeaveSendPayload ::= SEQUENCE {
+LeaveRequestPayload ::= SEQUENCE {
 	successors		SEQUENCE OF NodeID,
 	predecessors	SEQUENCE OF NodeID
 	-- ToDo: transfer of own data to newly responsible node
 	}
 
-LeaveReceivePayload ::= NULL	-- just a confirmation
+LeaveResponsePayload ::= NULL	-- just a confirmation
 
-PingSendPayload ::= NULL		-- do not include a node/ vserver ID, so that
+PingRequestPayload ::= NULL		-- do not include a node/ vserver ID, so that
 								-- the node has to respond with all active ones
 
 -- learning all active vserver IDs handled by the server at once
-PingReceivePayload ::= SEQUENCE OF NodeState
+PingResponsePayload ::= SEQUENCE OF NodeState
 
 
 END

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
+  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
   ghc-options:         -Wall
 
 

Hash2Pub/src/Hash2Pub/ASN1Coding.hs

@@ -26,9 +26,17 @@ data Action =
 
 -- ToDo: probably move this to DHTProtocol as it is high-level
 
-data FediChordMessage = FediChordMessage {
+data FediChordMessage =
-    messageType     :: MessageType
+    Request {
-  , requestID       :: Integer
+    requestID       :: Integer
+  , sender          :: NodeState
+  , parts           :: Integer
+  , part            :: Integer
+  , action          :: Action
+  , payload         :: ActionPayload
+                        }
+  | Response {
+    responseTo      :: Integer
   , senderID        :: NodeID
   , parts           :: Integer
   , part            :: Integer
@@ -36,23 +44,17 @@ data FediChordMessage = FediChordMessage {
   , payload         :: ActionPayload
              } deriving (Show, Eq)
 
-data MessageType = Request | Response deriving (Show, Eq, Enum)
-
 data ActionPayload = 
     QueryIDRequestPayload {
         queryTargetID   :: NodeID
       , queryLBestNodes :: Integer
                           }
-  | JoinRequestPayload {
+  | JoinRequestPayload
-        joinNodeState   :: NodeState
-                       }
   | LeaveRequestPayload {
         leaveSuccessors     :: [NodeID]
       , leavePredecessors   :: [NodeID]
                         }
-  | StabiliseRequestPayload {
+  | StabiliseRequestPayload
-        stabiliseNodeState  :: NodeState
-                            }
   | PingRequestPayload
   | QueryIDResponsePayload {
         queryResult     :: QueryResponse
@@ -82,6 +84,7 @@ 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)
@@ -95,21 +98,21 @@ encodeCacheEntry (NodeEntry _ ns timestamp) =
   : encodeNodeState ns
   -- ToDo: possibly optimise this by using dlists
   ++ [
-    IntVal . fromIntegral . fromEnum . utcTimeToPOSIXSeconds $ timestamp
+    IntVal . fromIntegral . fromEnum $ timestamp
   , End Sequence]
 encodeCacheEntry _ = []
     
-encodeLeaveResponsePayload :: [ASN1]
+encodeLeaveResponsePayload :: ActionPayload -> [ASN1]
-encodeLeaveResponsePayload = [Null]
+encodeLeaveResponsePayload LeaveResponsePayload = [Null]
 
 encodeLeaveRequestPayload :: ActionPayload -> [ASN1]
 encodeLeaveRequestPayload payload@LeaveRequestPayload{} = 
     Start Sequence
   : Start Sequence
-  : map (IntVal . getNodeID) $ leaveSuccessors payload
+  : (map (IntVal . getNodeID) $ leaveSuccessors payload)
   ++ [End Sequence
   , Start Sequence]
-  ++ map (IntVal . getNodeID) $ leavePredecessors payload
+  ++ (map (IntVal . getNodeID) $ leavePredecessors payload)
   ++ [End Sequence
   , End Sequence]
 
@@ -118,16 +121,15 @@ encodeStabiliseResponsePayload :: ActionPayload -> [ASN1]
 encodeStabiliseResponsePayload payload@StabiliseResponsePayload{} = 
     Start Sequence
   : Start Sequence
-  : map (IntVal . getNodeID) $ stabiliseSuccessors payload
+  : (map (IntVal . getNodeID) $ stabiliseSuccessors payload)
   ++ [End Sequence
   , Start Sequence]
-  ++ map (IntVal . getNodeID) $ stabilisePredecessors payload
+  ++ (map (IntVal . getNodeID) $ stabilisePredecessors payload)
   ++ [End Sequence
   , End Sequence]
 
 encodeStabiliseRequestPayload :: ActionPayload -> [ASN1]
-encodeStabiliseRequestPayload payload@StabiliseRequestPayload =
+encodeStabiliseRequestPayload payload@StabiliseRequestPayload = [Null]
-    encodeNodeState $ stabiliseNodeState payload
 
 encodeQueryResult :: QueryResponse -> ASN1
 encodeQueryResult FOUND{} = Enumerated 0
@@ -144,12 +146,12 @@ encodeQueryIDResponsePayload payload@QueryIDResponsePayload{} =
       FOUND _ -> []
       FORWARD entrySet ->
             Start Sequence
-          : concatMap encodeCacheEntry . Set.elems $ entrySet
+          : (concatMap encodeCacheEntry . Set.elems $ entrySet)
           ++ [End Sequence]
   ++ [End Sequence]
 
 encodeQueryIDRequestPayload :: ActionPayload -> [ASN1]
-encodeQueryIDRequestPayload payload@QueryIDResponsePayload = [
+encodeQueryIDRequestPayload payload@QueryIDResponsePayload{} = [
     Start Sequence
   , IntVal . getNodeID $ queryTargetID payload
   , IntVal $ queryLBestNodes payload
@@ -158,30 +160,29 @@ encodeQueryIDRequestPayload payload@QueryIDResponsePayload = [
 
 -- | encodes the @JoinResponsePayload@ ASN.1 type
 encodeJoinResponsePayload :: ActionPayload -> [ASN1]
-encodeJoinResponsePayload payload@JoinResponsePayload =
+encodeJoinResponsePayload payload@JoinResponsePayload{} =
     Start Sequence
   : Start Sequence
-  : map (IntVal . getNodeID) $ joinSuccessors payload
+  : (map (IntVal . getNodeID) $ joinSuccessors payload)
   ++ [End Sequence
   , Start Sequence]
-  ++ map (IntVal . getNodeID) $ joinPredecessors payload
+  ++ (map (IntVal . getNodeID) $ joinPredecessors payload)
   ++ [End Sequence
     , Start Sequence]
-  ++ concatMap encodeCacheEntry $ joinCache payload
+  ++ (concatMap encodeCacheEntry $ joinCache payload)
   ++ [End Sequence
     , End Sequence]
 
 encodeJoinRequestPayload :: ActionPayload -> [ASN1]
-encodeJoinRequestPayload payload@JoinRequestPayload =
+encodeJoinRequestPayload payload@JoinRequestPayload{} = [Null]
-    encodeNodeState $ joinNodeState payload
 
-encodePingRequestPayload :: [ASN1]
+encodePingRequestPayload :: ActionPayload -> [ASN1]
-encodePingRequestPayload = Null
+encodePingRequestPayload PingRequestPayload{} = [Null]
 
 encodePingResponsePayload :: ActionPayload -> [ASN1]
-encodePingResponsePayload payload@PingResponsePayload =
+encodePingResponsePayload payload@PingResponsePayload{} =
     Start Sequence
-  : concatMap encodeNodeState $ pingNodeStates payload
+  : (concatMap encodeNodeState $ pingNodeStates payload)
   ++ [End Sequence]
 
 -- | Encode a 'FediChordMessage' as ASN.1.
@@ -193,17 +194,18 @@ encodeMessage :: FediChordMessage   -- ^ the 'FediChordMessage to be encoded, th
                                     -- the message's 'payload'
               -> [ASN1]
 encodeMessage
-    (FediChordMessage Request requestID senderID parts part action _)
+    (Request requestID sender parts part action _)
-    payload = [
+    payload =
         Start Sequence
-      , Enumerated . fromIntegral . fromEnum $ action
+      : (Enumerated . fromIntegral . fromEnum $ action)
-      , IntVal requestID
+      : IntVal requestID
-      , IntVal . getNodeID $ senderID
+      : encodeNodeState sender
-      , IntVal parts
+      ++ [
+        IntVal parts
       , IntVal part ]
       ++ payload
 encodeMessage
-    (FediChordMessage Response responseTo senderID parts part action _)
+    (Response responseTo senderID parts part action _)
     payload = [
         Start Sequence
       , IntVal responseTo
@@ -221,13 +223,13 @@ parseMessage = do
 -- see ASN.1 schema
     first <- getNext
     case first of
-      Enumerated a -> parseRequest . toEnum $ a
+      Enumerated a -> parseRequest . toEnum . fromIntegral $ a
       IntVal i -> parseResponse i
 
 parseRequest :: Action -> ParseASN1 FediChordMessage
 parseRequest action = do
     requestID <- parseInteger
-    senderID <- (fromInteger <$> parseInteger :: ParseASN1 NodeID)
+    sender <- parseNodeState
     parts <- parseInteger
     part <- parseInteger
     payload <- onNextContainer Sequence $
@@ -238,14 +240,14 @@ parseRequest action = do
             Stabilise -> parseStabiliseRequest
             Ping -> parsePingRequest
 
-    return ()
+    return $ Request requestID sender parts part action payload
 
 parseResponse :: Integer -> ParseASN1 FediChordMessage
 parseResponse responseTo = do
-    senderID <- (fromInteger <$> parseInteger :: ParseASN1 NodeID)
+    senderID <- fromInteger <$> parseInteger :: ParseASN1 NodeID
     parts <- parseInteger
     part <- parseInteger
-    action <- (parseEnum :: ParseASN1 Action)
+    action <- parseEnum :: ParseASN1 Action
     payload <- onNextContainer Sequence $
         case action of
             QueryID -> parseQueryIDResponse
@@ -254,7 +256,7 @@ parseResponse responseTo = do
             Stabilise -> parseStabiliseResponse
             Ping -> parsePingResponse
 
-    return ()
+    return $ Response responseTo senderID parts part action payload
 
 parseInteger :: ParseASN1 Integer
 parseInteger = do
@@ -265,3 +267,121 @@ parseEnum :: Enum a => ParseASN1 a
 parseEnum = do
     Enumerated en <- getNext
     return $ toEnum . fromIntegral $ en
+
+parseString :: ParseASN1 String
+parseString = do
+    ASN1String toBeParsed <- getNext
+    maybe (throwParseError "string parsing failed") return $ asn1CharacterToString toBeParsed
+
+parseOctets :: ParseASN1 BS.ByteString
+parseOctets = do
+    OctetString bs <- getNext
+    return bs
+
+parseNull :: ParseASN1 ()
+parseNull = do
+    -- ToDo: figure out how this fails on wrong inputs,
+    -- maybe a case distinction + throwParseError is better?
+    Null <- getNext
+    return ()
+
+parseNodeState :: ParseASN1 NodeState
+parseNodeState = do
+    nid' <- fromInteger <$> parseInteger
+    domain' <- parseString
+    ip' <- bsAsIpAddr <$> parseOctets
+    dhtPort' <- fromInteger <$> parseInteger
+    apPort' <- fromInteger <$> parseInteger
+    vServer' <- parseInteger
+    return NodeState {
+        nid = nid'
+      , domain = domain'
+      , dhtPort = dhtPort'
+      , apPort = if apPort' == 0 then Nothing else Just apPort'
+      , vServerID = vServer'
+                     }
+
+
+parseCacheEntry :: ParseASN1 CacheEntry
+parseCacheEntry = do
+    node <- parseNodeState
+    timestamp <- toEnum . fromIntegral <$> parseInteger
+    return $ NodeEntry False node timestamp
+
+parseNodeCache :: ParseASN1 [CacheEntry]
+parseNodeCache = getMany parseCacheEntry
+
+parseJoinRequest :: ParseASN1 ActionPayload
+parseJoinRequest = do
+    parseNull
+    return JoinRequestPayload
+
+parseJoinResponse :: ParseASN1 ActionPayload
+parseJoinResponse = do
+    succ' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
+    pred' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
+    cache <- parseNodeCache
+    return $ JoinResponsePayload {
+        joinSuccessors = succ'
+      , joinPredecessors = pred'
+      , joinCache = cache
+                                 }
+
+parseQueryIDRequest :: ParseASN1 ActionPayload
+parseQueryIDRequest = do
+    targetID <- fromInteger <$> parseInteger
+    lBestNodes <- parseInteger
+    return $ QueryIDRequestPayload {
+        queryTargetID = targetID
+      , queryLBestNodes = lBestNodes
+                                   }
+
+parseQueryIDResponse :: ParseASN1 ActionPayload
+parseQueryIDResponse = do
+    Enumerated resultType <- getNext
+    result <- case resultType of
+                  0 -> FOUND <$> parseNodeState
+                  1 -> FORWARD . Set.fromList <$> parseNodeCache
+    return $ QueryIDResponsePayload {
+        queryResult = result
+                           }
+
+parseStabiliseRequest :: ParseASN1 ActionPayload
+parseStabiliseRequest = do
+    parseNull
+    return StabiliseRequestPayload
+
+parseStabiliseResponse :: ParseASN1 ActionPayload
+parseStabiliseResponse = do
+    succ' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
+    pred' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
+    return $ StabiliseResponsePayload {
+        stabiliseSuccessors = succ'
+      , stabilisePredecessors = pred'
+                                      }
+
+parseLeaveRequest :: ParseASN1 ActionPayload
+parseLeaveRequest = do
+    succ' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
+    pred' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
+    return $ LeaveRequestPayload {
+        leaveSuccessors = succ'
+      , leavePredecessors = pred'
+                                      }
+
+parseLeaveResponse :: ParseASN1 ActionPayload
+parseLeaveResponse = do
+    parseNull
+    return LeaveResponsePayload
+
+parsePingRequest :: ParseASN1 ActionPayload
+parsePingRequest = do
+    parseNull
+    return PingRequestPayload
+
+parsePingResponse :: ParseASN1 ActionPayload
+parsePingResponse = do
+    handledNodes <- getMany parseNodeState
+    return $ PingResponsePayload {
+        pingNodeStates = handledNodes
+                                 }

Hash2Pub/src/Hash2Pub/FediChord.hs

@@ -37,11 +37,12 @@ module Hash2Pub.FediChord (
   , genKeyIDBS
   , byteStringToUInteger
   , ipAddrAsBS
+  , bsAsIpAddr
                            ) where
 
 import qualified Data.Map.Strict as Map
 import Network.Socket
-import Data.Time.Clock
+import Data.Time.Clock.POSIX
 import Control.Exception
 import Data.Maybe (isJust, fromMaybe, mapMaybe)
 
@@ -49,10 +50,9 @@ import Data.Maybe (isJust, fromMaybe, mapMaybe)
 import Crypto.Hash
 import Data.Word
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Builder as BB
-import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.UTF8 as BSU
 import qualified Data.ByteArray as BA
+import qualified Network.ByteOrder as NetworkBytes
 
 import Hash2Pub.Utils
 
@@ -197,7 +197,7 @@ type NodeCache = Map.Map NodeID CacheEntry
 -- |an entry of the 'nodeCache' can hold 2 different kinds of data
 data CacheEntry =
     -- | an entry representing its validation status, the node state and its timestamp
-    NodeEntry Bool NodeState UTCTime
+    NodeEntry Bool NodeState POSIXTime
     -- | a proxy field for closing the ring structure, indicating the lookup shall be
     -- resumed at the given @NodeID@ unless the @ProxyEntry@ itself holds a @NodeEntry@
   | ProxyEntry (NodeID, ProxyDirection) (Maybe CacheEntry)
@@ -234,21 +234,21 @@ initCache = Map.fromList $ proxyEntry <$> [(maxBound, (minBound, Forwards)), (mi
   where
     proxyEntry (from,to) = (from, ProxyEntry to Nothing)
 
--- | insert a new @NodeState@ node into the cache
+-- | insert or update a new @NodeState@ node into the cache
 addCacheEntry :: NodeState      -- ^ the node to insert
               -> Integer        -- ^ initial age penalty in seconds
               -> NodeCache      -- ^ node cache to insert to
               -> IO NodeCache   -- ^ new node cache with the element inserted
-addCacheEntry node diffSeconds cache = do
+addCacheEntry node timestamp cache = do
-    now <- getCurrentTime
+    now <- getPOSIXTime
     let
         -- TODO: limit diffSeconds to some maximum value to prevent malicious nodes from inserting entries valid nearly until eternity
-        timestamp = fromInteger (negate diffSeconds) `addUTCTime` now 
+        timestamp' = fromInteger timestamp 
-        newCache = Map.insertWith insertCombineFunction (nid node) (NodeEntry False node timestamp) cache
+        newCache = Map.insertWith insertCombineFunction (nid node) (NodeEntry False node timestamp') cache
-        insertCombineFunction newVal oldVal =
+        insertCombineFunction newVal@(NodeEntry newValidationState newNode newTimestamp) oldVal =
             case oldVal of
               ProxyEntry n _ -> ProxyEntry n (Just newVal)
-              _ -> newVal
+              NodeEntry oldValidationState _ oldTimestamp  -> NodeEntry oldValidationState newNode (max oldTimestamp newTimestamp)
     return newCache
 
 -- | delete the node with given ID from cache
@@ -320,8 +320,18 @@ cacheGetNodeStateUnvalidated _ = error "trying to return empty node state, pleas
 
 -- | converts a 'HostAddress6' IP address to a big-endian strict ByteString
 ipAddrAsBS :: HostAddress6 -> BS.ByteString
--- TODO: this is inefficient and possibly better done with binary-strict
+ipAddrAsBS (a, b, c, d) = mconcat $ map NetworkBytes.bytestring32 [a, b, c, d]
-ipAddrAsBS (a, b, c, d) = BL.toStrict . BB.toLazyByteString . mconcat $ map BB.word32BE [a, b, c, d]
+
+-- | converts a ByteString in big endian order to an IPv6 address 'HostAddress6'
+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
+
 
 -- | generates a 256 bit long NodeID using SHAKE128, represented as ByteString
 genNodeIDBS :: HostAddress6     -- ^a node's IPv6 address

Hash2Pub/test/FediChordSpec.hs

@@ -65,6 +65,9 @@ spec = do
                 , vServerID = 1
                              }
             print nsReady
+    describe "IP address to ByteString conversion" $
+        it "correctly converts HostAddress6 values back and forth" $
+            (bsAsIpAddr . ipAddrAsBS $ ipAddr exampleNodeState) `shouldBe` ipAddr exampleNodeState
     describe "NodeCache" $ do
         let
             emptyCache = fromJust $ getNodeCache exampleLocalNode