remove unnecessary directory level

src/CacheEdgeCases.hs

@@ -0,0 +1,29 @@
+import Hash2Pub.FediChord
+import Data.Map.Internal.Debug (showTree)
+import qualified Data.Map.Strict as Map
+
+giebMalCache :: [Integer] -> Map.Map NodeID ()
+giebMalCache = Map.fromList . map (mkCacheEntry . fromInteger)
+  where
+    mkCacheEntry nodeid = (nodeid, ())
+
+testCache1 = giebMalCache [1, -1, 2^50]
+testFirstHalf = giebMalCache [3, 2^254-2, 2^255]
+testOverlap = giebMalCache [2^255+2^254+3, 2, 2^253]
+
+nidLookup m = flip Map.lookup m . fromInteger
+nidLookupLT m = flip Map.lookupLT m . fromInteger
+nidLookupGT m = flip Map.lookupGT m . fromInteger
+
+edgeCase1 :: IO ()
+edgeCase1 = do
+    putStrLn "Let there be a Map with the keys [2^255+2^254+3, 2, 2^253], all keys are NodeIDs mod 2^256."
+    print testOverlap 
+    putStrLn "\nWhile (NodeID 2^255+2^254+3) > (NodeID 2^254 + 14) …"
+    print $ toNodeID (2^255+2^254+3) > toNodeID (2^254+14)
+    putStrLn "… and 2^255+2^254+3 is an element of the map…"
+    print $ Map.member (fromInteger 2^255+2^254+3) testOverlap
+    putStrLn "… looking for an element larger than 2^254 + 14 doesn't yield any."
+    print $ nidLookupGT testOverlap (2^254+14)
+    putStrLn "\nThat's the tree of the map:"
+    putStrLn $ showTree testOverlap

src/Hash2Pub/ASN1Coding.hs

@@ -0,0 +1,430 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hash2Pub.ASN1Coding where
+
+import Data.ASN1.Encoding -- asn1-encoding package
+import Data.ASN1.BinaryEncoding
+import Data.ASN1.Error()
+import Data.ASN1.Types -- asn1-types package
+import Data.ASN1.Parse
+import Data.Maybe (fromMaybe, mapMaybe, isNothing)
+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 Data.Bifunctor (first)
+import Control.Exception (displayException)
+import Safe
+
+import Hash2Pub.FediChord
+import Hash2Pub.Utils
+import Hash2Pub.DHTProtocol
+
+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 . map 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
+  : 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 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
+  : 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
+  , 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 -> return ()
+      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 -> return ()
+      x -> throwParseError $ "unexpected ASN.1 element " ++ show x
+    return message
+
+
+
+parseRequest :: Action -> ParseASN1 FediChordMessage
+parseRequest action = do
+    requestID <- parseInteger
+    sender <- parseNodeState
+    parts <- parseInteger
+    part <- parseInteger
+    hasPayload <- hasNext
+    payload <- if not hasPayload then return Nothing else Just <$> case action of
+                 QueryID -> parseQueryIDRequest
+                 Join -> parseJoinRequest
+                 Leave -> parseLeaveRequest
+                 Stabilise -> parseStabiliseRequest
+                 Ping -> parsePingRequest
+
+    return $ 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 return Nothing else Just <$> case action of
+                 QueryID -> parseQueryIDResponse
+                 Join -> parseJoinResponse
+                 Leave -> parseLeaveResponse
+                 Stabilise -> parseStabiliseResponse
+                 Ping -> parsePingResponse
+
+    return $ Response responseTo senderID parts part action payload
+
+parseInteger :: ParseASN1 Integer
+parseInteger = do
+    i <- getNext
+    case i of
+        IntVal parsed -> return parsed
+        x -> throwParseError $ "Expected IntVal but got " ++ show x
+
+parseEnum :: Enum a => ParseASN1 a
+parseEnum = do
+    e <- getNext
+    case e of
+        Enumerated en -> return $ 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") return $ asn1CharacterToString toBeParsed
+        x -> throwParseError $ "Expected a ASN1String but got " ++ show x
+
+parseOctets :: ParseASN1 BS.ByteString
+parseOctets = do
+    os <- getNext
+    case os of
+        OctetString bs -> return bs
+        x -> throwParseError $ "Expected an OctetString but got " ++ show x
+
+parseNull :: ParseASN1 ()
+parseNull = do
+    n <- getNext
+    case n of
+        Null -> return ()
+        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
+    return 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
+    return $ RemoteCacheEntry node timestamp
+
+parseNodeCache :: ParseASN1 [RemoteCacheEntry]
+parseNodeCache = onNextContainer Sequence $ getMany parseCacheEntry
+
+parseJoinRequest :: ParseASN1 ActionPayload
+parseJoinRequest = do
+    parseNull
+    return JoinRequestPayload
+
+parseJoinResponse :: ParseASN1 ActionPayload
+parseJoinResponse = onNextContainer Sequence $ 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 = onNextContainer Sequence $ do
+    targetID <- fromInteger <$> parseInteger
+    lBestNodes <- parseInteger
+    return $ 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"
+    return $ QueryIDResponsePayload {
+        queryResult = result
+                           }
+
+parseStabiliseRequest :: ParseASN1 ActionPayload
+parseStabiliseRequest = do
+    parseNull
+    return StabiliseRequestPayload
+
+parseStabiliseResponse :: ParseASN1 ActionPayload
+parseStabiliseResponse = onNextContainer Sequence $ 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 = onNextContainer Sequence $ 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 = onNextContainer Sequence $ do
+    handledNodes <- getMany parseNodeState
+    return $ PingResponsePayload {
+        pingNodeStates = handledNodes
+                                 }

src/Hash2Pub/DHTProtocol.hs

@@ -0,0 +1,270 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hash2Pub.DHTProtocol
+    ( QueryResponse (..)
+    , queryLocalCache
+    , addCacheEntry
+    , addCacheEntryPure
+    , deleteCacheEntry
+    , markCacheEntryAsVerified
+    , RemoteCacheEntry(..)
+    , toRemoteCacheEntry
+    , remoteNode_
+    , Action(..)
+    , ActionPayload(..)
+    , FediChordMessage(..)
+    , maximumParts
+    )
+        where
+
+import Data.Maybe (maybe, fromMaybe)
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Data.Time.Clock.POSIX
+import Network.Socket hiding (send, sendTo, recv, recvFrom)
+import Network.Socket.ByteString
+import System.Timeout
+import Control.Monad.State.Strict
+
+import Hash2Pub.FediChord
+  ( NodeID
+  , NodeState (..)
+  , getSuccessors
+  , putSuccessors
+  , getPredecessors
+  , putPredecessors
+  , cacheGetNodeStateUnvalidated
+  , NodeCache
+  , CacheEntry(..)
+  , cacheLookup
+  , cacheLookupSucc
+  , cacheLookupPred
+  , localCompare
+  )
+
+import Debug.Trace (trace)
+
+-- === queries ===
+
+data QueryResponse = FORWARD (Set.Set RemoteCacheEntry) -- ^return closest nodes from local cache.
+                                          -- whole cache entry is returned for making
+                                          -- the entry time stamp available to the
+                                          -- protocol serialiser
+                   | FOUND NodeState     -- ^node is the responsible node for queried ID
+                   deriving (Show, Eq)
+
+-- TODO: evaluate more fine-grained argument passing to allow granular locking
+-- | look up an ID to either claim responsibility for it or return the closest l nodes from the local cache
+queryLocalCache :: NodeState -> NodeCache -> Int -> NodeID -> QueryResponse
+queryLocalCache ownState nCache lBestNodes targetID
+    -- as target ID falls between own ID and first predecessor, it is handled by this node
+      | (targetID `localCompare`  ownID) `elem` [LT, EQ] && not (null preds) && (targetID `localCompare` head preds == GT) = FOUND ownState
+    -- my interpretation: the "l best next hops" are the l-1 closest preceding nodes and
+    -- the closest succeeding node (like with the p initiated parallel queries
+      | otherwise = FORWARD $ closestSuccessor `Set.union` closestPredecessors
+  where
+    preds = fromMaybe [] $ getPredecessors ownState
+    ownID = nid ownState
+
+    closestSuccessor :: Set.Set RemoteCacheEntry
+    closestSuccessor = maybe Set.empty Set.singleton $ toRemoteCacheEntry =<< cacheLookupSucc targetID nCache
+
+    closestPredecessors :: Set.Set RemoteCacheEntry
+    closestPredecessors = closestPredecessor (lBestNodes-1) $ nid ownState
+    closestPredecessor :: (Integral n, Show n) => n -> NodeID -> Set.Set RemoteCacheEntry
+    closestPredecessor 0 _ = Set.empty
+    closestPredecessor remainingLookups lastID
+      | remainingLookups < 0 = Set.empty
+      | otherwise =
+        let result = cacheLookupPred lastID nCache
+      in
+        case toRemoteCacheEntry =<< result of
+          Nothing -> Set.empty
+          Just nPred@(RemoteCacheEntry ns ts) -> Set.insert nPred $ closestPredecessor (remainingLookups-1) (nid ns)
+
+-- === protocol serialisation data types
+
+data Action =
+    QueryID 
+  | Join
+  | Leave
+  | Stabilise
+  | Ping
+  deriving (Show, Eq, Enum)
+
+data FediChordMessage =
+    Request {
+    requestID       :: Integer
+  , sender          :: NodeState
+  , parts           :: Integer
+  , part            :: Integer
+  -- ^ part starts at 0
+  , action          :: Action
+  , payload         :: Maybe ActionPayload
+                        }
+  | Response {
+    responseTo      :: Integer
+  , senderID        :: NodeID
+  , parts           :: Integer
+  , part            :: Integer
+  , action          :: Action
+  , payload         :: Maybe ActionPayload
+             } deriving (Show, Eq)
+
+data ActionPayload = 
+    QueryIDRequestPayload {
+        queryTargetID   :: NodeID
+      , queryLBestNodes :: Integer
+                          }
+  | JoinRequestPayload
+  | LeaveRequestPayload {
+        leaveSuccessors     :: [NodeID]
+      , leavePredecessors   :: [NodeID]
+                        }
+  | StabiliseRequestPayload
+  | PingRequestPayload
+  | QueryIDResponsePayload {
+        queryResult     :: QueryResponse
+                           }
+  | JoinResponsePayload {
+        joinSuccessors      :: [NodeID]
+      , joinPredecessors    :: [NodeID]
+      , joinCache           :: [RemoteCacheEntry]
+                        }
+  | LeaveResponsePayload
+  | StabiliseResponsePayload {
+        stabiliseSuccessors     :: [NodeID]
+      , stabilisePredecessors   :: [NodeID]
+                             }
+  | PingResponsePayload {
+        pingNodeStates  :: [NodeState]
+                        }
+    deriving (Show, Eq)
+
+-- | global limit of parts per message used when (de)serialising messages.
+-- Used to limit the impact of DOS attempts with partial messages.
+maximumParts :: Num a => a
+maximumParts = 150
+
+-- | dedicated data type for cache entries sent to or received from the network,
+-- as these have to be considered as unvalidated. Also helps with separation of trust.
+data RemoteCacheEntry = RemoteCacheEntry NodeState POSIXTime
+    deriving (Show, Eq)
+
+instance Ord RemoteCacheEntry where
+    (RemoteCacheEntry ns1 _) `compare` (RemoteCacheEntry ns2 _) = nid ns1 `compare` nid ns2
+
+toRemoteCacheEntry :: CacheEntry -> Maybe RemoteCacheEntry
+toRemoteCacheEntry (NodeEntry _ ns ts) = Just $ RemoteCacheEntry ns ts
+toRemoteCacheEntry (ProxyEntry _ (Just entry@NodeEntry{})) = toRemoteCacheEntry entry
+toRemoteCacheEntry _ = Nothing
+
+-- helper function for use in tests
+remoteNode_ :: RemoteCacheEntry -> NodeState
+remoteNode_ (RemoteCacheEntry ns _) = ns
+
+-- cache operations
+
+-- | update or insert a 'RemoteCacheEntry' into the cache,
+-- converting it to a local 'CacheEntry'
+addCacheEntry :: RemoteCacheEntry   -- ^ a remote cache entry received from network
+              -> NodeCache          -- ^ node cache to insert to
+              -> IO NodeCache       -- ^ new node cache with the element inserted
+addCacheEntry entry cache = do
+    now <- getPOSIXTime
+    return $ addCacheEntryPure now entry cache
+
+-- | pure version of 'addCacheEntry' with current time explicitly specified as argument
+addCacheEntryPure :: POSIXTime      -- ^ current time
+              -> RemoteCacheEntry   -- ^ a remote cache entry received from network
+              -> NodeCache          -- ^ node cache to insert to
+              -> NodeCache       -- ^ new node cache with the element inserted
+addCacheEntryPure now (RemoteCacheEntry ns ts) cache =
+    let
+        -- TODO: limit diffSeconds to some maximum value to prevent malicious nodes from inserting entries valid nearly until eternity
+        timestamp' = if ts <= now then ts else now
+        newCache = Map.insertWith insertCombineFunction (nid ns) (NodeEntry False ns timestamp') cache
+        insertCombineFunction newVal@(NodeEntry newValidationState newNode newTimestamp) oldVal =
+            case oldVal of
+              ProxyEntry n _ -> ProxyEntry n (Just newVal)
+              NodeEntry oldValidationState _ oldTimestamp  -> NodeEntry oldValidationState newNode (max oldTimestamp newTimestamp)
+    in
+      newCache
+
+-- | delete the node with given ID from cache
+deleteCacheEntry :: NodeID      -- ^ID of the node to be deleted
+                 -> NodeCache   -- ^cache to delete from
+                 -> NodeCache   -- ^cache without the specified element
+deleteCacheEntry = Map.update modifier
+  where
+    modifier (ProxyEntry idPointer _) = Just (ProxyEntry idPointer Nothing)
+    modifier NodeEntry {} = Nothing
+
+-- | Mark a cache entry as verified after pinging it, possibly bumping its timestamp.
+markCacheEntryAsVerified :: Maybe POSIXTime     -- ^ the (current) timestamp to be
+                                                -- given to the entry, or Nothing
+                         -> NodeID              -- ^ which node to mark
+                         -> NodeCache           -- ^ current node cache
+                         -> NodeCache           -- ^ new NodeCache with the updated entry
+markCacheEntryAsVerified timestamp = Map.adjust adjustFunc
+    where
+        adjustFunc (NodeEntry _ ns ts) = NodeEntry True ns $ fromMaybe ts timestamp
+        adjustFunc (ProxyEntry _ (Just entry)) = adjustFunc entry
+        adjustFunc entry = entry
+
+-- ====== message send and receive operations ======
+
+requestQueryID :: NodeState -> NodeID -> IO NodeState
+-- 1. do a local lookup for the l closest nodes
+-- 2. create l sockets
+-- 3. send a message async concurrently to all l nodes
+-- 4. collect the results, insert them into cache
+-- 5. repeat until FOUND (problem: new entries not necessarily already in cache, explicitly compare with closer results)
+requestQueryID ns targetID = do
+    cacheSnapshot <- readIORef $ getNodeCacheRef ns
+    let localResult = queryLocalCache ns cacheSnapshot (fromMaybe 1 $ getLNumBestNodes ns) targetID
+    -- FOUND can only be returned if targetID is owned by local node
+    case localResult of
+      FOUND thisNode -> return thisNode
+      FORWARD nodeSet ->
+          sockets <- mapM (\resultNode -> mkSendSocket (domain result) (dhtPort resultNode)) $ Set.toList nodeSet
+          -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613
+          responses = mapM 
+
+sendRequestTo :: Int                    -- ^ timeout in seconds
+              -> Int                    -- ^ number of retries
+              -> FediChordMessage       -- ^ the message to be sent
+              -> Socket                 -- ^ connected socket to use for sending
+              -> IO (Set.Set FediChordMessage)  -- ^ responses
+sendRequestTo timeout attempts msg sock = do
+    let requests = serialiseMessage 1200 msg
+    -- ToDo: make attempts and timeout configurable
+    attempts 3 . timeout 5000 $ do
+  where
+    -- state reingeben: state = noch nicht geackte messages, result = responses
+    sendAndAck :: Socket -> StateT (Map.Map Integer BS.ByteString) IO (Set.Set FediChordMessage)
+    sendAndAck sock = do
+        remainingSends <- get
+        sendMany sock $ Map.elems remainingSends
+        -- timeout pro receive socket, danach catMaybes
+        -- wichtig: Pakete können dupliziert werden, dh es können mehr ACKs als gesendete parts ankommen
+        replicateM
+
+
+
+
+-- idea: send all parts at once
+-- Set/ Map with unacked parts
+-- then recv with timeout for |unackedParts| attempts, receive acked parts from set/ map
+-- how to manage individual retries? nested "attempts"
+
+-- | retry an IO action at most *i* times until it delivers a result
+attempts :: Int             -- ^ number of retries *i*
+         -> IO (Maybe a)    -- ^ action to retry
+         -> IO (Maybe a)    -- ^ result after at most *i* retries
+attempts 0 _ = return Nothing
+attempts i action = do
+    actionResult <- action
+    case actionResult of
+      Nothing -> attempts (i-1) action
+      Just res -> return $ Just res

src/Hash2Pub/FediChord.hs

@@ -0,0 +1,532 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, DataKinds, OverloadedStrings #-}
+{- |
+Module      : FediChord
+Description : An opinionated implementation of the EpiChord DHT by Leong et al.
+Copyright   : (c) schmittlauch, 2019-2020
+License     : AGPL-3
+Stability   : experimental
+
+Modernised EpiChord + k-choices load balancing
+-}
+
+module Hash2Pub.FediChord (
+    NodeID -- abstract, but newtype constructors cannot be hidden
+  , getNodeID
+  , toNodeID
+  , NodeState (..)
+  , InternalNodeState (..)
+  , getNodeCacheRef
+  , putNodeCache
+  , getSuccessors
+  , putSuccessors
+  , getPredecessors
+  , putPredecessors
+  , getLNumBestNodes
+  , NodeCache
+  , CacheEntry(..)
+  , cacheGetNodeStateUnvalidated
+  , initCache
+  , cacheLookup
+  , cacheLookupSucc
+  , cacheLookupPred
+  , localCompare
+  , genNodeID
+  , genNodeIDBS
+  , genKeyID
+  , genKeyIDBS
+  , byteStringToUInteger
+  , ipAddrAsBS
+  , bsAsIpAddr
+  , FediChordConf(..)
+  , fediChordInit
+  , nodeStateInit
+  , mkServerSocket
+  , resolve
+  , cacheWriter
+                           ) where
+
+import qualified Data.Map.Strict as Map
+import Network.Socket
+import Data.Time.Clock.POSIX
+import Control.Exception
+import Data.Maybe (isJust, fromMaybe, mapMaybe)
+
+-- for hashing and ID conversion
+import Crypto.Hash
+import Data.Word
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.UTF8 as BSU
+import qualified Data.ByteArray as BA
+import qualified Network.ByteOrder as NetworkBytes
+import Data.IP (IPv6, fromHostAddress6, toHostAddress6)
+import Data.IORef
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TQueue
+import Control.Monad (forever)
+import Data.Typeable (Typeable(..), typeOf)
+
+import Hash2Pub.Utils
+
+import Debug.Trace (trace)
+
+-- define protocol constants
+-- | static definition of ID length in bits
+idBits :: Integer
+idBits = 256
+
+-- |NodeIDs are Integers wrapped in a newtype, to be able to redefine
+-- their instance behaviour
+--
+-- for being able to check value bounds, the constructor should not be used directly
+-- and new values are created via @toNodeID@ (newtype constructors cannot be hidden)
+newtype NodeID = NodeID { getNodeID :: Integer } deriving (Eq, Show, Enum)
+
+-- |smart data constructor for NodeID that throws a runtime exception for out-of-bounds values.
+-- When needing a runtime-safe constructor with drawbacks, try @fromInteger@
+toNodeID :: Integer -> NodeID
+toNodeID i = assert (i >= getNodeID minBound && i <= getNodeID maxBound) $ NodeID i
+
+-- |NodeIDs are bounded by the value range of an unsigned Integer of length 'idBits'
+instance Bounded NodeID where
+    minBound = NodeID 0
+    maxBound = NodeID (2^idBits - 1)
+
+-- |calculations with NodeIDs are modular arithmetic operations
+instance Num NodeID where
+    a + b = NodeID $ (getNodeID a + getNodeID b) `mod` (getNodeID maxBound + 1)
+    a * b = NodeID $ (getNodeID a * getNodeID b) `mod` (getNodeID maxBound + 1)
+    a - b = NodeID $ (getNodeID a - getNodeID b) `mod` (getNodeID maxBound + 1)
+    -- |safe constructor for NodeID values with the drawback, that out-of-bound values are wrapped around
+    -- with modulo to fit in the allowed value space. For runtime checking, look at @toNodeID@.
+    fromInteger i = NodeID $ i `mod` (getNodeID maxBound + 1)
+    signum = NodeID . signum . getNodeID
+    abs = NodeID . abs . getNodeID  -- ToDo: make sure that at creation time only IDs within the range are used
+
+-- | use normal strict monotonic ordering of integers, realising the ring structure
+-- is done in the @NodeCache@ implementation
+instance Ord NodeID where
+    a `compare` b = getNodeID a `compare` getNodeID b
+
+-- | local comparison of 2 node IDs, only relevant for determining a successor or predecessor on caches with just 2 nodes
+localCompare :: NodeID -> NodeID -> Ordering
+a `localCompare` b
+  | getNodeID a == getNodeID b = EQ
+  | wayForwards > wayBackwards = GT
+  | otherwise = LT
+  where
+    wayForwards = getNodeID (b - a)
+    wayBackwards = getNodeID (a - b)
+
+
+-- | represents a node and all its important state
+data NodeState = NodeState {
+    nid :: NodeID
+  , domain :: String
+  -- ^ full public domain name the node is reachable under
+  , ipAddr :: HostAddress6
+  -- the node's public IPv6 address
+  , dhtPort :: PortNumber
+  -- ^ port of the DHT itself
+  , apPort :: Maybe PortNumber
+  -- ^ port of the ActivityPub relay and storage service
+  -- might have to be queried first
+  , vServerID :: Integer
+  -- ^ ID of this vserver
+
+  -- ==== internal state ====
+  , internals :: Maybe InternalNodeState
+  -- ^ data not present in the representation of remote nodes
+  -- is put into its own type.
+  -- This is usually @Nothing@ for all remote nodes.
+  } deriving (Show, Eq)
+
+-- | encapsulates all data and parameters that are not present for remote nodes
+data InternalNodeState = InternalNodeState {
+    nodeCache :: IORef NodeCache
+  -- ^ EpiChord node cache with expiry times for nodes
+  -- as the map is ordered, lookups for the closes preceding node can be done using @lookupLT@.
+  -- encapsulated into an IORef for allowing concurrent reads without locking
+  , cacheWriteQueue :: TQueue (NodeCache -> NodeCache)
+  -- ^ cache updates are not written directly to the  'nodeCache' but queued and
+  -- only processed by a single writer thread to prevent lost updates.
+  -- All nodeCache modifying functions have to be partially applied enough before
+  -- being put into the queue.
+  --
+  , successors :: [NodeID] -- could be a set instead as these are ordered as well
+  -- ^ successor nodes in ascending order by distance
+  , predecessors :: [NodeID]
+  -- ^ predecessor nodes in ascending order by distance
+  ----- protocol parameters -----
+  -- TODO: evaluate moving these somewhere else
+  , kNeighbours :: Int
+  -- ^ desired length of predecessor and successor list
+  -- needs to be parameterisable for simulation purposes
+  , lNumBestNodes :: Int
+  -- ^ number of best next hops to provide
+  -- needs to be parameterisable for simulation purposes
+  , pNumParallelQueries :: Int
+  -- ^ number of parallel sent queries
+  -- needs to be parameterisable for simulation purposes
+  , jEntriesPerSlice :: Int
+  -- ^ number of desired entries per cache slice
+  -- needs to be parameterisable for simulation purposes
+                         } deriving (Show, Eq)
+
+-- | defining Show instances to be able to print NodeState for debug purposes
+instance Typeable a => Show (IORef a) where
+    show x = show (typeOf x)
+
+instance Typeable a => Show (TQueue a) where
+    show x = show (typeOf x)
+
+-- | extract a value from the internals of a 'NodeState'
+getInternals_ :: (InternalNodeState -> a) -> NodeState -> Maybe a
+getInternals_ func ns = func <$> internals ns
+
+-- could be done better with lenses
+-- | convenience function that updates an internal value of a NodeState
+putInternals_ :: (InternalNodeState -> InternalNodeState) -> NodeState -> NodeState
+putInternals_ func ns = let
+        newInternals = func <$> internals ns
+    in
+        ns {internals = newInternals }
+
+-- | convenience function for extracting the 'NodeCache' from a 'NodeState'
+getNodeCacheRef :: NodeState -> Maybe (IORef NodeCache)
+getNodeCacheRef = getInternals_ nodeCache
+
+-- | convenience function for updating the 'NodeCache' on 'NodeState' s that have
+-- internals.
+-- NodeStates without a cache (without internals) are returned unchanged
+putNodeCache :: IORef NodeCache -> NodeState -> NodeState
+putNodeCache nc = putInternals_ (\i -> i {nodeCache = nc})
+
+getCacheWriteQueue :: NodeState -> Maybe (TQueue (NodeCache -> NodeCache))
+getCacheWriteQueue = getInternals_ cacheWriteQueue
+
+-- | convenience function for extracting the @successors@ from a 'NodeState'
+getSuccessors :: NodeState -> Maybe [NodeID]
+getSuccessors = getInternals_ successors
+
+-- | convenience function that updates the successors of a NodeState
+putSuccessors :: [NodeID] -> NodeState -> NodeState
+putSuccessors succ' = putInternals_ (\i -> i {successors = succ'})
+
+-- | convenience function for extracting the @predecessors@ from a 'NodeState'
+getPredecessors :: NodeState -> Maybe [NodeID]
+getPredecessors = getInternals_ predecessors
+
+-- | convenience function that updates the predecessors of a NodeState
+putPredecessors :: [NodeID] -> NodeState -> NodeState
+putPredecessors pred' = putInternals_ (\i -> i {predecessors = pred'})
+
+-- | convenience function for extracting the @lNumBestNodes@ from a 'NodeState'
+getLNumBestNodes :: NodeState -> Maybe Int
+getLNumBestNodes = getInternals_ lNumBestNodes
+
+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 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)
+    deriving (Show, Eq)
+
+-- | as a compromise, only NodeEntry components are ordered by their NodeID
+-- while ProxyEntry components should never be tried to be ordered.
+instance Ord CacheEntry where
+
+    a `compare` b = compare (extractID a) (extractID b)
+        where
+            extractID (NodeEntry _ eState _) = nid eState
+            extractID (ProxyEntry _ _) = error "proxy entries should never appear outside of the NodeCache"
+
+data ProxyDirection = Backwards | Forwards deriving (Show, Eq)
+
+instance Enum ProxyDirection where
+    toEnum (-1) = Backwards
+    toEnum 1 = Forwards
+    toEnum _ = error "no such ProxyDirection"
+    fromEnum Backwards = - 1
+    fromEnum Forwards = 1
+
+--- useful function for getting entries for a full cache transfer
+cacheEntries :: NodeCache -> [CacheEntry]
+cacheEntries ncache = mapMaybe extractNodeEntries $ Map.elems ncache
+    where
+  extractNodeEntries (ProxyEntry _ possibleEntry) = possibleEntry
+
+-- | An empty @NodeCache@ needs to be initialised with 2 proxy entries,
+-- linking the modular name space together by connecting @minBound@ and @maxBound@
+initCache :: NodeCache
+initCache = Map.fromList $ proxyEntry <$> [(maxBound, (minBound, Forwards)), (minBound, (maxBound, Backwards))]
+  where
+    proxyEntry (from,to) = (from, ProxyEntry to Nothing)
+
+-- | Maybe returns the cache entry stored at given key
+cacheLookup :: NodeID       -- ^lookup key
+            -> NodeCache    -- ^lookup cache
+            -> Maybe CacheEntry
+cacheLookup key cache = case Map.lookup key cache of
+                          Just (ProxyEntry _ result) -> result
+                          res -> res
+
+-- | a wrapper around lookup functions, making the lookup redirectable by a @ProxyEntry@
+-- to simulate a modular ring
+lookupWrapper :: (NodeID -> NodeCache -> Maybe (NodeID, CacheEntry)) -> (NodeID -> NodeCache -> Maybe (NodeID, CacheEntry)) -> ProxyDirection -> NodeID -> NodeCache -> Maybe CacheEntry
+lookupWrapper f fRepeat direction key cache =
+    case f key cache of
+        -- the proxy entry found holds a
+        Just (_, (ProxyEntry _ (Just entry@NodeEntry{}))) -> Just entry
+        -- proxy entry holds another proxy entry, this should not happen
+        Just (_, (ProxyEntry _ (Just (ProxyEntry _ _)))) -> Nothing
+        -- proxy entry without own entry is a pointer on where to continue
+        -- if lookup direction is the same as pointer direction: follow pointer
+        Just (foundKey, (ProxyEntry (pointerID, pointerDirection) Nothing)) ->
+            let newKey = if pointerDirection == direction
+                            then pointerID
+                            else foundKey + (fromInteger . toInteger . fromEnum $ direction)
+            in if cacheNotEmpty cache
+               then lookupWrapper fRepeat fRepeat direction newKey cache
+               else Nothing
+        -- normal entries are returned
+        Just (_, entry@NodeEntry{}) -> Just entry
+        Nothing -> Nothing
+  where
+    cacheNotEmpty :: NodeCache -> Bool
+    cacheNotEmpty cache' = (Map.size cache' > 2)     -- there are more than the 2 ProxyEntries
+                   || isJust ( cacheLookup minBound cache') -- or one of the ProxyEntries holds a node
+                   || isJust (cacheLookup maxBound cache')
+
+-- | find the successor node to a given key on a modular EpiChord ring cache.
+-- Note: The EpiChord definition of "successor" includes the node at the key itself,
+-- if existing.
+cacheLookupSucc :: NodeID           -- ^lookup key
+                -> NodeCache        -- ^ring cache
+                -> Maybe CacheEntry
+cacheLookupSucc = lookupWrapper Map.lookupGE Map.lookupGE Forwards
+
+-- | find the predecessor node to a given key on a modular EpiChord ring cache.
+cacheLookupPred :: NodeID           -- ^lookup key
+                -> NodeCache        -- ^ring cache
+                -> Maybe CacheEntry
+cacheLookupPred = lookupWrapper Map.lookupLT Map.lookupLE Backwards
+
+-- clean up cache entries: once now - entry > maxAge
+-- transfer difference now - entry to other node
+
+-- | return the @NodeState@ data from a cache entry without checking its validation status
+cacheGetNodeStateUnvalidated :: CacheEntry -> NodeState
+cacheGetNodeStateUnvalidated (NodeEntry _ nState _) = nState
+cacheGetNodeStateUnvalidated (ProxyEntry _ (Just entry)) = cacheGetNodeStateUnvalidated entry
+cacheGetNodeStateUnvalidated _ = error "trying to return empty node state, please report a bug"
+
+-- | converts a 'HostAddress6' IP address to a big-endian strict ByteString
+ipAddrAsBS :: HostAddress6 -> BS.ByteString
+ipAddrAsBS (a, b, c, d) = mconcat $ map NetworkBytes.bytestring32 [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 . chunkBytes 4 $ bytes 
+
+
+-- | generates a 256 bit long NodeID using SHAKE128, represented as ByteString
+genNodeIDBS :: HostAddress6     -- ^a node's IPv6 address
+            -> String           -- ^a node's 1st and 2nd level domain name
+            -> Word8            -- ^the used vserver ID
+            -> BS.ByteString    -- ^the NodeID as a 256bit ByteString big-endian unsigned integer
+genNodeIDBS ip nodeDomain vserver =
+    hashIpaddrUpper `BS.append` hashID nodeDomain' `BS.append` hashIpaddLower
+        where
+            vsBS = BS.pack [vserver] -- attention: only works for vserver IDs up to 255
+            ipaddrNet = (BS.take 8 $ ipAddrAsBS ip) `BS.append` vsBS
+            nodeDomain' = BSU.fromString nodeDomain `BS.append` vsBS
+            hashID bstr = BS.pack . BA.unpack $ (hash bstr :: Digest (SHAKE128 128))
+            (hashIpaddrUpper, hashIpaddLower) = BS.splitAt 64 $ hashID ipaddrNet
+
+
+-- | generates a 256 bit long @NodeID@ using SHAKE128
+genNodeID :: HostAddress6       -- ^a node's IPv6 address
+            -> String           -- ^a node's 1st and 2nd level domain name
+            -> Word8            -- ^the used vserver ID
+            -> NodeID           -- ^the generated @NodeID@
+genNodeID ip nodeDomain vs = NodeID . byteStringToUInteger $ genNodeIDBS ip nodeDomain vs
+
+-- | generates a 256 bit long key identifier, represented as ByteString, for looking up its data on the DHT
+genKeyIDBS :: String            -- ^the key string
+           -> BS.ByteString     -- ^the key ID represented as a @ByteString@
+genKeyIDBS key = BS.pack . BA.unpack $ (hash (BSU.fromString key) :: Digest SHA3_256)
+
+-- | generates a 256 bit long key identifier for looking up its data on the DHT
+genKeyID :: String              -- ^the key string
+         -> NodeID              -- ^the key ID
+genKeyID = NodeID . byteStringToUInteger . genKeyIDBS
+
+
+-- | parses the bit pattern of a ByteString as an unsigned Integer in Big Endian order
+-- by iterating it byte-wise from the back and shifting the byte values according to their offset
+byteStringToUInteger :: BS.ByteString -> Integer
+byteStringToUInteger bs = sum $ parsedBytes 0 bs
+  where
+    parsedBytes :: Integer -> BS.ByteString -> [ Integer ]
+    parsedBytes offset uintBs = case BS.unsnoc uintBs of
+                           Nothing -> []
+                           Just (bs', w) -> parseWithOffset offset w : parsedBytes (offset+1) bs'
+
+    parseWithOffset :: Integer -> Word8 -> Integer
+    parseWithOffset 0 word = toInteger word  -- a shift of 0 is always 0
+    parseWithOffset offset word =  toInteger word * 2^(8 * offset)
+
+
+
+-- TODO: complete rewrite
+-- |checks wether the cache entries fulfill the logarithmic EpiChord invariant
+-- of having j entries per slice, and creates a list of necessary lookup actions.
+-- Should be invoked periodically.
+--checkCacheSlices :: NodeState -> IO [()]
+--checkCacheSlices state = case getNodeCache state of
+--    -- don't do anything on nodes without a cache
+--    Nothing -> return [()]
+--    Just cache' -> checkSlice jEntries (nid state) startBound lastSucc =<< readIORef cache'
+--    -- TODO: do the same for predecessors
+--    where
+--        jEntries = fromMaybe 0 $ getInternals_ jEntriesPerSlice state
+--        lastSucc = last <$> maybeEmpty (fromMaybe [] $ getSuccessors state)
+--        startBound = NodeID 2^(255::Integer) + nid state
+--        checkSlice :: Int -> NodeID -> NodeID -> Maybe NodeID -> NodeCache -> [IO ()]
+--        checkSlice _ _ _ Nothing _ = []
+--        checkSlice j ownID upperBound (Just lastSuccNode) cache
+--            | upperBound < lastSuccNode = []
+--            | otherwise = 
+--                -- continuously half the DHT namespace, take the upper part as a slice,
+--                -- check for existing entries in that slice and create a lookup action
+--                -- and recursively do this on the lower half.
+--                -- recursion edge case: all successors/ predecessors need to be in the
+--                -- first slice.
+--                let
+--                  diff = getNodeID $ upperBound - ownID
+--                  lowerBound = ownID + NodeID (diff `div` 2)
+--                in
+--                   -- TODO: replace empty IO actions with actual lookups to middle of slice
+--                   -- TODO: validate ID before adding to cache
+--                   case Map.lookupLT upperBound cache of
+--                       Nothing -> return () : checkSlice j ownID lowerBound (Just lastSuccNode) cache
+--                       Just (matchID, _) ->
+--                           if
+--                               matchID <= lowerBound then return () : checkSlice j ownID lowerBound (Just lastSuccNode) cache
+--                           else
+--                               checkSlice j ownID lowerBound (Just lastSuccNode) cache
+
+
+-- Todo: DHT backend can learn potential initial bootstrapping points through the instances mentioned in the received AP-relay messages
+-- persist them on disk so they can be used for all following bootstraps
+
+-- | configuration values used for initialising the FediChord DHT
+data FediChordConf = FediChordConf {
+    confDomain :: String
+  , confIP :: HostAddress6
+  , confDhtPort :: Int
+                                   } deriving (Show, Eq)
+
+-- | initialise data structures, compute own IDs and bind to listening socket
+-- ToDo: load persisted state, thus this function already operates in IO
+fediChordInit :: FediChordConf -> IO (Socket, NodeState)
+fediChordInit conf = do
+    initialState <- nodeStateInit conf
+    serverSock <- mkServerSocket (ipAddr initialState) (dhtPort initialState)
+    return (serverSock, initialState)
+
+-- | initialises the 'NodeState' for this local node.
+-- Separated from 'fediChordInit' to be usable in tests.
+nodeStateInit :: FediChordConf -> IO NodeState
+nodeStateInit conf = do
+    cacheRef <- newIORef initCache
+    q <- atomically newTQueue
+    let
+        initialState = NodeState {
+            domain = confDomain conf
+          , ipAddr = confIP conf
+          , nid = genNodeID (confIP conf) (confDomain conf) 0
+          , dhtPort = toEnum $ confDhtPort conf
+          , apPort = Nothing
+          , vServerID = 0
+          , internals = Just internalsInit
+                                            }
+        internalsInit = InternalNodeState {
+           nodeCache = cacheRef
+          , cacheWriteQueue = q
+          , successors = []
+          , predecessors = []
+          , kNeighbours = 3
+          , lNumBestNodes = 3
+          , pNumParallelQueries = 2
+          , jEntriesPerSlice = 2
+                                           }
+    return initialState
+
+--fediChordJoin :: NodeState              -- ^ the local 'NodeState'
+--              -> (String, PortNumber)   -- ^ domain and port of a bootstrapping node
+--              -> Socket                 -- ^ socket used for sending and receiving the join message
+--              -> IO Either String NodeState -- ^ the joined 'NodeState' after a successful
+--                                         -- join, otherwise an error message
+--fediChordJoin ns (joinHost, joinPort) sock = do
+--    -- 1. get routed to destination until FOUND
+--    -- 2. then send a join to the currently responsible node
+--    -- ToDo: implement cache management, as already all received replies should be stored in cache
+--
+
+-- | cache updater thread that waits for incoming NodeCache update instructions on
+-- the node's cacheWriteQueue and then modifies the NodeCache as the single writer.
+cacheWriter :: NodeState -> IO ()
+cacheWriter ns = do
+    let writeQueue' = getCacheWriteQueue ns
+    case writeQueue' of
+      Nothing -> return ()
+      Just writeQueue -> forever $ do
+        f <- atomically $ readTQueue writeQueue
+        let
+            refModifier :: NodeCache -> (NodeCache, ())
+            refModifier nc = (f nc, ())
+        maybe (return ()) (
+            \ref -> atomicModifyIORef' ref refModifier
+                 ) $ getNodeCacheRef ns
+
+-- ====== network socket operations ======
+
+-- | resolve a specified host and return the 'AddrInfo' for it.
+-- If no hostname or IP is specified, the 'AddrInfo' can be used to bind to all
+-- addresses;
+-- if no port is specified an arbitrary free port is selected.
+resolve :: Maybe String         -- ^ hostname or IP address to be resolved
+        -> Maybe PortNumber     -- ^ port number of either local bind or remote
+        -> IO AddrInfo
+resolve host port = let
+    hints = defaultHints { addrFamily = AF_INET6, addrSocketType = Datagram
+                         , addrFlags = [AI_PASSIVE] }
+    in
+    head <$> getAddrInfo (Just hints) host (show <$> port)
+
+-- | create an unconnected UDP Datagram 'Socket' bound to the specified address
+mkServerSocket :: HostAddress6 -> PortNumber -> IO Socket
+mkServerSocket ip port = do
+    sockAddr <- addrAddress <$> resolve (Just $ show . fromHostAddress6 $ ip) (Just port)
+    sock <- socket AF_INET6 Datagram defaultProtocol
+    setSocketOption sock IPv6Only 1
+    bind sock sockAddr
+    return sock
+
+-- | create a UDP datagram socket, connected to a destination.
+-- The socket gets an arbitrary free local port assigned.
+mkSendSocket :: String  -- ^ destination hostname or IP
+             -> PortNumber  -- ^ destination port
+             -> IO Socket   -- ^ a socket with an arbitrary source port
+mkSendSocket dest destPort = do
+    destAddr <- addrAddress <$> resolve (Just dest) (Just destPort)
+    sendSock <- socket AF_INET6 Datagram defaultProtocol
+    setSocketOption sendSock IPv6Only 1
+    return sendSock

src/Hash2Pub/Main.hs

@@ -0,0 +1,32 @@
+module Main where
+
+import System.Environment
+import Data.IP (IPv6, toHostAddress6) -- iproute, just for IPv6 string parsing
+import Control.Concurrent
+
+import Hash2Pub.FediChord
+
+main :: IO ()
+main = do
+    -- ToDo: parse and pass config
+    -- probably use `tomland` for that
+    conf <- readConfig
+    -- ToDo: load persisted caches, bootstrapping nodes …
+    (serverSock, thisNode) <- fediChordInit conf
+    print thisNode
+    print serverSock
+    -- currently no masking is necessary, as there is nothing to clean up
+    cacheWriterThread <- forkIO $ cacheWriter thisNode
+    -- idea: list of bootstrapping nodes, try joining within a timeout
+    -- stop main thread from terminating during development
+    getChar
+    return ()
+
+readConfig :: IO FediChordConf
+readConfig = do
+    confDomainString : ipString : portString : _ <- getArgs
+    return $ FediChordConf {
+        confDomain = confDomainString
+      , confIP = toHostAddress6 . read $ ipString
+      , confDhtPort = read portString
+                           }

src/Hash2Pub/Utils.hs

@@ -0,0 +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

src/asn1test.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import qualified Data.ASN1.Encoding as ASN1 -- asn1-encoding package
+import qualified Data.ASN1.BinaryEncoding as ASN1
+import qualified Data.ASN1.Error as ASN1
+import qualified Data.ASN1.Types as ASN1 -- asn1-types package
+import qualified Data.ASN1.Parse as ASN1P
+import qualified Data.ByteString as BS
+import Data.Maybe (fromMaybe)
+import Debug.Trace (trace)
+
+-- import Hash2Pub.Fedichord
+
+-- encoding values as ASN.1 types is done using Data.ASN1.Prim
+someASN1 :: [ASN1.ASN1]
+someASN1 = ASN1.Start ASN1.Sequence : ASN1.ASN1String (ASN1.asn1CharacterString ASN1.Visible domain) : ASN1.ASN1String (ASN1.asn1CharacterString ASN1.UTF8 unicode) : map ASN1.IntVal xs ++ [ASN1.End ASN1.Sequence]
+  where
+    domain = "domains.are.ascii.on.ly"
+    unicode = "Hähä, but unicode string!"
+    xs = [ 23, 42, 2342 ]
+
+asn1AsDer :: [ASN1.ASN1] -> BS.ByteString
+asn1AsDer = ASN1.encodeASN1' ASN1.DER
+
+derToAsn1 :: BS.ByteString -> Either ASN1.ASN1Error [ASN1.ASN1]
+derToAsn1 = ASN1.decodeASN1' ASN1.DER
+
+getUnicodeField :: [ASN1.ASN1] -> String
+getUnicodeField ((ASN1.Start ASN1.Sequence) : _ : (ASN1.ASN1String strASN1) : _) = fromMaybe "" $ ASN1.asn1CharacterToString strASN1
+
+testParser :: ASN1P.ParseASN1 String
+testParser = do
+    foo <- ASN1P.onNextContainer ASN1.Sequence getAll
+    return $ show foo
+
+getAll :: ASN1P.ParseASN1 [ASN1.ASN1]
+getAll = ASN1P.getMany ASN1P.getNext
+
+--stringParser asn1obj =
+--    fmap (fromMaybe "" $ ASN1.asn1CharacterToString) ASN1P.getNext
+
+main = do
+    print someASN1
+    print $ asn1AsDer someASN1
+    print $ derToAsn1 . asn1AsDer $ someASN1
+    putStrLn $ getUnicodeField someASN1
+    print $ ASN1.decodeASN1Repr' ASN1.DER $ asn1AsDer someASN1
+    putStrLn "\nLet's try a real parser combinator:"
+    print $ ASN1P.runParseASN1State testParser someASN1