From da1b8f4b9d60dadc1df698214da21727d74cdafc Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 24 Jul 2020 22:29:43 +0200
Subject: [PATCH 001/112] define typeclasses for interfacing between
 PostService and DHT

---
 src/Hash2Pub/PostService.hs | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index e654868..53a840d 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -4,7 +4,6 @@
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE TypeOperators         #-}
-
 {-# LANGUAGE InstanceSigs          #-}
 
 module Hash2Pub.PostService where

From 473ccb631dee27929eb5e3ec4928a6a0a59768ac Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sun, 26 Jul 2020 16:26:26 +0200
Subject: [PATCH 002/112] add hie as language server to dev environment

---
 default.nix | 27 ++++++++++++++++++++-------
 1 file changed, 20 insertions(+), 7 deletions(-)

diff --git a/default.nix b/default.nix
index eea5386..5bf5a15 100644
--- a/default.nix
+++ b/default.nix
@@ -1,14 +1,26 @@
-{ pkgs ? import (
-  builtins.fetchGit {
-    name = "nixpkgs-pinned";
-    url = https://github.com/NixOS/nixpkgs/;
-    ref = "refs/heads/release-20.03";
-    rev = "da7ddd822e32aeebea00e97ab5aeca9758250a40";
-  }) {},
+{
   compiler ? "ghc865"
 }:
 
 let
+  # pin all-hies for getting the language server
+  all-hies = fetchTarball {
+    url = "https://github.com/infinisil/all-hies/tarball/b8fb659620b99b4a393922abaa03a1695e2ca64d";
+    sha256 = "sha256:0br6wsqpfk1lzz90f7zw439w1ir2p54268qilw9l2pk6yz7ganfx";
+  };
+  pkgs = import (
+    builtins.fetchGit {
+      name = "nixpkgs-pinned";
+      url = https://github.com/NixOS/nixpkgs/;
+      ref = "refs/heads/release-20.03";
+      rev = "076c67fdea6d0529a568c7d0e0a72e6bc161ecf5";
+    }) {
+      # Pass no config for purity
+          config = {};
+              overlays = [
+                      (import all-hies {}).overlay
+                          ];
+    };
   hp = pkgs.haskell.packages."${compiler}";
   src = pkgs.nix-gitignore.gitignoreSource [] ./.;
   drv = hp.callCabal2nix "Hash2Pub" "${src}/Hash2Pub.cabal" {};
@@ -25,6 +37,7 @@ in
         hlint
         stylish-haskell
         pkgs.python3Packages.asn1ate
+        hie
       ];
   };
 }

From 6349e05033d593d8eed4556e46365110f95859ef Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sun, 26 Jul 2020 16:38:56 +0200
Subject: [PATCH 003/112] enable HIE only in the shell environment, but not by
 default

---
 default.nix | 7 ++++---
 shell.nix   | 2 +-
 2 files changed, 5 insertions(+), 4 deletions(-)

diff --git a/default.nix b/default.nix
index 5bf5a15..4e77a05 100644
--- a/default.nix
+++ b/default.nix
@@ -1,5 +1,6 @@
 {
-  compiler ? "ghc865"
+  compiler ? "ghc865",
+  withHIE ? false
 }:
 
 let
@@ -37,7 +38,7 @@ in
         hlint
         stylish-haskell
         pkgs.python3Packages.asn1ate
-        hie
-      ];
+      ]
+      ++ (if withHIE then [ hie ] else []);
   };
 }
diff --git a/shell.nix b/shell.nix
index 82fb296..dafd212 100644
--- a/shell.nix
+++ b/shell.nix
@@ -1 +1 @@
-(import ./default.nix {}).shell
+(import ./default.nix {withHIE = true;}).shell

From 988144e9e7f9f9c22e4f43d5fdcac603d750a217 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sun, 26 Jul 2020 18:55:23 +0200
Subject: [PATCH 004/112] further relax constrains on RingMap

key now needs to be explicitly given at insert, instead of
deriving it from the value. This makes it possible to store values where
a key cannot be extracted from (HasKeyID)

contributes to #62, #32, #41
---
 src/Hash2Pub/RingMap.hs | 155 +++++++++++++++++++++-------------------
 1 file changed, 80 insertions(+), 75 deletions(-)

diff --git a/src/Hash2Pub/RingMap.hs b/src/Hash2Pub/RingMap.hs
index 529a68b..9c7f63b 100644
--- a/src/Hash2Pub/RingMap.hs
+++ b/src/Hash2Pub/RingMap.hs
@@ -10,31 +10,31 @@ import           Data.Maybe      (fromJust, isJust, isNothing, mapMaybe)
 
 -- | Class for all types that can be identified via a EpiChord key.
 -- Used for restricting the types a 'RingMap' can store
-class (Eq a, Show a, Bounded k, Ord k) => HasKeyID a k where
+class (Eq a, Show a, Bounded k, Ord k) => HasKeyID k a where
     getKeyID :: a -> k
 
 
 -- | generic data structure for holding elements with a key and modular lookup
-newtype RingMap a k = RingMap { getRingMap :: (HasKeyID a k, Bounded k, Ord k) => Map.Map k (RingEntry a k) }
+newtype RingMap k a = RingMap { getRingMap :: (Bounded k, Ord k) => Map.Map k (RingEntry k a) }
 
-instance (HasKeyID a k, Bounded k, Ord k) => Eq (RingMap a k) where
+instance (Bounded k, Ord k, Eq a) => Eq (RingMap k a) where
     a == b = getRingMap a == getRingMap b
 
-instance (HasKeyID a k, Bounded k, Ord k, Show k) => Show (RingMap a k) where
+instance (Bounded k, Ord k, Show k, Show a) => Show (RingMap k a) where
     show rmap = shows "RingMap " (show $ getRingMap rmap)
 
 -- | entry of a 'RingMap' that holds a value and can also
 -- wrap around the lookup direction at the edges of the name space.
-data RingEntry a k = KeyEntry a
-    | ProxyEntry (k, ProxyDirection) (Maybe (RingEntry a k))
+data RingEntry k a = KeyEntry a
+    | ProxyEntry (k, ProxyDirection) (Maybe (RingEntry k a))
     deriving (Show, Eq)
 
 -- | as a compromise, only KeyEntry components are ordered by their key
 -- while ProxyEntry components should never be tried to be ordered.
-instance (HasKeyID a k, Eq k, Ord a, Bounded k, Ord k) => Ord (RingEntry a k) where
+instance (HasKeyID k a, Eq k, Ord a, Bounded k, Ord k) => Ord (RingEntry k a) where
     a `compare` b = compare (extractID a) (extractID b)
         where
-            extractID :: (HasKeyID a k, Ord a, Bounded k, Ord k) => RingEntry a k -> k
+            extractID :: (HasKeyID k a, Ord a, Bounded k, Ord k) => RingEntry k a -> k
             extractID (KeyEntry e) = getKeyID e
             extractID ProxyEntry{} = error "proxy entries should never appear outside of the RingMap"
 
@@ -49,51 +49,51 @@ instance Enum ProxyDirection where
     fromEnum Backwards = - 1
     fromEnum Forwards  = 1
 
--- | helper function for getting the a from a RingEntry a k
-extractRingEntry :: (HasKeyID a k, Bounded k, Ord k) => RingEntry a k -> Maybe a
+-- | helper function for getting the a from a RingEntry k a
+extractRingEntry :: (Bounded k, Ord k) => RingEntry k a -> Maybe a
 extractRingEntry (KeyEntry entry)                       = Just entry
 extractRingEntry (ProxyEntry _ (Just (KeyEntry entry))) = Just entry
 extractRingEntry _                                      = Nothing
 
 -- | An empty 'RingMap' needs to be initialised with 2 proxy entries,
 -- linking the modular name space together by connecting @minBound@ and @maxBound@
-emptyRMap :: (HasKeyID a k, Bounded k, Ord k) => RingMap a k
+emptyRMap :: (Bounded k, Ord k) => RingMap k a
 emptyRMap = RingMap . Map.fromList $ proxyEntry <$> [(maxBound, (minBound, Forwards)), (minBound, (maxBound, Backwards))]
   where
     proxyEntry (from,to) = (from, ProxyEntry to Nothing)
 
 -- | Maybe returns the entry stored at given key
-rMapLookup :: (HasKeyID a k, Bounded k, Ord k)
+rMapLookup :: (Bounded k, Ord k)
            => k       -- ^lookup key
-           -> RingMap a k    -- ^lookup cache
+           -> RingMap k a    -- ^lookup cache
            -> Maybe a
 rMapLookup key rmap =  extractRingEntry =<< Map.lookup key (getRingMap rmap)
 
 -- | returns number of present 'KeyEntry' in a properly initialised 'RingMap'
-rMapSize :: (HasKeyID a k, Integral i, Bounded k, Ord k)
-         => RingMap a k
+rMapSize :: (Integral i, Bounded k, Ord k)
+         => RingMap k a
          -> i
 rMapSize rmap = fromIntegral $ Map.size innerMap - oneIfEntry rmap minBound - oneIfEntry rmap maxBound
   where
     innerMap = getRingMap rmap
-    oneIfEntry :: (HasKeyID a k, Integral i, Bounded k, Ord k) => RingMap a k -> k -> i
+    oneIfEntry :: (Integral i, Bounded k, Ord k) => RingMap k a -> k -> i
     oneIfEntry rmap' nid
       | isNothing (rMapLookup nid rmap') = 1
       | otherwise = 0
 
 -- | a wrapper around lookup functions, making the lookup redirectable by a @ProxyEntry@
 -- to simulate a modular ring
-lookupWrapper :: (HasKeyID a k, Bounded k, Ord k, Num k)
-              => (k -> Map.Map k (RingEntry a k) -> Maybe (k, RingEntry a k))
-              -> (k -> Map.Map k (RingEntry a k) -> Maybe (k, RingEntry a k))
+lookupWrapper :: (Bounded k, Ord k, Num k)
+              => (k -> Map.Map k (RingEntry k a) -> Maybe (k, RingEntry k a))
+              -> (k -> Map.Map k (RingEntry k a) -> Maybe (k, RingEntry k a))
               -> ProxyDirection
               -> k
-              -> RingMap a k
-              -> Maybe a
+              -> RingMap k a
+              -> Maybe (k, a)
 lookupWrapper f fRepeat direction key rmap =
     case f key $ getRingMap rmap of
         -- the proxy entry found holds a
-        Just (_, ProxyEntry _ (Just (KeyEntry entry))) -> Just entry
+        Just (foundKey, ProxyEntry _ (Just (KeyEntry entry))) -> Just (foundKey, 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
@@ -106,10 +106,10 @@ lookupWrapper f fRepeat direction key rmap =
                then lookupWrapper fRepeat fRepeat direction newKey rmap
                else Nothing
         -- normal entries are returned
-        Just (_, KeyEntry entry) -> Just entry
+        Just (foundKey, KeyEntry entry) -> Just (foundKey, entry)
         Nothing -> Nothing
   where
-    rMapNotEmpty :: (HasKeyID a k, Bounded k, Ord k) => RingMap a k -> Bool
+    rMapNotEmpty :: (Bounded k, Ord k) => RingMap k a -> Bool
     rMapNotEmpty rmap' = (Map.size (getRingMap rmap') > 2)     -- there are more than the 2 ProxyEntries
                    || isJust (rMapLookup minBound rmap') -- or one of the ProxyEntries holds a node
                    || isJust (rMapLookup maxBound rmap')
@@ -117,32 +117,34 @@ lookupWrapper f fRepeat direction key rmap =
 -- | find the successor node to a given key on a modular EpiChord ring.
 -- Note: The EpiChord definition of "successor" includes the node at the key itself,
 -- if existing.
-rMapLookupSucc :: (HasKeyID a k, Bounded k, Ord k, Num k)
+rMapLookupSucc :: (Bounded k, Ord k, Num k)
                => k           -- ^lookup key
-               -> RingMap a k       -- ^ring cache
-               -> Maybe a
+               -> RingMap k a       -- ^ring cache
+               -> Maybe (k, a)
 rMapLookupSucc = lookupWrapper Map.lookupGE Map.lookupGE Forwards
 
 -- | find the predecessor node to a given key on a modular EpiChord ring.
-rMapLookupPred :: (HasKeyID a k, Bounded k, Ord k, Num k)
+rMapLookupPred :: (Bounded k, Ord k, Num k)
                => k           -- ^lookup key
-               -> RingMap a k        -- ^ring cache
-               -> Maybe a
+               -> RingMap k a        -- ^ring cache
+               -> Maybe (k, a)
 rMapLookupPred = lookupWrapper Map.lookupLT Map.lookupLE Backwards
 
-addRMapEntryWith :: (HasKeyID a k, Bounded k, Ord k)
-                 => (RingEntry a k -> RingEntry a k -> RingEntry a k)
-                 -> a
-                 -> RingMap a k
-                 -> RingMap a k
-addRMapEntryWith combineFunc entry = RingMap
-    . Map.insertWith combineFunc (getKeyID entry) (KeyEntry entry)
+addRMapEntryWith :: (Bounded k, Ord k)
+                 => (RingEntry k a -> RingEntry k a -> RingEntry k a)
+                 -> k   -- ^ key
+                 -> a   -- ^ value
+                 -> RingMap k a
+                 -> RingMap k a
+addRMapEntryWith combineFunc key entry = RingMap
+    . Map.insertWith combineFunc key (KeyEntry entry)
     . getRingMap
 
-addRMapEntry :: (HasKeyID a k, Bounded k, Ord k)
-             => a
-             -> RingMap a k
-             -> RingMap a k
+addRMapEntry :: (Bounded k, Ord k)
+             => k   -- ^ key
+             -> a   -- ^ value
+             -> RingMap k a
+             -> RingMap k a
 addRMapEntry = addRMapEntryWith insertCombineFunction
   where
     insertCombineFunction newVal oldVal =
@@ -151,30 +153,30 @@ addRMapEntry = addRMapEntryWith insertCombineFunction
           KeyEntry _     -> newVal
 
 
-addRMapEntries :: (Foldable t, HasKeyID a k, Bounded k, Ord k)
-               => t a
-               -> RingMap a k
-               -> RingMap a k
-addRMapEntries entries rmap = foldr' addRMapEntry rmap entries
+addRMapEntries :: (Foldable t, Bounded k, Ord k)
+               => t (k, a)
+               -> RingMap k a
+               -> RingMap k a
+addRMapEntries entries rmap = foldr' (\(k, v) rmap' -> addRMapEntry k v rmap') rmap entries
 
-setRMapEntries :: (Foldable t, HasKeyID a k, Bounded k, Ord k)
-               => t a
-               -> RingMap a k
+setRMapEntries :: (Foldable t, Bounded k, Ord k)
+               => t (k, a)
+               -> RingMap k a
 setRMapEntries entries = addRMapEntries entries emptyRMap
 
-deleteRMapEntry :: (HasKeyID a k, Bounded k, Ord k)
+deleteRMapEntry :: (Bounded k, Ord k)
                 => k
-                -> RingMap a k
-                -> RingMap a k
+                -> RingMap k a
+                -> RingMap k a
 deleteRMapEntry nid = RingMap . Map.update modifier nid . getRingMap
   where
     modifier (ProxyEntry idPointer _) = Just (ProxyEntry idPointer Nothing)
     modifier KeyEntry {}              = Nothing
 
-rMapToList :: (HasKeyID a k, Bounded k, Ord k) => RingMap a k -> [a]
+rMapToList :: (Bounded k, Ord k) => RingMap k a -> [a]
 rMapToList = mapMaybe extractRingEntry . Map.elems . getRingMap
 
-rMapFromList :: (HasKeyID a k, Bounded k, Ord k) => [a] -> RingMap a k
+rMapFromList :: (Bounded k, Ord k) => [(k, a)] -> RingMap k a
 rMapFromList = setRMapEntries
 
 -- | takes up to i entries from a 'RingMap' by calling a getter function on a
@@ -182,49 +184,52 @@ rMapFromList = setRMapEntries
 -- Stops once i entries have been taken or an entry has been encountered twice
 -- (meaning the ring has been traversed completely).
 -- Forms the basis for 'takeRMapSuccessors' and 'takeRMapPredecessors'.
-takeRMapEntries_ :: (HasKeyID a k, Integral i, Bounded k, Ord k)
-                 => (k -> RingMap a k -> Maybe a)
-                 -> k
-                 -> i
-                 -> RingMap a k
-                 -> [a]
+takeRMapEntries_ :: (Integral i, Bounded k, Ord k)
+                 => (k -> RingMap k a -> Maybe (k, a))   -- ^ parameterisable getter function to determine lookup direction
+                 -> k   -- ^ starting key
+                 -> i   -- ^ number of maximum values to take
+                 -> RingMap k a
+                 -> [a] -- ^ values taken
 -- TODO: might be more efficient with dlists
 takeRMapEntries_ getterFunc startAt num rmap = reverse $
     case getterFunc startAt rmap of
       Nothing -> []
-      Just anEntry -> takeEntriesUntil rmap getterFunc (getKeyID anEntry) (getKeyID anEntry) (num-1) [anEntry]
+      Just (foundKey, anEntry) -> takeEntriesUntil rmap getterFunc foundKey foundKey (num-1) [anEntry]
   where
     -- for some reason, just reusing the already-bound @rmap@ and @getterFunc@
     -- variables leads to a type error, these need to be passed explicitly
-    takeEntriesUntil :: (HasKeyID a k, Integral i, Bounded k, Ord k)
-                     => RingMap a k
-                     -> (k -> RingMap a k -> Maybe a) -- getter function
+    takeEntriesUntil :: (Integral i, Bounded k, Ord k)
+                     => RingMap k a
+                     -> (k -> RingMap k a -> Maybe (k, a)) -- getter function
                      -> k
                      -> k
                      -> i
                      -> [a]
                      -> [a]
     takeEntriesUntil rmap' getterFunc' havingReached previousEntry remaining takeAcc
+      -- length limit reached
       | remaining <= 0 = takeAcc
-      | getKeyID (fromJust $ getterFunc' previousEntry rmap') == havingReached = takeAcc
-      | otherwise = let (Just gotEntry) = getterFunc' previousEntry rmap'
-                    in takeEntriesUntil rmap' getterFunc' havingReached (getKeyID gotEntry) (remaining-1) (gotEntry:takeAcc)
+      --
+      | otherwise = case nextEntry of
+                      Just (fKey, gotEntry)
+                        | fKey == havingReached -> takeAcc
+                        | otherwise -> takeEntriesUntil rmap' getterFunc' havingReached fKey (remaining - 1) (gotEntry:takeAcc)
+                      Nothing -> takeAcc
+        where
+            nextEntry = getterFunc' previousEntry rmap'
 
-takeRMapPredecessors :: (HasKeyID a k, Integral i, Bounded k, Ord k, Num k)
+
+takeRMapPredecessors :: (Integral i, Bounded k, Ord k, Num k)
                  => k
                  -> i
-                 -> RingMap a k
+                 -> RingMap k a
                  -> [a]
 takeRMapPredecessors = takeRMapEntries_ rMapLookupPred
 
-takeRMapSuccessors :: (HasKeyID a k, Integral i, Bounded k, Ord k, Num k)
+takeRMapSuccessors :: (Integral i, Bounded k, Ord k, Num k)
                  => k
                  -> i
-                 -> RingMap a k
+                 -> RingMap k a
                  -> [a]
 takeRMapSuccessors = takeRMapEntries_ rMapLookupSucc
 
--- clean up cache entries: once now - entry > maxAge
--- transfer difference now - entry to other node
-
-

From 7878c67635d2e11ef2bcf81783b1ffe7e19cd8ca Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 27 Jul 2020 00:37:17 +0200
Subject: [PATCH 005/112] adjust rest of code to refactored RingMap

---
 src/Hash2Pub/DHTProtocol.hs    | 21 ++++++++++++---------
 src/Hash2Pub/FediChordTypes.hs | 25 ++++++++++++++-----------
 src/Hash2Pub/PostService.hs    |  4 +++-
 src/Hash2Pub/RingMap.hs        |  4 +++-
 4 files changed, 32 insertions(+), 22 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index d69d94c..546c10f 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -130,23 +130,25 @@ closestCachePredecessors remainingLookups lastID nCache
 -- Looks up the successor of the lookup key on a 'RingMap' representation of the
 -- predecessor list with the node itself added. If the result is the same as the node
 -- itself then it falls into the responsibility interval.
-isInOwnResponsibilitySlice :: HasKeyID a NodeID => a -> LocalNodeState -> Bool
-isInOwnResponsibilitySlice lookupTarget ownNs = (getKeyID <$> rMapLookupSucc (getKeyID lookupTarget :: NodeID) predecessorRMap) == pure (getNid ownNs)
+isInOwnResponsibilitySlice :: HasKeyID NodeID a => a -> LocalNodeState -> Bool
+isInOwnResponsibilitySlice lookupTarget ownNs = (fst <$> rMapLookupSucc (getKeyID lookupTarget :: NodeID) predecessorRMap) == pure (getNid ownNs)
   where
     predecessorList = predecessors ownNs
     -- add node itself to RingMap representation, to distinguish between
     -- responsibility of own node and predecessor
-    predecessorRMap = addRMapEntry (toRemoteNodeState ownNs) $ rMapFromList predecessorList
+    predecessorRMap = addRMapEntry (getKeyID ownRemote) ownRemote $ rMapFromList (keyValuePair <$> predecessorList) :: RingMap NodeID RemoteNodeState
+    ownRemote = toRemoteNodeState ownNs
     closestPredecessor = headMay predecessorList
 
-isPossiblePredecessor :: HasKeyID a NodeID => a -> LocalNodeState -> Bool
+isPossiblePredecessor :: HasKeyID NodeID a => a -> LocalNodeState -> Bool
 isPossiblePredecessor = isInOwnResponsibilitySlice
 
-isPossibleSuccessor :: HasKeyID a NodeID => a -> LocalNodeState -> Bool
-isPossibleSuccessor lookupTarget ownNs = (getKeyID <$> rMapLookupPred (getKeyID lookupTarget :: NodeID) successorRMap) == pure (getNid ownNs)
+isPossibleSuccessor :: HasKeyID NodeID a => a -> LocalNodeState -> Bool
+isPossibleSuccessor lookupTarget ownNs = (fst <$> rMapLookupPred (getKeyID lookupTarget :: NodeID) successorRMap) == pure (getNid ownNs)
   where
     successorList = successors ownNs
-    successorRMap = addRMapEntry (toRemoteNodeState ownNs) $ rMapFromList successorList
+    successorRMap = addRMapEntry (getKeyID ownRemote) ownRemote $ rMapFromList (keyValuePair <$> successorList)
+    ownRemote = toRemoteNodeState ownNs
     closestSuccessor = headMay successorList
 
 -- cache operations
@@ -169,7 +171,8 @@ 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 = addRMapEntryWith insertCombineFunction (CacheEntry False ns timestamp') cache
+        newEntry = CacheEntry False ns timestamp'
+        newCache = addRMapEntryWith insertCombineFunction (getKeyID newEntry) newEntry cache
         insertCombineFunction newVal@(KeyEntry (CacheEntry newValidationState newNode newTimestamp)) oldVal =
             case oldVal of
               ProxyEntry n _ -> ProxyEntry n (Just newVal)
@@ -202,7 +205,7 @@ addNodeAsVerifiedPure :: POSIXTime
                       -> RemoteNodeState
                       -> NodeCache
                       -> NodeCache
-addNodeAsVerifiedPure now node = addRMapEntry (CacheEntry True node now)
+addNodeAsVerifiedPure now node = addRMapEntry (getKeyID node) (CacheEntry True node now)
 
 
 
diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs
index 7652f4f..6e0bef6 100644
--- a/src/Hash2Pub/FediChordTypes.hs
+++ b/src/Hash2Pub/FediChordTypes.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
@@ -26,8 +27,7 @@ module Hash2Pub.FediChordTypes (
   , CacheEntry(..)
   , RingEntry(..)
   , RingMap(..)
-  , HasKeyID
-  , getKeyID
+  , HasKeyID(..)
   , rMapSize
   , rMapLookup
   , rMapLookupPred
@@ -271,31 +271,31 @@ instance Typeable a => Show (TQueue a) where
 
 -- | convenience function that replaces the predecessors of a 'LocalNodeState' with the k closest nodes from the provided list
 setPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState
-setPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . rMapFromList . filter ((/=) (getNid ns) . getNid) $ preds}
+setPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . rMapFromList . fmap keyValuePair . filter ((/=) (getNid ns) . getNid) $ preds}
 
 -- | convenience function that replaces the successors of a 'LocalNodeState' with the k closest nodes from the provided list
 setSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState
-setSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . rMapFromList . filter ((/=) (getNid ns) . getNid) $ succs}
+setSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . rMapFromList . fmap keyValuePair . filter ((/=) (getNid ns) . getNid) $ succs}
 
 -- | sets the predecessors of a 'LocalNodeState' to the closest k nodes of the current predecessors and the provided list, combined
 addPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState
-addPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . addRMapEntries (filter ((/=) (getNid ns) . getNid) preds) . rMapFromList  $ predecessors ns}
+addPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . addRMapEntries (keyValuePair <$> filter ((/=) (getNid ns) . getNid) preds) . rMapFromList . fmap keyValuePair  $ predecessors ns}
 
 -- | sets the successors of a 'LocalNodeState' to the closest k nodes of the current successors and the provided list, combined
 addSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState
-addSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . addRMapEntries (filter ((/=) (getNid ns) . getNid) succs) . rMapFromList  $ successors ns}
+addSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . addRMapEntries (keyValuePair <$> filter ((/=) (getNid ns) . getNid) succs) . rMapFromList . fmap keyValuePair $ successors ns}
 
-instance HasKeyID RemoteNodeState NodeID where
+instance HasKeyID NodeID RemoteNodeState where
     getKeyID = getNid
 
-instance HasKeyID a k => HasKeyID (CacheEntry a) k where
+instance HasKeyID k a => HasKeyID k (CacheEntry a) where
     getKeyID (CacheEntry _ obj _) = getKeyID obj
 
 instance HasKeyID NodeID NodeID where
     getKeyID = id
 
 type NodeCacheEntry = CacheEntry RemoteNodeState
-type NodeCache = RingMap NodeCacheEntry NodeID
+type NodeCache = RingMap NodeID NodeCacheEntry
 
 type LookupCacheEntry = CacheEntry (String, PortNumber)
 type LookupCache = Map.Map NodeID LookupCacheEntry
@@ -319,12 +319,15 @@ cacheLookup = rMapLookup
 cacheLookupSucc :: NodeID           -- ^lookup key
                 -> NodeCache        -- ^ring cache
                 -> Maybe NodeCacheEntry
-cacheLookupSucc = rMapLookupSucc
+cacheLookupSucc key cache = snd <$> rMapLookupSucc key cache
 
 cacheLookupPred :: NodeID           -- ^lookup key
                 -> NodeCache        -- ^ring cache
                 -> Maybe NodeCacheEntry
-cacheLookupPred = rMapLookupPred
+cacheLookupPred key cache = snd <$> rMapLookupPred key cache
+
+-- 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 RemoteNodeState -> RemoteNodeState
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index e8b325b..21a7238 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -1,15 +1,16 @@
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE InstanceSigs          #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE TypeOperators         #-}
-{-# LANGUAGE InstanceSigs          #-}
 
 module Hash2Pub.PostService where
 
 import           Control.Concurrent
 import qualified Data.ByteString.Lazy.UTF8 as BSU
+import qualified Data.HashMap.Strict       as HMap
 import           Data.Maybe                (fromMaybe)
 import           Data.String               (fromString)
 import qualified Data.Text                 as Txt
@@ -18,6 +19,7 @@ import qualified Network.Wai.Handler.Warp  as Warp
 import           Servant
 
 import           Hash2Pub.FediChord
+import           Hash2Pub.RingMap
 import           Hash2Pub.ServiceTypes
 
 
diff --git a/src/Hash2Pub/RingMap.hs b/src/Hash2Pub/RingMap.hs
index 9c7f63b..016f9f1 100644
--- a/src/Hash2Pub/RingMap.hs
+++ b/src/Hash2Pub/RingMap.hs
@@ -5,13 +5,15 @@ module Hash2Pub.RingMap where
 
 import           Data.Foldable   (foldr')
 import qualified Data.Map.Strict as Map
-import           Data.Maybe      (fromJust, isJust, isNothing, mapMaybe)
+import           Data.Maybe      (isJust, isNothing, mapMaybe)
 
 
 -- | Class for all types that can be identified via a EpiChord key.
 -- Used for restricting the types a 'RingMap' can store
 class (Eq a, Show a, Bounded k, Ord k) => HasKeyID k a where
     getKeyID :: a -> k
+    keyValuePair :: a -> (k, a)
+    keyValuePair val = (getKeyID val, val)
 
 
 -- | generic data structure for holding elements with a key and modular lookup

From 04423171fdbc307b9c0d05d9f3ec16f6453ec5f9 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 27 Jul 2020 13:20:15 +0200
Subject: [PATCH 006/112] define data types for post and subscription storage

---
 Hash2Pub.cabal                 |  2 +-
 src/Hash2Pub/FediChordTypes.hs |  2 +-
 src/Hash2Pub/PostService.hs    | 22 ++++++++++++++++++++--
 src/Hash2Pub/ServiceTypes.hs   |  8 +++++++-
 4 files changed, 29 insertions(+), 5 deletions(-)

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index ebc9c7e..3ca520e 100644
--- a/Hash2Pub.cabal
+++ b/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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers
+  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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable
   ghc-options:         -Wall
 
 
diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs
index 6e0bef6..d764b71 100644
--- a/src/Hash2Pub/FediChordTypes.hs
+++ b/src/Hash2Pub/FediChordTypes.hs
@@ -413,7 +413,7 @@ data FediChordConf = FediChordConf
 
 class DHT d where
     -- | lookup the responsible host handling a given key string,
-    -- possibly from a lookup cache
+    -- possiblggy from a lookup cache
     lookupKey :: d -> String -> IO (Maybe (String, PortNumber))
     -- | lookup the responsible host handling a given key string,
     -- but force the DHT to do a fresh lookup instead of returning a cached result.
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 21a7238..bc1dc23 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -9,16 +9,21 @@
 module Hash2Pub.PostService where
 
 import           Control.Concurrent
+import           Control.Concurrent.STM
+import           Control.Concurrent.STM.TChan
+import           Control.Concurrent.STM.TVar
 import qualified Data.ByteString.Lazy.UTF8 as BSU
 import qualified Data.HashMap.Strict       as HMap
+import qualified Data.HashSet as HSet
 import           Data.Maybe                (fromMaybe)
 import           Data.String               (fromString)
 import qualified Data.Text                 as Txt
+import Data.Time.Clock.POSIX
 
 import qualified Network.Wai.Handler.Warp  as Warp
 import           Servant
 
-import           Hash2Pub.FediChord
+import           Hash2Pub.FediChordTypes
 import           Hash2Pub.RingMap
 import           Hash2Pub.ServiceTypes
 
@@ -29,6 +34,13 @@ data PostService d = PostService
     -- queues, other data structures
     , baseDHT       ::   (DHT d) => d
     , serviceThread :: ThreadId
+    , subscribers   :: TVar (RingMap NodeID TagSubscribers)
+    -- ^ for each tag store the subscribers + their queue
+    , ownSubscriptions :: TVar (HMap.HashMap NodeID POSIXTime)
+    -- ^ tags subscribed by the own node have an assigned lease time
+    , ownPosts :: TVar (HSet.HashSet Txt.Text)
+    -- ^ just store the existence of posts for saving memory,
+    -- always return the same placeholder
     }
 
 instance DHT d => Service PostService d where
@@ -45,12 +57,18 @@ instance DHT d => Service PostService d where
                            }
     getServicePort s = fromIntegral $ psPort s
 
+type PostContent = Txt.Text
+-- | For each handled tag, store its subscribers and provide a
+-- broadcast 'TChan' for enqueuing posts
+type RelayTags = RingMap NodeID (TagSubscribers, TChan PostContent)
+-- | each subscriber is identified by its contact data "hostname" "port"
+-- and holds a TChan duplicated from the broadcast TChan of the tag
+type TagSubscribers = HMap.HashMap (String, Int) (TChan PostContent)
 
 -- | return a WAI application
 postServiceApplication :: Application
 postServiceApplication = serve exposedPostServiceAPI postServer
 
-servicePort = 8081
 
 -- | needed for guiding type inference
 exposedPostServiceAPI :: Proxy PostServiceAPI
diff --git a/src/Hash2Pub/ServiceTypes.hs b/src/Hash2Pub/ServiceTypes.hs
index ab06052..430dc74 100644
--- a/src/Hash2Pub/ServiceTypes.hs
+++ b/src/Hash2Pub/ServiceTypes.hs
@@ -1,9 +1,15 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 module Hash2Pub.ServiceTypes where
 
-import           Hash2Pub.FediChord (DHT (..))
+import Data.Hashable (Hashable(..))
+
+import           Hash2Pub.FediChord (DHT (..), NodeID(..))
 
 class Service s d where
     -- | run the service
     runService :: (Integral i) => d -> String -> i -> IO (s d)
     getServicePort :: (Integral i) => s d -> i
+
+instance Hashable NodeID where
+    hashWithSalt salt = hashWithSalt salt . getNodeID
+    hash = hash . getNodeID

From daae9d0b38182985963f896018a46c2435e78a80 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 27 Jul 2020 21:39:33 +0200
Subject: [PATCH 007/112] process and enqueue incoming posts

---
 src/Hash2Pub/PostService.hs  | 146 ++++++++++++++++++++++-------------
 src/Hash2Pub/ServiceTypes.hs |   4 +-
 2 files changed, 94 insertions(+), 56 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index bc1dc23..fc3e5e8 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -11,16 +11,20 @@ module Hash2Pub.PostService where
 import           Control.Concurrent
 import           Control.Concurrent.STM
 import           Control.Concurrent.STM.TChan
+import           Control.Concurrent.STM.TQueue
 import           Control.Concurrent.STM.TVar
-import qualified Data.ByteString.Lazy.UTF8 as BSU
-import qualified Data.HashMap.Strict       as HMap
-import qualified Data.HashSet as HSet
-import           Data.Maybe                (fromMaybe)
-import           Data.String               (fromString)
-import qualified Data.Text                 as Txt
-import Data.Time.Clock.POSIX
+import           Control.Monad                 (forM_, forever)
+import           Control.Monad.IO.Class        (liftIO)
+import qualified Data.ByteString.Lazy.UTF8     as BSU
+import qualified Data.HashMap.Strict           as HMap
+import qualified Data.HashSet                  as HSet
+import           Data.Maybe                    (fromMaybe)
+import           Data.String                   (fromString)
+import qualified Data.Text.Lazy                as Txt
+import           Data.Time.Clock.POSIX
+import           System.Random
 
-import qualified Network.Wai.Handler.Warp  as Warp
+import qualified Network.Wai.Handler.Warp      as Warp
 import           Servant
 
 import           Hash2Pub.FediChordTypes
@@ -29,34 +33,23 @@ import           Hash2Pub.ServiceTypes
 
 
 data PostService d = PostService
-    { psPort        :: Warp.Port
-    , psHost        :: String
+    { psPort           :: Warp.Port
+    , psHost           :: String
     -- queues, other data structures
-    , baseDHT       ::   (DHT d) => d
-    , serviceThread :: ThreadId
-    , subscribers   :: TVar (RingMap NodeID TagSubscribers)
+    , baseDHT          ::   (DHT d) => d
+    , serviceThread    :: TVar ThreadId
+    , subscribers      :: TVar (RingMap NodeID TagSubscribers)
     -- ^ for each tag store the subscribers + their queue
     , ownSubscriptions :: TVar (HMap.HashMap NodeID POSIXTime)
     -- ^ tags subscribed by the own node have an assigned lease time
-    , ownPosts :: TVar (HSet.HashSet Txt.Text)
+    , ownPosts         :: TVar (HSet.HashSet Txt.Text)
     -- ^ just store the existence of posts for saving memory,
-    -- always return the same placeholder
+    , relayInQueue     :: TQueue (Hashtag, PostID, PostContent)
+    -- ^ Queue for processing incoming posts of own instance asynchronously
     }
 
-instance DHT d => Service PostService d where
-    runService dht host port = do
-        let
-            port' = fromIntegral port
-            warpSettings = Warp.setPort port' . Warp.setHost (fromString host) $ Warp.defaultSettings
-        servThread <- forkIO $ Warp.runSettings warpSettings postServiceApplication
-        pure $ PostService {
-            psPort = port'
-          , psHost = host
-          , baseDHT = dht
-          , serviceThread = servThread
-                           }
-    getServicePort s = fromIntegral $ psPort s
-
+type Hashtag = Txt.Text
+type PostID = Txt.Text
 type PostContent = Txt.Text
 -- | For each handled tag, store its subscribers and provide a
 -- broadcast 'TChan' for enqueuing posts
@@ -65,9 +58,40 @@ type RelayTags = RingMap NodeID (TagSubscribers, TChan PostContent)
 -- and holds a TChan duplicated from the broadcast TChan of the tag
 type TagSubscribers = HMap.HashMap (String, Int) (TChan PostContent)
 
+
+instance DHT d => Service PostService d where
+    -- | initialise 'PostService' data structures and run server
+    runService dht host port = do
+        -- create necessary TVars
+        threadVar <- newTVarIO =<< myThreadId -- own thread ID as placeholder
+        subscriberVar <- newTVarIO emptyRMap
+        ownSubsVar <- newTVarIO HMap.empty
+        ownPostVar <- newTVarIO HSet.empty
+        relayInQueue' <- newTQueueIO
+        let
+            thisService = PostService {
+                psPort = port'
+              , psHost = host
+              , baseDHT = dht
+              , serviceThread = threadVar
+              , subscribers = subscriberVar
+              , ownSubscriptions = ownSubsVar
+              , ownPosts = ownPostVar
+              , relayInQueue = relayInQueue'
+                                      }
+            port' = fromIntegral port
+            warpSettings = Warp.setPort port' . Warp.setHost (fromString host) $ Warp.defaultSettings
+        servThreadID <- forkIO $ Warp.runSettings warpSettings $ postServiceApplication thisService
+        -- update thread ID after fork
+        atomically $ writeTVar threadVar servThreadID
+        pure thisService
+
+    getServicePort s = fromIntegral $ psPort s
+
+
 -- | return a WAI application
-postServiceApplication :: Application
-postServiceApplication = serve exposedPostServiceAPI postServer
+postServiceApplication :: PostService d -> Application
+postServiceApplication serv = serve exposedPostServiceAPI $ postServer serv
 
 
 -- | needed for guiding type inference
@@ -78,7 +102,7 @@ exposedPostServiceAPI = Proxy
 
 -- ========= HTTP API and handlers =============
 
-type PostServiceAPI = "relay" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> PostCreated '[PlainText] Txt.Text
+type PostServiceAPI = "relay" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
                  -- ^ delivery endpoint of newly published posts of the relay's instance
                  :<|> "relay" :> "subscribers" :> ReqBody '[PlainText] Txt.Text :> Post '[PlainText] Txt.Text
                  -- ^ endpoint for delivering the subscriptions and outstanding queue
@@ -97,37 +121,51 @@ type PostServiceAPI = "relay" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> Pos
                  -- the Origin header to $hashtag
 
 
-postServer :: Server PostServiceAPI
-postServer = relayInbox
-        :<|> subscriptionDelivery
-        :<|> postFetch
-        :<|> postMultiFetch
-        :<|> tagDelivery
-        :<|> tagSubscribe
-        :<|> tagUnsubscribe
+postServer :: PostService d -> Server PostServiceAPI
+postServer service = relayInbox service
+        :<|> subscriptionDelivery service
+        :<|> postFetch service
+        :<|> postMultiFetch service
+        :<|> tagDelivery service
+        :<|> tagSubscribe service
+        :<|> tagUnsubscribe service
 
 
-relayInbox :: Txt.Text -> Handler Txt.Text
-relayInbox post = pure $ "Here be InboxDragons with " <> post
+relayInbox :: PostService d -> Txt.Text -> Handler NoContent
+relayInbox serv post = do
+    -- extract contained hashtags
+    let
+        containedTags = fmap Txt.tail . filter ((==) '#' . Txt.head) . Txt.words $ post
+    -- generate post ID
+    postId <- liftIO $ Txt.pack . show <$> (randomRIO (0, 2^128-1) :: IO Integer)
+    -- add ID to own posts
+    liftIO . atomically $ modifyTVar' (ownPosts serv) (HSet.insert postId)
+    -- enqueue a relay job for each tag
+    liftIO $ forM_ (containedTags :: [Txt.Text]) (\tag ->
+        atomically $ writeTQueue (relayInQueue serv) (tag, postId,  post)
+                                 )
+    pure NoContent
 
-subscriptionDelivery :: Txt.Text -> Handler Txt.Text
-subscriptionDelivery subList = pure $ "Here be Subscription List dragons: " <> subList
 
-postFetch :: Txt.Text -> Handler Txt.Text
-postFetch postID = pure $ "Here be a post with dragon ID " <> postID
 
-postMultiFetch :: Txt.Text -> Handler Txt.Text
-postMultiFetch postIDs = pure $ "Here be multiple post dragons: "
+subscriptionDelivery :: PostService d -> Txt.Text -> Handler Txt.Text
+subscriptionDelivery serv subList = pure $ "Here be Subscription List dragons: " <> subList
+
+postFetch :: PostService d -> Txt.Text -> Handler Txt.Text
+postFetch serv postID = pure $ "Here be a post with dragon ID " <> postID
+
+postMultiFetch :: PostService d -> Txt.Text -> Handler Txt.Text
+postMultiFetch serv postIDs = pure $ "Here be multiple post dragons: "
                       <> (Txt.unwords . Txt.lines $ postIDs)
 
-tagDelivery :: Txt.Text -> Txt.Text -> Handler Txt.Text
-tagDelivery hashtag posts = pure $ "Here be #" <> hashtag <> " dragons with " <> posts
+tagDelivery :: PostService d -> Txt.Text -> Txt.Text -> Handler Txt.Text
+tagDelivery serv hashtag posts = pure $ "Here be #" <> hashtag <> " dragons with " <> posts
 
-tagSubscribe :: Txt.Text -> Maybe Txt.Text -> Handler Integer
-tagSubscribe hashtag origin = pure 42
+tagSubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Integer
+tagSubscribe serv hashtag origin = pure 42
 
-tagUnsubscribe :: Txt.Text -> Maybe Txt.Text -> Handler Txt.Text
-tagUnsubscribe hashtag origin = pure $ "Here be a dragon unsubscription from " <> fromMaybe "Nothing" origin <> " to " <> hashtag
+tagUnsubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Text
+tagUnsubscribe serv hashtag origin = pure $ "Here be a dragon unsubscription from " <> fromMaybe "Nothing" origin <> " to " <> hashtag
 
 
 -- | define how to convert all showable types to PlainText
diff --git a/src/Hash2Pub/ServiceTypes.hs b/src/Hash2Pub/ServiceTypes.hs
index 430dc74..5e2b37c 100644
--- a/src/Hash2Pub/ServiceTypes.hs
+++ b/src/Hash2Pub/ServiceTypes.hs
@@ -1,9 +1,9 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 module Hash2Pub.ServiceTypes where
 
-import Data.Hashable (Hashable(..))
+import           Data.Hashable      (Hashable (..))
 
-import           Hash2Pub.FediChord (DHT (..), NodeID(..))
+import           Hash2Pub.FediChord (DHT (..), NodeID (..))
 
 class Service s d where
     -- | run the service

From 736815ea831bc7fdecd0f9680f3218b70684b6ce Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 27 Jul 2020 21:49:42 +0200
Subject: [PATCH 008/112] normalise hastag unicode representation of incoming
 posts

---
 Hash2Pub.cabal              | 2 +-
 src/Hash2Pub/PostService.hs | 4 +++-
 2 files changed, 4 insertions(+), 2 deletions(-)

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index 3ca520e..56441ad 100644
--- a/Hash2Pub.cabal
+++ b/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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable
+  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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms
   ghc-options:         -Wall
 
 
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index fc3e5e8..e44c8c6 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -21,6 +21,8 @@ import qualified Data.HashSet                  as HSet
 import           Data.Maybe                    (fromMaybe)
 import           Data.String                   (fromString)
 import qualified Data.Text.Lazy                as Txt
+import           Data.Text.Normalize           (NormalizationMode (NFC),
+                                                normalize)
 import           Data.Time.Clock.POSIX
 import           System.Random
 
@@ -135,7 +137,7 @@ relayInbox :: PostService d -> Txt.Text -> Handler NoContent
 relayInbox serv post = do
     -- extract contained hashtags
     let
-        containedTags = fmap Txt.tail . filter ((==) '#' . Txt.head) . Txt.words $ post
+        containedTags = fmap (Txt.fromStrict . normalize NFC . Txt.toStrict . Txt.tail) . filter ((==) '#' . Txt.head) . Txt.words $ post
     -- generate post ID
     postId <- liftIO $ Txt.pack . show <$> (randomRIO (0, 2^128-1) :: IO Integer)
     -- add ID to own posts

From 3b657574061700d83ab671cbaa8e6ce360c97094 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Tue, 28 Jul 2020 02:12:03 +0200
Subject: [PATCH 009/112] worker thread for processing incoming posts in
 background, started together with web server

---
 src/Hash2Pub/PostService.hs | 28 +++++++++++++++++++++++++++-
 1 file changed, 27 insertions(+), 1 deletion(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index e44c8c6..8811080 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -9,6 +9,7 @@
 module Hash2Pub.PostService where
 
 import           Control.Concurrent
+import           Control.Concurrent.Async
 import           Control.Concurrent.STM
 import           Control.Concurrent.STM.TChan
 import           Control.Concurrent.STM.TQueue
@@ -83,7 +84,14 @@ instance DHT d => Service PostService d where
                                       }
             port' = fromIntegral port
             warpSettings = Warp.setPort port' . Warp.setHost (fromString host) $ Warp.defaultSettings
-        servThreadID <- forkIO $ Warp.runSettings warpSettings $ postServiceApplication thisService
+        -- Run 'concurrently_' from another thread to be able to return the
+        -- 'PostService'.
+        -- Terminating that parent thread will make all child threads terminate as well.
+        servThreadID <- forkIO $
+            concurrently_
+                -- web server
+                (Warp.runSettings warpSettings $ postServiceApplication thisService)
+                (processIncomingPosts thisService)
         -- update thread ID after fork
         atomically $ writeTVar threadVar servThreadID
         pure thisService
@@ -175,3 +183,21 @@ tagUnsubscribe serv hashtag origin = pure $ "Here be a dragon unsubscription fro
 -- TODO: figure out how this overlapping stuff actually works https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#instance-overlap
 instance {-# OVERLAPPABLE #-} Show a => MimeRender PlainText a where
     mimeRender _ = BSU.fromString . show
+
+
+-- ====== worker threads ======
+
+-- | process the pending relays of incoming posts from the internal queue:
+-- Look up responsible relay node for given hashtag and forward post to it
+processIncomingPosts :: DHT d => PostService d -> IO ()
+processIncomingPosts serv = forever $ do
+    -- blocks until available
+    -- TODO: process multiple in parallel
+    (t, pID, pC) <- atomically . readTQueue $ relayInQueue serv
+    lookupRes <- lookupKey (baseDHT serv) (Txt.unpack t)
+    case lookupRes of
+      -- no vserver active => wait and retry
+      Nothing -> threadDelay $ 10 * 10^6
+      Just (responsibleHost, responsiblePort) -> do
+        -- TODO: do actual HTTP requests
+        pure ()

From 970c94ff0d51ce90d2d8b4d244087fe3536e1c31 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Tue, 28 Jul 2020 21:39:15 +0200
Subject: [PATCH 010/112] set up subscription data structures and transfer
 subscription endpoint

---
 src/Hash2Pub/PostService.hs | 74 +++++++++++++++++++++++++++++++++----
 1 file changed, 67 insertions(+), 7 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 8811080..9be7d1b 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -41,7 +41,7 @@ data PostService d = PostService
     -- queues, other data structures
     , baseDHT          ::   (DHT d) => d
     , serviceThread    :: TVar ThreadId
-    , subscribers      :: TVar (RingMap NodeID TagSubscribers)
+    , subscribers      :: TVar RelayTags
     -- ^ for each tag store the subscribers + their queue
     , ownSubscriptions :: TVar (HMap.HashMap NodeID POSIXTime)
     -- ^ tags subscribed by the own node have an assigned lease time
@@ -56,10 +56,10 @@ type PostID = Txt.Text
 type PostContent = Txt.Text
 -- | For each handled tag, store its subscribers and provide a
 -- broadcast 'TChan' for enqueuing posts
-type RelayTags = RingMap NodeID (TagSubscribers, TChan PostContent)
+type RelayTags = RingMap NodeID (TagSubscribers, TChan PostID, Hashtag)
 -- | each subscriber is identified by its contact data "hostname" "port"
 -- and holds a TChan duplicated from the broadcast TChan of the tag
-type TagSubscribers = HMap.HashMap (String, Int) (TChan PostContent)
+type TagSubscribers = TVar (HMap.HashMap (String, Int) (TChan PostID))
 
 
 instance DHT d => Service PostService d where
@@ -114,7 +114,7 @@ exposedPostServiceAPI = Proxy
 
 type PostServiceAPI = "relay" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
                  -- ^ delivery endpoint of newly published posts of the relay's instance
-                 :<|> "relay" :> "subscribers" :> ReqBody '[PlainText] Txt.Text :> Post '[PlainText] Txt.Text
+                 :<|> "relay" :> "subscribers" :> ReqBody '[PlainText] Txt.Text :> PostNoContent '[PlainText] NoContent
                  -- ^ endpoint for delivering the subscriptions and outstanding queue
                  :<|> "post" :> Capture "postid" Txt.Text :> Get '[PlainText] Txt.Text
                  -- ^ fetch endpoint for posts, full post ID is http://$domain/post/$postid
@@ -145,7 +145,7 @@ relayInbox :: PostService d -> Txt.Text -> Handler NoContent
 relayInbox serv post = do
     -- extract contained hashtags
     let
-        containedTags = fmap (Txt.fromStrict . normalize NFC . Txt.toStrict . Txt.tail) . filter ((==) '#' . Txt.head) . Txt.words $ post
+        containedTags = fmap (normaliseTag . Txt.tail) . filter ((==) '#' . Txt.head) . Txt.words $ post
     -- generate post ID
     postId <- liftIO $ Txt.pack . show <$> (randomRIO (0, 2^128-1) :: IO Integer)
     -- add ID to own posts
@@ -158,8 +158,25 @@ relayInbox serv post = do
 
 
 
-subscriptionDelivery :: PostService d -> Txt.Text -> Handler Txt.Text
-subscriptionDelivery serv subList = pure $ "Here be Subscription List dragons: " <> subList
+subscriptionDelivery :: PostService d -> Txt.Text -> Handler NoContent
+subscriptionDelivery serv subList = do
+    let
+        tagSubs = Txt.lines subList
+    liftIO $ forM_ tagSubs $ processTag (subscribers serv)
+    pure NoContent
+    -- TODO: check and only accept tags in own (future?) responsibility
+  where
+      processTag :: TVar RelayTags -> Txt.Text -> IO ()
+      processTag subscriberSTM tagData = do
+          let
+            tag:subText:posts:_ = Txt.splitOn "," tagData
+            sub = read . Txt.unpack $ subText :: (String, Int)
+            postList = Txt.words posts
+          enqueueSubscriptions subscriberSTM (normaliseTag tag) sub postList
+
+
+
+
 
 postFetch :: PostService d -> Txt.Text -> Handler Txt.Text
 postFetch serv postID = pure $ "Here be a post with dragon ID " <> postID
@@ -178,6 +195,49 @@ tagUnsubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Tex
 tagUnsubscribe serv hashtag origin = pure $ "Here be a dragon unsubscription from " <> fromMaybe "Nothing" origin <> " to " <> hashtag
 
 
+-- ======= data structure manipulations =========
+
+-- | Write all pending posts of a subscriber-tag-combination to its queue.
+-- Sets up all necessary data structures if they are still missing.
+enqueueSubscriptions :: TVar RelayTags    -- tag-subscriber map
+                     -> Hashtag         -- hashtag of pending posts
+                     -> (String, Int)   -- subscriber's connection information
+                     -> [PostID]        -- pending posts
+                     -> IO ()
+enqueueSubscriptions tagMapSTM tag subscriber posts = do
+    -- get the tag output queue and, if necessary, create it
+    subChan <- atomically setupSubscriberChannel
+    forM_ posts (atomically . writeTChan subChan)
+  where
+      setupSubscriberChannel :: STM (TChan PostID)
+      setupSubscriberChannel = do
+          tagMap <- readTVar tagMapSTM
+          case rMapLookup (genKeyID . Txt.unpack $ tag) tagMap of
+            Nothing -> do
+              -- if no collision/ tag doesn't exist yet, just initialize a
+              -- new subscriber map
+              broadcastChan <- newBroadcastTChan
+              tagOutChan <- dupTChan broadcastChan
+              newSubMapSTM <- newTVar $ HMap.singleton subscriber tagOutChan
+              writeTVar tagMapSTM $ addRMapEntry (genKeyID . Txt.unpack $ tag) (newSubMapSTM, broadcastChan, tag) tagMap
+              pure tagOutChan
+            Just (foundSubMapSTM, broadcastChan, _) -> do
+              -- otherwise use the existing subscriber map
+              foundSubMap <- readTVar foundSubMapSTM
+              case HMap.lookup subscriber foundSubMap of
+                Nothing -> do
+                  -- for new subscribers, create new output channel
+                  tagOutChan <- dupTChan broadcastChan
+                  writeTVar foundSubMapSTM $ HMap.insert subscriber tagOutChan foundSubMap
+                  pure tagOutChan
+                -- existing subscriber's channels are just returned
+                Just tagOutChan -> pure tagOutChan
+
+
+-- normalise the unicode representation of a string to NFC
+normaliseTag :: Txt.Text -> Txt.Text
+normaliseTag = Txt.fromStrict . normalize NFC . Txt.toStrict
+
 -- | define how to convert all showable types to PlainText
 -- No idea what I'm doing with these overlappable instances though ¯\_(ツ)_/¯
 -- TODO: figure out how this overlapping stuff actually works https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#instance-overlap

From 63bc06a88e3e6827c92a4ea51f4ec447de000dc5 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Tue, 28 Jul 2020 23:45:21 +0200
Subject: [PATCH 011/112] implement post fetch (with placeholder content)

---
 src/Hash2Pub/PostService.hs | 13 +++++++++----
 1 file changed, 9 insertions(+), 4 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 9be7d1b..ef22e29 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -108,7 +108,10 @@ postServiceApplication serv = serve exposedPostServiceAPI $ postServer serv
 exposedPostServiceAPI :: Proxy PostServiceAPI
 exposedPostServiceAPI = Proxy
 
+-- ========= constants ===========
 
+placeholderPost :: Txt.Text
+placeholderPost = Txt.take 5120 . Txt.repeat $ 'O' -- size 5KiB
 
 -- ========= HTTP API and handlers =============
 
@@ -175,11 +178,13 @@ subscriptionDelivery serv subList = do
           enqueueSubscriptions subscriberSTM (normaliseTag tag) sub postList
 
 
-
-
-
 postFetch :: PostService d -> Txt.Text -> Handler Txt.Text
-postFetch serv postID = pure $ "Here be a post with dragon ID " <> postID
+postFetch serv postID = do
+    postSet <- liftIO . readTVarIO . ownPosts $ serv
+    if HSet.member postID postSet
+       -- decision: always return the same placeholder post
+       then pure placeholderPost
+       else throwError $ err404 { errBody = "No post found with this ID" }
 
 postMultiFetch :: PostService d -> Txt.Text -> Handler Txt.Text
 postMultiFetch serv postIDs = pure $ "Here be multiple post dragons: "

From bd70e2dff02ea98b7d892d3a97d92f6df84fd4fe Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 29 Jul 2020 00:06:16 +0200
Subject: [PATCH 012/112] implement multiple post fetch (with placeholder
 content)

---
 src/Hash2Pub/PostService.hs | 16 ++++++++++++----
 1 file changed, 12 insertions(+), 4 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index ef22e29..169d2b7 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -14,7 +14,7 @@ import           Control.Concurrent.STM
 import           Control.Concurrent.STM.TChan
 import           Control.Concurrent.STM.TQueue
 import           Control.Concurrent.STM.TVar
-import           Control.Monad                 (forM_, forever)
+import           Control.Monad                 (foldM, forM_, forever)
 import           Control.Monad.IO.Class        (liftIO)
 import qualified Data.ByteString.Lazy.UTF8     as BSU
 import qualified Data.HashMap.Strict           as HMap
@@ -150,7 +150,7 @@ relayInbox serv post = do
     let
         containedTags = fmap (normaliseTag . Txt.tail) . filter ((==) '#' . Txt.head) . Txt.words $ post
     -- generate post ID
-    postId <- liftIO $ Txt.pack . show <$> (randomRIO (0, 2^128-1) :: IO Integer)
+    postId <- liftIO $ Txt.pack . show <$> (randomRIO (0, 2^(128::Integer)-1) :: IO Integer)
     -- add ID to own posts
     liftIO . atomically $ modifyTVar' (ownPosts serv) (HSet.insert postId)
     -- enqueue a relay job for each tag
@@ -186,9 +186,17 @@ postFetch serv postID = do
        then pure placeholderPost
        else throwError $ err404 { errBody = "No post found with this ID" }
 
+
 postMultiFetch :: PostService d -> Txt.Text -> Handler Txt.Text
-postMultiFetch serv postIDs = pure $ "Here be multiple post dragons: "
-                      <> (Txt.unwords . Txt.lines $ postIDs)
+postMultiFetch serv postIDs = do
+    let idList = Txt.lines postIDs
+    postSet <- liftIO . readTVarIO . ownPosts $ serv
+    -- look up existence of all given post IDs, fail if even one is missing
+    foldM (\response postID ->
+        if HSet.member postID postSet
+           then pure $ placeholderPost <> "\n" <> response
+           else throwError $ err404 { errBody = "No post found with this ID" }
+          ) "" idList
 
 tagDelivery :: PostService d -> Txt.Text -> Txt.Text -> Handler Txt.Text
 tagDelivery serv hashtag posts = pure $ "Here be #" <> hashtag <> " dragons with " <> posts

From ad52a017aa18c92188ddf89a3edc8e16340d1132 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 29 Jul 2020 22:15:14 +0200
Subject: [PATCH 013/112] add relay inbox endpoint

---
 src/Hash2Pub/PostService.hs | 74 ++++++++++++++++++++++++++++---------
 1 file changed, 56 insertions(+), 18 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 169d2b7..059ebe5 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -56,10 +56,11 @@ type PostID = Txt.Text
 type PostContent = Txt.Text
 -- | For each handled tag, store its subscribers and provide a
 -- broadcast 'TChan' for enqueuing posts
-type RelayTags = RingMap NodeID (TagSubscribers, TChan PostID, Hashtag)
+type RelayTags = RingMap NodeID (TagSubscribersSTM, TChan PostID, Hashtag)
+type TagSubscribersSTM = TVar TagSubscribers
 -- | each subscriber is identified by its contact data "hostname" "port"
 -- and holds a TChan duplicated from the broadcast TChan of the tag
-type TagSubscribers = TVar (HMap.HashMap (String, Int) (TChan PostID))
+type TagSubscribers = (HMap.HashMap (String, Int) (TChan PostID))
 
 
 instance DHT d => Service PostService d where
@@ -115,7 +116,7 @@ placeholderPost = Txt.take 5120 . Txt.repeat $ 'O' -- size 5KiB
 
 -- ========= HTTP API and handlers =============
 
-type PostServiceAPI = "relay" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
+type PostServiceAPI = "relay" :> "inbox" :> Capture "hashtag" Txt.Text :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
                  -- ^ delivery endpoint of newly published posts of the relay's instance
                  :<|> "relay" :> "subscribers" :> ReqBody '[PlainText] Txt.Text :> PostNoContent '[PlainText] NoContent
                  -- ^ endpoint for delivering the subscriptions and outstanding queue
@@ -123,6 +124,8 @@ type PostServiceAPI = "relay" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> Put
                  -- ^ fetch endpoint for posts, full post ID is http://$domain/post/$postid
                  :<|> "posts" :> ReqBody '[PlainText] Txt.Text :> Post '[PlainText] Txt.Text
                  -- ^ endpoint for fetching multiple posts at once
+                 :<|> "posts" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
+                 -- ^ delivery endpoint of newly published posts of the relay's instance
                  :<|> "tags" :> Capture "hashtag" Txt.Text :> ReqBody '[PlainText] Txt.Text :> PostCreated '[PlainText] Txt.Text
                  -- ^ delivery endpoint for posts of $tag at subscribing instance
                  :<|> "tags" :> Capture "hashtag" Txt.Text :> "subscribe" :> Header "Origin" Txt.Text :> Get '[PlainText] Integer
@@ -139,28 +142,28 @@ postServer service = relayInbox service
         :<|> subscriptionDelivery service
         :<|> postFetch service
         :<|> postMultiFetch service
+        :<|> postInbox service
         :<|> tagDelivery service
         :<|> tagSubscribe service
         :<|> tagUnsubscribe service
 
 
-relayInbox :: PostService d -> Txt.Text -> Handler NoContent
-relayInbox serv post = do
-    -- extract contained hashtags
+relayInbox :: PostService d -> Hashtag -> Txt.Text -> Handler NoContent
+relayInbox serv tag posts = do
     let
-        containedTags = fmap (normaliseTag . Txt.tail) . filter ((==) '#' . Txt.head) . Txt.words $ post
-    -- generate post ID
-    postId <- liftIO $ Txt.pack . show <$> (randomRIO (0, 2^(128::Integer)-1) :: IO Integer)
-    -- add ID to own posts
-    liftIO . atomically $ modifyTVar' (ownPosts serv) (HSet.insert postId)
-    -- enqueue a relay job for each tag
-    liftIO $ forM_ (containedTags :: [Txt.Text]) (\tag ->
-        atomically $ writeTQueue (relayInQueue serv) (tag, postId,  post)
-                                 )
+    -- skip checking whether the post actually contains the tag, just drop full post
+        postIDs = head . Txt.splitOn "," <$> Txt.lines posts
+    broadcastChan <- liftIO $ atomically $ getTagBroadcastChannel serv tag
+    -- if tag is not in own responsibility, return a 410 Gone
+    maybe
+        (throwError $ err410 { errBody = "Relay is not responsible for this tag"})
+    -- otherwise enqueue posts into broadcast queue of the tag
+        (\queue ->
+            liftIO $ forM_ postIDs (atomically . writeTChan queue)
+        )
+        broadcastChan
     pure NoContent
 
-
-
 subscriptionDelivery :: PostService d -> Txt.Text -> Handler NoContent
 subscriptionDelivery serv subList = do
     let
@@ -198,6 +201,23 @@ postMultiFetch serv postIDs = do
            else throwError $ err404 { errBody = "No post found with this ID" }
           ) "" idList
 
+
+postInbox :: PostService d -> Txt.Text -> Handler NoContent
+postInbox serv post = do
+    -- extract contained hashtags
+    let
+        containedTags = fmap (normaliseTag . Txt.tail) . filter ((==) '#' . Txt.head) . Txt.words $ post
+    -- generate post ID
+    postId <- liftIO $ Txt.pack . show <$> (randomRIO (0, 2^(128::Integer)-1) :: IO Integer)
+    -- add ID to own posts
+    liftIO . atomically $ modifyTVar' (ownPosts serv) (HSet.insert postId)
+    -- enqueue a relay job for each tag
+    liftIO $ forM_ (containedTags :: [Txt.Text]) (\tag ->
+        atomically $ writeTQueue (relayInQueue serv) (tag, postId,  post)
+                                 )
+    pure NoContent
+
+
 tagDelivery :: PostService d -> Txt.Text -> Txt.Text -> Handler Txt.Text
 tagDelivery serv hashtag posts = pure $ "Here be #" <> hashtag <> " dragons with " <> posts
 
@@ -225,7 +245,7 @@ enqueueSubscriptions tagMapSTM tag subscriber posts = do
       setupSubscriberChannel :: STM (TChan PostID)
       setupSubscriberChannel = do
           tagMap <- readTVar tagMapSTM
-          case rMapLookup (genKeyID . Txt.unpack $ tag) tagMap of
+          case lookupRelayTags tag tagMap of
             Nothing -> do
               -- if no collision/ tag doesn't exist yet, just initialize a
               -- new subscriber map
@@ -247,6 +267,24 @@ enqueueSubscriptions tagMapSTM tag subscriber posts = do
                 Just tagOutChan -> pure tagOutChan
 
 
+-- | returns the broadcast channel of a hashtag if there are any subscribers to it
+getTagBroadcastChannel :: PostService d -> Hashtag -> STM (Maybe (TChan PostID))
+getTagBroadcastChannel serv tag = do
+    tagMap <- readTVar $ subscribers serv
+    case lookupRelayTags tag tagMap of
+      Nothing -> pure Nothing
+      Just (subscriberSTM, broadcastChan, _) -> do
+          subscriberMap <- readTVar subscriberSTM
+          if HMap.null subscriberMap
+             then pure Nothing
+             else pure (Just broadcastChan)
+
+
+-- | look up the subscription data of a tag
+lookupRelayTags :: Hashtag -> RelayTags -> Maybe (TagSubscribersSTM, TChan PostID, Hashtag)
+lookupRelayTags tag = rMapLookup (genKeyID . Txt.unpack $ tag)
+
+
 -- normalise the unicode representation of a string to NFC
 normaliseTag :: Txt.Text -> Txt.Text
 normaliseTag = Txt.fromStrict . normalize NFC . Txt.toStrict

From da47f8062fc155f3d4b163b4fb9770969f423c23 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 29 Jul 2020 23:06:07 +0200
Subject: [PATCH 014/112] add lease time to subscription entries

---
 src/Hash2Pub/PostService.hs | 67 ++++++++++++++++++++-----------------
 1 file changed, 37 insertions(+), 30 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 059ebe5..81b00a3 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -60,7 +60,8 @@ type RelayTags = RingMap NodeID (TagSubscribersSTM, TChan PostID, Hashtag)
 type TagSubscribersSTM = TVar TagSubscribers
 -- | each subscriber is identified by its contact data "hostname" "port"
 -- and holds a TChan duplicated from the broadcast TChan of the tag
-type TagSubscribers = (HMap.HashMap (String, Int) (TChan PostID))
+-- + an expiration timestamp
+type TagSubscribers = (HMap.HashMap (String, Int) (TChan PostID, POSIXTime))
 
 
 instance DHT d => Service PostService d where
@@ -175,10 +176,12 @@ subscriptionDelivery serv subList = do
       processTag :: TVar RelayTags -> Txt.Text -> IO ()
       processTag subscriberSTM tagData = do
           let
-            tag:subText:posts:_ = Txt.splitOn "," tagData
+            tag:subText:lease:posts:_ = Txt.splitOn "," tagData
+            -- ignore checking of lease time
+            leaseTime = fromIntegral (read . Txt.unpack $ lease :: Integer)
             sub = read . Txt.unpack $ subText :: (String, Int)
             postList = Txt.words posts
-          enqueueSubscriptions subscriberSTM (normaliseTag tag) sub postList
+          enqueueSubscription subscriberSTM (normaliseTag tag) sub postList leaseTime
 
 
 postFetch :: PostService d -> Txt.Text -> Handler Txt.Text
@@ -232,39 +235,43 @@ tagUnsubscribe serv hashtag origin = pure $ "Here be a dragon unsubscription fro
 
 -- | Write all pending posts of a subscriber-tag-combination to its queue.
 -- Sets up all necessary data structures if they are still missing.
-enqueueSubscriptions :: TVar RelayTags    -- tag-subscriber map
+enqueueSubscription :: TVar RelayTags    -- tag-subscriber map
                      -> Hashtag         -- hashtag of pending posts
                      -> (String, Int)   -- subscriber's connection information
                      -> [PostID]        -- pending posts
+                     -> POSIXTime       -- lease expiry time
                      -> IO ()
-enqueueSubscriptions tagMapSTM tag subscriber posts = do
+enqueueSubscription tagMapSTM tag subscriber posts leaseTime = do
     -- get the tag output queue and, if necessary, create it
-    subChan <- atomically setupSubscriberChannel
+    subChan <- atomically $ setupSubscriberChannel tagMapSTM tag subscriber leaseTime
     forM_ posts (atomically . writeTChan subChan)
-  where
-      setupSubscriberChannel :: STM (TChan PostID)
-      setupSubscriberChannel = do
-          tagMap <- readTVar tagMapSTM
-          case lookupRelayTags tag tagMap of
-            Nothing -> do
-              -- if no collision/ tag doesn't exist yet, just initialize a
-              -- new subscriber map
-              broadcastChan <- newBroadcastTChan
-              tagOutChan <- dupTChan broadcastChan
-              newSubMapSTM <- newTVar $ HMap.singleton subscriber tagOutChan
-              writeTVar tagMapSTM $ addRMapEntry (genKeyID . Txt.unpack $ tag) (newSubMapSTM, broadcastChan, tag) tagMap
-              pure tagOutChan
-            Just (foundSubMapSTM, broadcastChan, _) -> do
-              -- otherwise use the existing subscriber map
-              foundSubMap <- readTVar foundSubMapSTM
-              case HMap.lookup subscriber foundSubMap of
-                Nothing -> do
-                  -- for new subscribers, create new output channel
-                  tagOutChan <- dupTChan broadcastChan
-                  writeTVar foundSubMapSTM $ HMap.insert subscriber tagOutChan foundSubMap
-                  pure tagOutChan
-                -- existing subscriber's channels are just returned
-                Just tagOutChan -> pure tagOutChan
+
+
+-- | STM operation to return the outgoing post queue of a tag to a specified subscriber.
+-- If the queue doesn't exist yet, all necessary data structures are set up accordingly.
+setupSubscriberChannel :: TVar RelayTags -> Hashtag -> (String, Int) -> POSIXTime -> STM (TChan PostID)
+setupSubscriberChannel tagMapSTM tag subscriber leaseTime = do
+    tagMap <- readTVar tagMapSTM
+    case lookupRelayTags tag tagMap of
+      Nothing -> do
+        -- if no collision/ tag doesn't exist yet, just initialize a
+        -- new subscriber map
+        broadcastChan <- newBroadcastTChan
+        tagOutChan <- dupTChan broadcastChan
+        newSubMapSTM <- newTVar $ HMap.singleton subscriber (tagOutChan, leaseTime)
+        writeTVar tagMapSTM $ addRMapEntry (genKeyID . Txt.unpack $ tag) (newSubMapSTM, broadcastChan, tag) tagMap
+        pure tagOutChan
+      Just (foundSubMapSTM, broadcastChan, _) -> do
+        -- otherwise use the existing subscriber map
+        foundSubMap <- readTVar foundSubMapSTM
+        case HMap.lookup subscriber foundSubMap of
+          Nothing -> do
+            -- for new subscribers, create new output channel
+            tagOutChan <- dupTChan broadcastChan
+            writeTVar foundSubMapSTM $ HMap.insert subscriber (tagOutChan, leaseTime) foundSubMap
+            pure tagOutChan
+          -- existing subscriber's channels are just returned
+          Just (tagOutChan, _) -> pure tagOutChan
 
 
 -- | returns the broadcast channel of a hashtag if there are any subscribers to it

From 98ca0ff13e2996aa45d7bcfab695143689ae8650 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 30 Jul 2020 01:21:56 +0200
Subject: [PATCH 015/112] service config, integrate service launch into DHT
 launch

TODO: hold a reference from DHT to service
---
 Hash2Pub.cabal                 |  2 +-
 app/Main.hs                    | 20 +++++++++++++++-----
 src/Hash2Pub/FediChord.hs      | 11 +++++++++--
 src/Hash2Pub/FediChordTypes.hs | 25 +++++++++++++++++++++++++
 src/Hash2Pub/PostService.hs    | 15 ++++++---------
 src/Hash2Pub/ServiceTypes.hs   | 15 ---------------
 6 files changed, 56 insertions(+), 32 deletions(-)
 delete mode 100644 src/Hash2Pub/ServiceTypes.hs

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index 56441ad..54cb29d 100644
--- a/Hash2Pub.cabal
+++ b/Hash2Pub.cabal
@@ -55,7 +55,7 @@ library
   import: deps
 
   -- Modules exported by the library.
-  exposed-modules:     Hash2Pub.FediChord, Hash2Pub.FediChordTypes, Hash2Pub.DHTProtocol, Hash2Pub.ASN1Coding, Hash2Pub.ProtocolTypes, Hash2Pub.PostService, Hash2Pub.ServiceTypes, Hash2Pub.RingMap
+  exposed-modules:     Hash2Pub.FediChord, Hash2Pub.FediChordTypes, Hash2Pub.DHTProtocol, Hash2Pub.ASN1Coding, Hash2Pub.ProtocolTypes, Hash2Pub.PostService, Hash2Pub.RingMap
 
   -- Modules included in this library but not exported.
   other-modules: Hash2Pub.Utils
diff --git a/app/Main.hs b/app/Main.hs
index 8887ee8..98961c0 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -10,15 +10,17 @@ import           Data.IP                     (IPv6, toHostAddress6)
 import           System.Environment
 
 import           Hash2Pub.FediChord
+import           Hash2Pub.FediChordTypes
+import           Hash2Pub.PostService        (PostService (..))
 
 main :: IO ()
 main = do
     -- ToDo: parse and pass config
     -- probably use `tomland` for that
-    conf <- readConfig
+    (fConf, sConf) <- readConfig
     -- TODO: first initialise 'RealNode', then the vservers
     -- ToDo: load persisted caches, bootstrapping nodes …
-    (serverSock, thisNode) <- fediChordInit conf
+    (serverSock, thisNode) <- fediChordInit fConf (runService sConf :: DHT d => d -> IO (PostService d))
     -- currently no masking is necessary, as there is nothing to clean up
     nodeCacheWriterThread <- forkIO $ nodeCacheWriter thisNode
     -- try joining the DHT using one of the provided bootstrapping nodes
@@ -41,10 +43,11 @@ main = do
     pure ()
 
 
-readConfig :: IO FediChordConf
+readConfig :: IO (FediChordConf, ServiceConf)
 readConfig = do
-    confDomainString : ipString : portString : bootstrapHost : bootstrapPortString : _ <- getArgs
-    pure $ FediChordConf {
+    confDomainString : ipString : portString : bootstrapHost : bootstrapPortString : servicePortString : speedup : _ <- getArgs
+    let
+        fConf = FediChordConf {
         confDomain = confDomainString
       , confIP = toHostAddress6 . read $ ipString
       , confDhtPort = read portString
@@ -53,3 +56,10 @@ readConfig = do
       , confBootstrapSamplingInterval = 180
       , confMaxLookupCacheAge = 300
                            }
+        sConf = ServiceConf {
+        confSubscriptionExpiryTime = 2*3600 `div` read speedup
+                            , confServicePort = read servicePortString
+                            , confServiceHost = confDomainString
+                            }
+    pure (fConf, sConf)
+
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 26a373c..7a5abb0 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -95,16 +95,23 @@ import           Debug.Trace                   (trace)
 
 -- | 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, LocalNodeStateSTM)
-fediChordInit initConf = do
+--fediChordInit :: (DHT d, Service s d)
+--              => FediChordConf
+--              -> (d -> s d)     -- ^ runner function for service
+--              -> IO (Socket, LocalNodeStateSTM)
+fediChordInit initConf serviceRunner = do
     emptyLookupCache <- newTVarIO Map.empty
     let realNode = RealNode {
             vservers = []
           , nodeConfig = initConf
           , bootstrapNodes = confBootstrapNodes initConf
           , lookupCacheSTM = emptyLookupCache
+          --, service = undefined
                             }
     realNodeSTM <- newTVarIO realNode
+    -- launch service and set the reference in the RealNode
+    serv <- serviceRunner realNodeSTM
+    --atomically . writeTVar $ realNode { service = serv }
     initialState <- nodeStateInit realNodeSTM
     initialStateSTM <- newTVarIO initialState
     serverSock <- mkServerSocket (getIpAddr initialState) (getDhtPort initialState)
diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs
index d764b71..604519e 100644
--- a/src/Hash2Pub/FediChordTypes.hs
+++ b/src/Hash2Pub/FediChordTypes.hs
@@ -58,11 +58,14 @@ module Hash2Pub.FediChordTypes (
   , bsAsIpAddr
   , FediChordConf(..)
   , DHT(..)
+  , Service(..)
+  , ServiceConf(..)
                            ) where
 
 import           Control.Exception
 import           Data.Foldable                 (foldr')
 import           Data.Function                 (on)
+import qualified Data.Hashable                 as Hashable
 import           Data.List                     (delete, nub, sortBy)
 import qualified Data.Map.Strict               as Map
 import           Data.Maybe                    (fromJust, fromMaybe, isJust,
@@ -144,6 +147,7 @@ a `localCompare` b
 -- | Data for managing the virtual server nodes of this real node.
 -- Also contains shared data and config values.
 -- TODO: more data structures for k-choices bookkeeping
+--data RealNode s = RealNode
 data RealNode = RealNode
     { vservers       :: [LocalNodeStateSTM]
     -- ^ references to all active versers
@@ -155,6 +159,7 @@ data RealNode = RealNode
     -- ^ a global cache of looked up keys and their associated nodes
     }
 
+--type RealNodeSTM s = TVar (RealNode s)
 type RealNodeSTM = TVar RealNode
 
 -- | represents a node and all its important state
@@ -411,6 +416,26 @@ data FediChordConf = FediChordConf
     }
     deriving (Show, Eq)
 
+-- ====== Service Types ============
+
+class Service s d where
+    -- | run the service
+    runService :: ServiceConf -> d -> IO (s d)
+    getServicePort' :: (Integral i) => s d -> i
+
+instance Hashable.Hashable NodeID where
+    hashWithSalt salt = Hashable.hashWithSalt salt . getNodeID
+    hash = Hashable.hash . getNodeID
+
+data ServiceConf = ServiceConf
+    { confSubscriptionExpiryTime :: Integer
+    -- ^ subscription lease expiration in seconds
+    , confServicePort            :: Int
+    -- ^ listening port for service
+    , confServiceHost            :: String
+    -- ^ hostname of service
+    }
+
 class DHT d where
     -- | lookup the responsible host handling a given key string,
     -- possiblggy from a lookup cache
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 81b00a3..264bccb 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -32,12 +32,10 @@ import           Servant
 
 import           Hash2Pub.FediChordTypes
 import           Hash2Pub.RingMap
-import           Hash2Pub.ServiceTypes
 
 
 data PostService d = PostService
-    { psPort           :: Warp.Port
-    , psHost           :: String
+    { serviceConf      :: ServiceConf
     -- queues, other data structures
     , baseDHT          ::   (DHT d) => d
     , serviceThread    :: TVar ThreadId
@@ -66,7 +64,7 @@ type TagSubscribers = (HMap.HashMap (String, Int) (TChan PostID, POSIXTime))
 
 instance DHT d => Service PostService d where
     -- | initialise 'PostService' data structures and run server
-    runService dht host port = do
+    runService conf dht = do
         -- create necessary TVars
         threadVar <- newTVarIO =<< myThreadId -- own thread ID as placeholder
         subscriberVar <- newTVarIO emptyRMap
@@ -75,8 +73,7 @@ instance DHT d => Service PostService d where
         relayInQueue' <- newTQueueIO
         let
             thisService = PostService {
-                psPort = port'
-              , psHost = host
+                serviceConf = conf
               , baseDHT = dht
               , serviceThread = threadVar
               , subscribers = subscriberVar
@@ -84,8 +81,8 @@ instance DHT d => Service PostService d where
               , ownPosts = ownPostVar
               , relayInQueue = relayInQueue'
                                       }
-            port' = fromIntegral port
-            warpSettings = Warp.setPort port' . Warp.setHost (fromString host) $ Warp.defaultSettings
+            port' = fromIntegral (confServicePort conf)
+            warpSettings = Warp.setPort port' . Warp.setHost (fromString . confServiceHost $ conf) $ Warp.defaultSettings
         -- Run 'concurrently_' from another thread to be able to return the
         -- 'PostService'.
         -- Terminating that parent thread will make all child threads terminate as well.
@@ -98,7 +95,7 @@ instance DHT d => Service PostService d where
         atomically $ writeTVar threadVar servThreadID
         pure thisService
 
-    getServicePort s = fromIntegral $ psPort s
+    getServicePort' = fromIntegral . confServicePort . serviceConf
 
 
 -- | return a WAI application
diff --git a/src/Hash2Pub/ServiceTypes.hs b/src/Hash2Pub/ServiceTypes.hs
deleted file mode 100644
index 5e2b37c..0000000
--- a/src/Hash2Pub/ServiceTypes.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-module Hash2Pub.ServiceTypes where
-
-import           Data.Hashable      (Hashable (..))
-
-import           Hash2Pub.FediChord (DHT (..), NodeID (..))
-
-class Service s d where
-    -- | run the service
-    runService :: (Integral i) => d -> String -> i -> IO (s d)
-    getServicePort :: (Integral i) => s d -> i
-
-instance Hashable NodeID where
-    hashWithSalt salt = hashWithSalt salt . getNodeID
-    hash = hash . getNodeID

From 4bf80911432da8db7b1d5bc9278885310c1517c7 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 30 Jul 2020 01:30:42 +0200
Subject: [PATCH 016/112] fix type signature of fediChordInit

---
 src/Hash2Pub/FediChord.hs | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 7a5abb0..70c9ff7 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -95,10 +95,10 @@ import           Debug.Trace                   (trace)
 
 -- | initialise data structures, compute own IDs and bind to listening socket
 -- ToDo: load persisted state, thus this function already operates in IO
---fediChordInit :: (DHT d, Service s d)
---              => FediChordConf
---              -> (d -> s d)     -- ^ runner function for service
---              -> IO (Socket, LocalNodeStateSTM)
+fediChordInit :: (Service s RealNodeSTM)
+              => FediChordConf
+              -> (RealNodeSTM -> IO (s RealNodeSTM))     -- ^ runner function for service
+              -> IO (Socket, LocalNodeStateSTM)
 fediChordInit initConf serviceRunner = do
     emptyLookupCache <- newTVarIO Map.empty
     let realNode = RealNode {

From 5ffe1b074e723f8ffaa29716baf066fe08f79a7d Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 30 Jul 2020 02:19:26 +0200
Subject: [PATCH 017/112] add reference from RealNode to Service

This required to make both RealNode(STM) and LocalNodeState(STM) parameterisable
polymorphic types
---
 src/Hash2Pub/DHTProtocol.hs    | 44 +++++++++++++-------------
 src/Hash2Pub/FediChord.hs      | 57 ++++++++++++++++------------------
 src/Hash2Pub/FediChordTypes.hs | 30 +++++++++---------
 src/Hash2Pub/PostService.hs    |  2 ++
 test/FediChordSpec.hs          |  2 +-
 5 files changed, 68 insertions(+), 67 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index 546c10f..f962d58 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -92,7 +92,7 @@ import           Debug.Trace                    (trace)
 
 -- 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 :: LocalNodeState -> NodeCache -> Int -> NodeID -> QueryResponse
+queryLocalCache :: LocalNodeState s -> 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
     -- This only makes sense if the node is part of the DHT by having joined.
@@ -130,7 +130,7 @@ closestCachePredecessors remainingLookups lastID nCache
 -- Looks up the successor of the lookup key on a 'RingMap' representation of the
 -- predecessor list with the node itself added. If the result is the same as the node
 -- itself then it falls into the responsibility interval.
-isInOwnResponsibilitySlice :: HasKeyID NodeID a => a -> LocalNodeState -> Bool
+isInOwnResponsibilitySlice :: HasKeyID NodeID a => a -> LocalNodeState s -> Bool
 isInOwnResponsibilitySlice lookupTarget ownNs = (fst <$> rMapLookupSucc (getKeyID lookupTarget :: NodeID) predecessorRMap) == pure (getNid ownNs)
   where
     predecessorList = predecessors ownNs
@@ -140,10 +140,10 @@ isInOwnResponsibilitySlice lookupTarget ownNs = (fst <$> rMapLookupSucc (getKeyI
     ownRemote = toRemoteNodeState ownNs
     closestPredecessor = headMay predecessorList
 
-isPossiblePredecessor :: HasKeyID NodeID a => a -> LocalNodeState -> Bool
+isPossiblePredecessor :: HasKeyID NodeID a => a -> LocalNodeState s -> Bool
 isPossiblePredecessor = isInOwnResponsibilitySlice
 
-isPossibleSuccessor :: HasKeyID NodeID a => a -> LocalNodeState -> Bool
+isPossibleSuccessor :: HasKeyID NodeID a => a -> LocalNodeState s -> Bool
 isPossibleSuccessor lookupTarget ownNs = (fst <$> rMapLookupPred (getKeyID lookupTarget :: NodeID) successorRMap) == pure (getNid ownNs)
   where
     successorList = successors ownNs
@@ -224,7 +224,7 @@ markCacheEntryAsVerified timestamp nid = RingMap . Map.adjust adjustFunc nid . g
 
 -- | uses the successor and predecessor list of a node as an indicator for whether a
 -- node has properly joined the DHT
-isJoined :: LocalNodeState -> Bool
+isJoined :: LocalNodeState s -> Bool
 isJoined ns = not . all null $ [successors ns, predecessors ns]
 
 -- | the size limit to be used when serialising messages for sending
@@ -248,7 +248,7 @@ ackRequest _ _ = Map.empty
 
 -- | Dispatch incoming requests to the dedicated handling and response function, and enqueue
 -- the response to be sent.
-handleIncomingRequest :: LocalNodeStateSTM                     -- ^ the handling node
+handleIncomingRequest :: LocalNodeStateSTM s                     -- ^ the handling node
                       -> TQueue (BS.ByteString, SockAddr)   -- ^ send queue
                       -> Set.Set FediChordMessage           -- ^ all parts of the request to handle
                       -> SockAddr                           -- ^ source address of the request
@@ -287,7 +287,7 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do
 
 
 -- | execute a key ID lookup on local cache and respond with the result
-respondQueryID :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
+respondQueryID :: LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
 respondQueryID nsSTM msgSet = do
     putStrLn "responding to a QueryID request"
     -- this message cannot be split reasonably, so just
@@ -328,7 +328,7 @@ respondQueryID nsSTM msgSet = do
 -- | Respond to a Leave request by removing the leaving node from local data structures
 -- and confirming with response.
 -- TODO: copy over key data from leaver and confirm
-respondLeave :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
+respondLeave :: LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
 respondLeave nsSTM msgSet = do
     -- combine payload of all parts
     let (requestPreds, requestSuccs) = foldr' (\msg (predAcc, succAcc) ->
@@ -359,7 +359,7 @@ respondLeave nsSTM msgSet = do
     pure $ serialiseMessage sendMessageSize responseMsg
 
 -- | respond to stabilise requests by returning successor and predecessor list
-respondStabilise :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
+respondStabilise :: LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
 respondStabilise nsSTM msgSet = do
     nsSnap <- readTVarIO nsSTM
     let
@@ -381,7 +381,7 @@ respondStabilise nsSTM msgSet = do
 
 
 -- | respond to Ping request by returning all active vserver NodeStates
-respondPing :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
+respondPing :: LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
 respondPing nsSTM msgSet = do
     -- TODO: respond with all active VS when implementing k-choices
     nsSnap <- readTVarIO nsSTM
@@ -400,7 +400,7 @@ respondPing nsSTM msgSet = do
 
 -- this modifies node state, so locking and IO seems to be necessary.
 -- Still try to keep as much code as possible pure
-respondJoin :: LocalNodeStateSTM -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
+respondJoin :: LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
 respondJoin nsSTM msgSet = do
     -- atomically read and modify the node state according to the parsed request
     responseMsg <- atomically $ do
@@ -451,8 +451,8 @@ respondJoin nsSTM msgSet = do
 
 -- | send a join request and return the joined 'LocalNodeState' including neighbours
 requestJoin :: NodeState a => a             -- ^ currently responsible node to be contacted
-            -> LocalNodeStateSTM               -- ^ joining NodeState
-            -> IO (Either String LocalNodeStateSTM)    -- ^ node after join with all its new information
+            -> LocalNodeStateSTM s               -- ^ joining NodeState
+            -> IO (Either String (LocalNodeStateSTM s))    -- ^ node after join with all its new information
 requestJoin toJoinOn ownStateSTM = do
     ownState <- readTVarIO ownStateSTM
     prn <- readTVarIO $ parentRealNode ownState
@@ -500,7 +500,7 @@ requestJoin toJoinOn ownStateSTM = do
 
 
 -- | Send a 'QueryID' 'Request' for getting the node that handles a certain key ID.
-requestQueryID :: LocalNodeState        -- ^ NodeState of the querying node
+requestQueryID :: LocalNodeState s        -- ^ NodeState of the querying node
                -> NodeID                -- ^ target key ID to look up
                -> IO RemoteNodeState    -- ^ the node responsible for handling that key
 -- 1. do a local lookup for the l closest nodes
@@ -515,7 +515,7 @@ requestQueryID ns targetID = do
     queryIdLookupLoop firstCacheSnapshot ns 50 targetID
 
 -- | like 'requestQueryID, but allows passing of a custom cache, e.g. for joining
-queryIdLookupLoop :: NodeCache -> LocalNodeState -> Int -> NodeID -> IO RemoteNodeState
+queryIdLookupLoop :: NodeCache -> LocalNodeState s -> Int -> NodeID -> IO RemoteNodeState
 -- return node itself as default fallback value against infinite recursion.
 -- TODO: consider using an Either instead of a default value
 queryIdLookupLoop _ ns 0 _ = pure $ toRemoteNodeState ns
@@ -541,7 +541,7 @@ queryIdLookupLoop cacheSnapshot ns maxAttempts targetID = do
 
 sendQueryIdMessages :: (Integral i)
                     => NodeID                        -- ^ target key ID to look up
-                    -> LocalNodeState                -- ^ node state of the node doing the query
+                    -> LocalNodeState s                -- ^ node state of the node doing the query
                     -> Maybe i                       -- ^ optionally provide an explicit @l@ parameter of number of nodes to be returned
                    -> [RemoteNodeState]             -- ^ nodes to query
                    -> IO QueryResponse -- ^ accumulated response
@@ -579,7 +579,7 @@ sendQueryIdMessages targetID ns lParam targets = do
 -- | Create a QueryID message to be supplied to 'sendRequestTo'
 lookupMessage :: Integral i
               => NodeID         -- ^ target ID
-              -> LocalNodeState -- ^ sender node state
+              -> LocalNodeState s -- ^ sender node state
               -> Maybe i        -- ^ optionally provide a different l parameter
               ->  (Integer -> FediChordMessage)
 lookupMessage targetID ns lParam = \rID -> Request rID (toRemoteNodeState ns) 1 True QueryID (Just $ pl ns targetID)
@@ -589,7 +589,7 @@ lookupMessage targetID ns lParam = \rID -> Request rID (toRemoteNodeState ns) 1
 
 -- | Send a stabilise request to provided 'RemoteNode' and, if successful,
 -- return parsed neighbour lists
-requestStabilise :: LocalNodeState      -- ^ sending node
+requestStabilise :: LocalNodeState s      -- ^ sending node
                  -> RemoteNodeState     -- ^ neighbour node to send to
                  -> IO (Either String ([RemoteNodeState], [RemoteNodeState]))   -- ^ (predecessors, successors) of responding node
 requestStabilise ns neighbour = do
@@ -624,7 +624,7 @@ requestStabilise ns neighbour = do
         ) responses
 
 
-requestPing :: LocalNodeState      -- ^ sending node
+requestPing :: LocalNodeState s      -- ^ sending node
                  -> RemoteNodeState     -- ^ node to be PINGed
                  -> IO (Either String [RemoteNodeState])   -- ^ all active vServers of the pinged node
 requestPing ns target = do
@@ -723,7 +723,7 @@ sendRequestTo timeoutMillis numAttempts msgIncomplete sock = do
 
 -- | enqueue a list of RemoteCacheEntries to be added to the global NodeCache
 queueAddEntries :: Foldable c => c RemoteCacheEntry
-                -> LocalNodeState
+                -> LocalNodeState s
                 -> IO ()
 queueAddEntries entries ns = do
     now <- getPOSIXTime
@@ -733,14 +733,14 @@ queueAddEntries entries ns = do
 -- | enque a list of node IDs to be deleted from the global NodeCache
 queueDeleteEntries :: Foldable c
                    => c NodeID
-                   -> LocalNodeState
+                   -> LocalNodeState s
                    -> IO ()
 queueDeleteEntries ids ns = forM_ ids $ atomically . writeTQueue (cacheWriteQueue ns) . deleteCacheEntry
 
 
 -- | enque a single node ID to be deleted from the global NodeCache
 queueDeleteEntry :: NodeID
-                 -> LocalNodeState
+                 -> LocalNodeState s
                  -> IO ()
 queueDeleteEntry toDelete = queueDeleteEntries $ Identity toDelete
 
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 70c9ff7..914ea57 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -78,7 +78,6 @@ import           Data.Maybe                    (catMaybes, fromJust, fromMaybe,
                                                 isJust, isNothing, mapMaybe)
 import qualified Data.Set                      as Set
 import           Data.Time.Clock.POSIX
-import           Data.Typeable                 (Typeable (..), typeOf)
 import           Data.Word
 import qualified Network.ByteOrder             as NetworkBytes
 import           Network.Socket                hiding (recv, recvFrom, send,
@@ -95,10 +94,10 @@ import           Debug.Trace                   (trace)
 
 -- | initialise data structures, compute own IDs and bind to listening socket
 -- ToDo: load persisted state, thus this function already operates in IO
-fediChordInit :: (Service s RealNodeSTM)
+fediChordInit :: (Service s (RealNodeSTM s))
               => FediChordConf
-              -> (RealNodeSTM -> IO (s RealNodeSTM))     -- ^ runner function for service
-              -> IO (Socket, LocalNodeStateSTM)
+              -> (RealNodeSTM s -> IO (s (RealNodeSTM s)))     -- ^ runner function for service
+              -> IO (Socket, LocalNodeStateSTM s)
 fediChordInit initConf serviceRunner = do
     emptyLookupCache <- newTVarIO Map.empty
     let realNode = RealNode {
@@ -119,7 +118,7 @@ fediChordInit initConf serviceRunner = do
 
 -- | initialises the 'NodeState' for this local node.
 -- Separated from 'fediChordInit' to be usable in tests.
-nodeStateInit :: RealNodeSTM -> IO LocalNodeState
+nodeStateInit :: RealNodeSTM s -> IO (LocalNodeState s)
 nodeStateInit realNodeSTM = do
     realNode <- readTVarIO realNodeSTM
     cacheSTM <- newTVarIO initCache
@@ -151,9 +150,9 @@ nodeStateInit realNodeSTM = do
 
 -- | Join a new node into the DHT, using a provided bootstrap node as initial cache seed
 -- for resolving the new node's position.
-fediChordBootstrapJoin :: LocalNodeStateSTM              -- ^ the local 'NodeState'
+fediChordBootstrapJoin :: LocalNodeStateSTM s            -- ^ the local 'NodeState'
                         -> (String, PortNumber)   -- ^ domain and port of a bootstrapping node
-                        -> IO (Either String LocalNodeStateSTM) -- ^ the joined 'NodeState' after a
+                        -> IO (Either String (LocalNodeStateSTM s)) -- ^ the joined 'NodeState' after a
                                             -- successful join, otherwise an error message
 fediChordBootstrapJoin nsSTM bootstrapNode = do
     -- can be invoked multiple times with all known bootstrapping nodes until successfully joined
@@ -169,7 +168,7 @@ fediChordBootstrapJoin nsSTM bootstrapNode = do
 
 -- Periodically lookup own ID through a random bootstrapping node to discover and merge separated DHT clusters.
 -- Unjoined try joining instead.
-convergenceSampleThread :: LocalNodeStateSTM -> IO ()
+convergenceSampleThread :: LocalNodeStateSTM s -> IO ()
 convergenceSampleThread nsSTM = forever $ do
     nsSnap <- readTVarIO nsSTM
     parentNode <- readTVarIO $ parentRealNode nsSnap
@@ -200,7 +199,7 @@ convergenceSampleThread nsSTM = forever $ do
 
 
 -- | Try joining the DHT through any of the bootstrapping nodes until it succeeds.
-tryBootstrapJoining :: LocalNodeStateSTM -> IO (Either String LocalNodeStateSTM)
+tryBootstrapJoining :: LocalNodeStateSTM s -> IO (Either String (LocalNodeStateSTM s))
 tryBootstrapJoining nsSTM = do
     bss <- atomically $ do
         nsSnap <- readTVar nsSTM
@@ -217,7 +216,7 @@ tryBootstrapJoining nsSTM = do
 
 
 -- | Look up a key just based on the responses of a single bootstrapping node.
-bootstrapQueryId :: LocalNodeStateSTM -> (String, PortNumber) -> NodeID -> IO (Either String RemoteNodeState)
+bootstrapQueryId :: LocalNodeStateSTM s -> (String, PortNumber) -> NodeID -> IO (Either String RemoteNodeState)
 bootstrapQueryId nsSTM (bootstrapHost, bootstrapPort) targetID = do
     ns <- readTVarIO nsSTM
     srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
@@ -248,8 +247,8 @@ bootstrapQueryId nsSTM (bootstrapHost, bootstrapPort) targetID = do
 
 -- | join a node to the DHT using the global node cache
 -- node's position.
-fediChordJoin :: LocalNodeStateSTM                    -- ^ the local 'NodeState'
-              -> IO (Either String LocalNodeStateSTM)  -- ^ the joined 'NodeState' after a
+fediChordJoin :: LocalNodeStateSTM s                    -- ^ the local 'NodeState'
+              -> IO (Either String (LocalNodeStateSTM s))  -- ^ the joined 'NodeState' after a
                                                     -- successful join, otherwise an error message
 fediChordJoin nsSTM = do
     ns <- readTVarIO nsSTM
@@ -265,7 +264,7 @@ fediChordJoin nsSTM = do
 
 -- | Wait for new cache entries to appear and then try joining on them.
 -- Exits after successful joining.
-joinOnNewEntriesThread :: LocalNodeStateSTM -> IO ()
+joinOnNewEntriesThread :: LocalNodeStateSTM s -> IO ()
 joinOnNewEntriesThread nsSTM = loop
   where
     loop = do
@@ -278,8 +277,7 @@ joinOnNewEntriesThread nsSTM = loop
               result                   -> pure (result, cache)
         case lookupResult of
           -- already joined
-          FOUND _ -> do
-              print =<< readTVarIO nsSTM
+          FOUND _ ->
               pure ()
           -- otherwise try joining
           FORWARD _ -> do
@@ -295,7 +293,7 @@ joinOnNewEntriesThread nsSTM = loop
 
 -- | cache updater thread that waits for incoming NodeCache update instructions on
 -- the node's cacheWriteQueue and then modifies the NodeCache as the single writer.
-nodeCacheWriter :: LocalNodeStateSTM -> IO ()
+nodeCacheWriter :: LocalNodeStateSTM s -> IO ()
 nodeCacheWriter nsSTM =
     forever $ atomically $ do
         ns <- readTVar nsSTM
@@ -309,7 +307,7 @@ maxEntryAge = 600
 
 
 -- | Periodically iterate through cache, clean up expired entries and verify unverified ones
-nodeCacheVerifyThread :: LocalNodeStateSTM -> IO ()
+nodeCacheVerifyThread :: LocalNodeStateSTM s -> IO ()
 nodeCacheVerifyThread nsSTM = forever $ do
     putStrLn "cache verify run: begin"
     -- get cache
@@ -370,7 +368,7 @@ nodeCacheVerifyThread nsSTM = forever $ do
 -- | Checks the invariant of at least @jEntries@ per cache slice.
 -- If this invariant does not hold, the middle of the slice is returned for
 -- making lookups to that ID
-checkCacheSliceInvariants :: LocalNodeState
+checkCacheSliceInvariants :: LocalNodeState s
                           -> NodeCache
                           -> [NodeID]   -- ^ list of middle IDs of slices not
                                         -- ^ fulfilling the invariant
@@ -426,12 +424,11 @@ checkCacheSliceInvariants ns
 -- | Periodically send @StabiliseRequest' s to the closest neighbour nodes, until
 -- one responds, and get their neighbours for maintaining the own neighbour lists.
 -- If necessary, request new neighbours.
-stabiliseThread :: LocalNodeStateSTM -> IO ()
+stabiliseThread :: LocalNodeStateSTM s -> IO ()
 stabiliseThread nsSTM = forever $ do
     ns <- readTVarIO nsSTM
 
     putStrLn "stabilise run: begin"
-    print ns
 
     -- iterate through the same snapshot, collect potential new neighbours
     -- and nodes to be deleted, and modify these changes only at the end of
@@ -489,8 +486,8 @@ stabiliseThread nsSTM = forever $ do
     -- with the n+1-th neighbour.
     -- On success, return 2 lists: The failed nodes and the potential neighbours
     -- returned by the queried node.
-    stabiliseClosestResponder :: LocalNodeState     -- ^ own node
-                              -> (LocalNodeState -> [RemoteNodeState])  -- ^ getter function for either predecessors or successors
+    stabiliseClosestResponder :: LocalNodeState s    -- ^ own node
+                              -> (LocalNodeState s -> [RemoteNodeState])  -- ^ getter function for either predecessors or successors
                               -> Int    -- ^ index of neighbour to query
                               -> [RemoteNodeState]     -- ^ delete accumulator
                               -> IO (Either String ([RemoteNodeState], [RemoteNodeState])) -- ^ (nodes to be deleted, successfully pinged potential neighbours)
@@ -514,7 +511,7 @@ stabiliseThread nsSTM = forever $ do
 
     currentNeighbour ns neighbourGetter = atMay $ neighbourGetter ns
 
-    checkReachability :: LocalNodeState         -- ^ this node
+    checkReachability :: LocalNodeState s       -- ^ this node
                       -> RemoteNodeState        -- ^ node to Ping for reachability
                       -> IO (Maybe RemoteNodeState)     -- ^ if the Pinged node handles the requested node state then that one
     checkReachability ns toCheck = do
@@ -543,10 +540,10 @@ sendThread sock sendQ = forever $ do
     sendAllTo sock packet addr
 
 -- | Sets up and manages the main server threads of FediChord
-fediMainThreads :: Socket -> LocalNodeStateSTM -> IO ()
+fediMainThreads :: Socket -> LocalNodeStateSTM s -> IO ()
 fediMainThreads sock nsSTM = do
     ns <- readTVarIO nsSTM
-    putStrLn $ "launching threads, ns: " <> show ns
+    putStrLn $ "launching threads"
     sendQ <- newTQueueIO
     recvQ <- newTQueueIO
     -- concurrently launch all handler threads, if one of them throws an exception
@@ -588,7 +585,7 @@ requestMapPurge mapVar = forever $ do
 -- and pass them to their specific handling function.
 fediMessageHandler :: TQueue (BS.ByteString, SockAddr)  -- ^ send queue
                    -> TQueue (BS.ByteString, SockAddr)  -- ^ receive queue
-                   -> LocalNodeStateSTM                    -- ^ acting NodeState
+                   -> LocalNodeStateSTM s                  -- ^ acting NodeState
                    -> IO ()
 fediMessageHandler sendQ recvQ nsSTM = do
     -- Read node state just once, assuming that all relevant data for this function does
@@ -653,14 +650,14 @@ fediMessageHandler sendQ recvQ nsSTM = do
 
 -- ==== interface to service layer ====
 
-instance DHT RealNodeSTM where
+instance DHT (RealNodeSTM s) where
     lookupKey nodeSTM keystring = getKeyResponsibility nodeSTM $ genKeyID keystring
     forceLookupKey nodeSTM keystring = updateLookupCache nodeSTM $ genKeyID keystring
 
 -- | Returns the hostname and port of the host responsible for a key.
 -- Information is provided from a cache, only on a cache miss a new DHT lookup
 -- is triggered.
-getKeyResponsibility :: RealNodeSTM -> NodeID -> IO (Maybe (String, PortNumber))
+getKeyResponsibility :: RealNodeSTM s -> NodeID -> IO (Maybe (String, PortNumber))
 getKeyResponsibility nodeSTM lookupKey = do
     node <- readTVarIO nodeSTM
     cache <- readTVarIO $ lookupCacheSTM node
@@ -676,7 +673,7 @@ getKeyResponsibility nodeSTM lookupKey = do
 -- | Triggers a new DHT lookup for a key, updates the lookup cache and returns the
 -- new entry.
 -- If no vserver is active in the DHT, 'Nothing' is returned.
-updateLookupCache :: RealNodeSTM -> NodeID -> IO (Maybe (String, PortNumber))
+updateLookupCache :: RealNodeSTM s -> NodeID -> IO (Maybe (String, PortNumber))
 updateLookupCache nodeSTM lookupKey = do
     (node, lookupSource) <- atomically $ do
         node <- readTVar nodeSTM
@@ -703,7 +700,7 @@ updateLookupCache nodeSTM lookupKey = do
 
 
 -- | Periodically clean the lookup cache from expired entries.
-lookupCacheCleanup :: RealNodeSTM -> IO ()
+lookupCacheCleanup :: RealNodeSTM s -> IO ()
 lookupCacheCleanup nodeSTM = do
     node <- readTVarIO nodeSTM
     forever $ do
diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs
index 604519e..5b8ef17 100644
--- a/src/Hash2Pub/FediChordTypes.hs
+++ b/src/Hash2Pub/FediChordTypes.hs
@@ -147,9 +147,8 @@ a `localCompare` b
 -- | Data for managing the virtual server nodes of this real node.
 -- Also contains shared data and config values.
 -- TODO: more data structures for k-choices bookkeeping
---data RealNode s = RealNode
-data RealNode = RealNode
-    { vservers       :: [LocalNodeStateSTM]
+data RealNode s = RealNode
+    { vservers       :: [LocalNodeStateSTM s]
     -- ^ references to all active versers
     , nodeConfig     :: FediChordConf
     -- ^ holds the initial configuration read at program start
@@ -157,10 +156,10 @@ data RealNode = RealNode
     -- ^ nodes to be used as bootstrapping points, new ones learned during operation
     , lookupCacheSTM :: TVar LookupCache
     -- ^ a global cache of looked up keys and their associated nodes
+    , nodeService    :: s (RealNodeSTM s)
     }
 
---type RealNodeSTM s = TVar (RealNode s)
-type RealNodeSTM = TVar RealNode
+type RealNodeSTM s = TVar (RealNode s)
 
 -- | represents a node and all its important state
 data RemoteNodeState = RemoteNodeState
@@ -182,7 +181,7 @@ instance Ord RemoteNodeState where
     a `compare` b = nid a `compare` nid b
 
 -- | represents a node and encapsulates all data and parameters that are not present for remote nodes
-data LocalNodeState = LocalNodeState
+data LocalNodeState s = LocalNodeState
     { nodeState           :: RemoteNodeState
     -- ^ represents common data present both in remote and local node representations
     , nodeCacheSTM        :: TVar NodeCache
@@ -201,13 +200,13 @@ data LocalNodeState = LocalNodeState
     -- ^ number of parallel sent queries
     , jEntriesPerSlice    :: Int
     -- ^ number of desired entries per cache slice
-    , parentRealNode      :: RealNodeSTM
+    , parentRealNode      :: RealNodeSTM s
     -- ^ the parent node managing this vserver instance
     }
     deriving (Show, Eq)
 
 -- | for concurrent access, LocalNodeState is wrapped in a TVar
-type LocalNodeStateSTM = TVar LocalNodeState
+type LocalNodeStateSTM s = TVar (LocalNodeState s)
 
 -- | class for various NodeState representations, providing
 -- getters and setters for common values
@@ -244,14 +243,14 @@ instance NodeState RemoteNodeState where
     toRemoteNodeState = id
 
 -- | helper function for setting values on the 'RemoteNodeState' contained in the 'LocalNodeState'
-propagateNodeStateSet_ :: (RemoteNodeState -> RemoteNodeState) -> LocalNodeState -> LocalNodeState
+propagateNodeStateSet_ :: (RemoteNodeState -> RemoteNodeState) -> LocalNodeState s -> LocalNodeState s
 propagateNodeStateSet_ func ns = let
         newNs = func $ nodeState ns
     in
         ns {nodeState = newNs}
 
 
-instance NodeState LocalNodeState where
+instance NodeState (LocalNodeState s) where
     getNid = getNid . nodeState
     getDomain = getDomain . nodeState
     getIpAddr = getIpAddr . nodeState
@@ -273,21 +272,24 @@ instance Typeable a => Show (TVar a) where
 instance Typeable a => Show (TQueue a) where
     show x = show (typeOf x)
 
+instance Typeable a => Show (TChan a) where
+    show x = show (typeOf x)
+
 
 -- | convenience function that replaces the predecessors of a 'LocalNodeState' with the k closest nodes from the provided list
-setPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState
+setPredecessors :: [RemoteNodeState] -> LocalNodeState s -> LocalNodeState s
 setPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . rMapFromList . fmap keyValuePair . filter ((/=) (getNid ns) . getNid) $ preds}
 
 -- | convenience function that replaces the successors of a 'LocalNodeState' with the k closest nodes from the provided list
-setSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState
+setSuccessors :: [RemoteNodeState] -> LocalNodeState s -> LocalNodeState s
 setSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . rMapFromList . fmap keyValuePair . filter ((/=) (getNid ns) . getNid) $ succs}
 
 -- | sets the predecessors of a 'LocalNodeState' to the closest k nodes of the current predecessors and the provided list, combined
-addPredecessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState
+addPredecessors :: [RemoteNodeState] -> LocalNodeState s -> LocalNodeState s
 addPredecessors preds ns = ns {predecessors = takeRMapPredecessors (getNid ns) (kNeighbours ns) . addRMapEntries (keyValuePair <$> filter ((/=) (getNid ns) . getNid) preds) . rMapFromList . fmap keyValuePair  $ predecessors ns}
 
 -- | sets the successors of a 'LocalNodeState' to the closest k nodes of the current successors and the provided list, combined
-addSuccessors :: [RemoteNodeState] -> LocalNodeState -> LocalNodeState
+addSuccessors :: [RemoteNodeState] -> LocalNodeState s -> LocalNodeState s
 addSuccessors succs ns = ns {successors = takeRMapSuccessors (getNid ns) (kNeighbours ns) . addRMapEntries (keyValuePair <$> filter ((/=) (getNid ns) . getNid) succs) . rMapFromList . fmap keyValuePair $ successors ns}
 
 instance HasKeyID NodeID RemoteNodeState where
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 264bccb..d5dd30d 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -25,6 +25,7 @@ import qualified Data.Text.Lazy                as Txt
 import           Data.Text.Normalize           (NormalizationMode (NFC),
                                                 normalize)
 import           Data.Time.Clock.POSIX
+import           Data.Typeable                 (Typeable)
 import           System.Random
 
 import qualified Network.Wai.Handler.Warp      as Warp
@@ -48,6 +49,7 @@ data PostService d = PostService
     , relayInQueue     :: TQueue (Hashtag, PostID, PostContent)
     -- ^ Queue for processing incoming posts of own instance asynchronously
     }
+    deriving (Typeable)
 
 type Hashtag = Txt.Text
 type PostID = Txt.Text
diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs
index 1cace7a..bcc2eaf 100644
--- a/test/FediChordSpec.hs
+++ b/test/FediChordSpec.hs
@@ -292,7 +292,7 @@ exampleNodeState = RemoteNodeState {
   , vServerID = 0
                    }
 
-exampleLocalNode :: IO LocalNodeState
+exampleLocalNode :: IO (LocalNodeState s)
 exampleLocalNode = nodeStateInit =<< (newTVarIO $ RealNode {
             vservers = []
           , nodeConfig = exampleFediConf

From e3c7faa80bbecbfda11901e45e9d673b62122eb0 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 31 Jul 2020 16:54:19 +0200
Subject: [PATCH 018/112] properly initialise RealNode with service and vserver
 data, set up reference

---
 src/Hash2Pub/FediChord.hs      | 13 ++++++++-----
 src/Hash2Pub/FediChordTypes.hs |  2 +-
 src/Hash2Pub/PostService.hs    |  2 +-
 3 files changed, 10 insertions(+), 7 deletions(-)

diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 914ea57..858b38e 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -105,20 +105,23 @@ fediChordInit initConf serviceRunner = do
           , nodeConfig = initConf
           , bootstrapNodes = confBootstrapNodes initConf
           , lookupCacheSTM = emptyLookupCache
-          --, service = undefined
+          , nodeService = undefined
                             }
     realNodeSTM <- newTVarIO realNode
     -- launch service and set the reference in the RealNode
     serv <- serviceRunner realNodeSTM
-    --atomically . writeTVar $ realNode { service = serv }
+    atomically . modifyTVar' realNodeSTM $ \rn -> rn { nodeService = serv }
+    -- initialise a single vserver
     initialState <- nodeStateInit realNodeSTM
     initialStateSTM <- newTVarIO initialState
+    -- add vserver to list at RealNode
+    atomically . modifyTVar' realNodeSTM $ \rn -> rn { vservers = initialStateSTM:vservers rn }
     serverSock <- mkServerSocket (getIpAddr initialState) (getDhtPort initialState)
     pure (serverSock, initialStateSTM)
 
 -- | initialises the 'NodeState' for this local node.
 -- Separated from 'fediChordInit' to be usable in tests.
-nodeStateInit :: RealNodeSTM s -> IO (LocalNodeState s)
+nodeStateInit :: Service s (RealNodeSTM s) => RealNodeSTM s -> IO (LocalNodeState s)
 nodeStateInit realNodeSTM = do
     realNode <- readTVarIO realNodeSTM
     cacheSTM <- newTVarIO initCache
@@ -131,7 +134,7 @@ nodeStateInit realNodeSTM = do
           , ipAddr = confIP conf
           , nid = genNodeID (confIP conf) (confDomain conf) $ fromInteger vsID
           , dhtPort = toEnum $ confDhtPort conf
-          , servicePort = 0
+          , servicePort = getListeningPortFromService $ nodeService realNode
           , vServerID = vsID
                                           }
         initialState = LocalNodeState {
@@ -543,7 +546,7 @@ sendThread sock sendQ = forever $ do
 fediMainThreads :: Socket -> LocalNodeStateSTM s -> IO ()
 fediMainThreads sock nsSTM = do
     ns <- readTVarIO nsSTM
-    putStrLn $ "launching threads"
+    putStrLn "launching threads"
     sendQ <- newTQueueIO
     recvQ <- newTQueueIO
     -- concurrently launch all handler threads, if one of them throws an exception
diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs
index 5b8ef17..e73e7f5 100644
--- a/src/Hash2Pub/FediChordTypes.hs
+++ b/src/Hash2Pub/FediChordTypes.hs
@@ -423,7 +423,7 @@ data FediChordConf = FediChordConf
 class Service s d where
     -- | run the service
     runService :: ServiceConf -> d -> IO (s d)
-    getServicePort' :: (Integral i) => s d -> i
+    getListeningPortFromService :: (Integral i) => s d -> i
 
 instance Hashable.Hashable NodeID where
     hashWithSalt salt = Hashable.hashWithSalt salt . getNodeID
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index d5dd30d..ae122e2 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -97,7 +97,7 @@ instance DHT d => Service PostService d where
         atomically $ writeTVar threadVar servThreadID
         pure thisService
 
-    getServicePort' = fromIntegral . confServicePort . serviceConf
+    getListeningPortFromService = fromIntegral . confServicePort . serviceConf
 
 
 -- | return a WAI application

From 50044673a65d0ba0afcc4abc104fa19a70b67757 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 31 Jul 2020 17:46:33 +0200
Subject: [PATCH 019/112] server endpoint for tag-post delivery

---
 src/Hash2Pub/PostService.hs | 23 +++++++++++++++++------
 1 file changed, 17 insertions(+), 6 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index ae122e2..cab4350 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -19,7 +19,7 @@ import           Control.Monad.IO.Class        (liftIO)
 import qualified Data.ByteString.Lazy.UTF8     as BSU
 import qualified Data.HashMap.Strict           as HMap
 import qualified Data.HashSet                  as HSet
-import           Data.Maybe                    (fromMaybe)
+import           Data.Maybe                    (fromMaybe, isJust)
 import           Data.String                   (fromString)
 import qualified Data.Text.Lazy                as Txt
 import           Data.Text.Normalize           (NormalizationMode (NFC),
@@ -48,6 +48,7 @@ data PostService d = PostService
     -- ^ just store the existence of posts for saving memory,
     , relayInQueue     :: TQueue (Hashtag, PostID, PostContent)
     -- ^ Queue for processing incoming posts of own instance asynchronously
+    , postFetchQueue   :: TQueue PostID
     }
     deriving (Typeable)
 
@@ -73,6 +74,7 @@ instance DHT d => Service PostService d where
         ownSubsVar <- newTVarIO HMap.empty
         ownPostVar <- newTVarIO HSet.empty
         relayInQueue' <- newTQueueIO
+        postFetchQueue' <- newTQueueIO
         let
             thisService = PostService {
                 serviceConf = conf
@@ -82,6 +84,7 @@ instance DHT d => Service PostService d where
               , ownSubscriptions = ownSubsVar
               , ownPosts = ownPostVar
               , relayInQueue = relayInQueue'
+              , postFetchQueue = postFetchQueue'
                                       }
             port' = fromIntegral (confServicePort conf)
             warpSettings = Warp.setPort port' . Warp.setHost (fromString . confServiceHost $ conf) $ Warp.defaultSettings
@@ -221,7 +224,15 @@ postInbox serv post = do
 
 
 tagDelivery :: PostService d -> Txt.Text -> Txt.Text -> Handler Txt.Text
-tagDelivery serv hashtag posts = pure $ "Here be #" <> hashtag <> " dragons with " <> posts
+tagDelivery serv hashtag posts = do
+    let postIDs = Txt.lines posts
+    subscriptions <- liftIO . readTVarIO . ownSubscriptions $ serv
+    if isJust (HMap.lookup (genKeyID . Txt.unpack $ hashtag) subscriptions)
+       then -- TODO: increase a counter/ statistics for received posts of this tag
+            liftIO $ forM_ postIDs $ atomically . writeTQueue (postFetchQueue serv)
+        else -- silently drop posts from unsubscribed tags
+            pure ()
+    pure $ "Received a postID for tag " <> hashtag
 
 tagSubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Integer
 tagSubscribe serv hashtag origin = pure 42
@@ -251,7 +262,7 @@ enqueueSubscription tagMapSTM tag subscriber posts leaseTime = do
 setupSubscriberChannel :: TVar RelayTags -> Hashtag -> (String, Int) -> POSIXTime -> STM (TChan PostID)
 setupSubscriberChannel tagMapSTM tag subscriber leaseTime = do
     tagMap <- readTVar tagMapSTM
-    case lookupRelayTags tag tagMap of
+    case lookupTagSubscriptions tag tagMap of
       Nothing -> do
         -- if no collision/ tag doesn't exist yet, just initialize a
         -- new subscriber map
@@ -277,7 +288,7 @@ setupSubscriberChannel tagMapSTM tag subscriber leaseTime = do
 getTagBroadcastChannel :: PostService d -> Hashtag -> STM (Maybe (TChan PostID))
 getTagBroadcastChannel serv tag = do
     tagMap <- readTVar $ subscribers serv
-    case lookupRelayTags tag tagMap of
+    case lookupTagSubscriptions tag tagMap of
       Nothing -> pure Nothing
       Just (subscriberSTM, broadcastChan, _) -> do
           subscriberMap <- readTVar subscriberSTM
@@ -287,8 +298,8 @@ getTagBroadcastChannel serv tag = do
 
 
 -- | look up the subscription data of a tag
-lookupRelayTags :: Hashtag -> RelayTags -> Maybe (TagSubscribersSTM, TChan PostID, Hashtag)
-lookupRelayTags tag = rMapLookup (genKeyID . Txt.unpack $ tag)
+lookupTagSubscriptions :: Hashtag -> RingMap NodeID a -> Maybe a
+lookupTagSubscriptions tag = rMapLookup (genKeyID . Txt.unpack $ tag)
 
 
 -- normalise the unicode representation of a string to NFC

From 7d7fa3b52a745d57cefc4fb7f24aac798e39bce4 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 31 Jul 2020 17:49:52 +0200
Subject: [PATCH 020/112] fix haddock parsing

---
 src/Hash2Pub/PostService.hs | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index cab4350..dc2164a 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -120,23 +120,23 @@ placeholderPost = Txt.take 5120 . Txt.repeat $ 'O' -- size 5KiB
 -- ========= HTTP API and handlers =============
 
 type PostServiceAPI = "relay" :> "inbox" :> Capture "hashtag" Txt.Text :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
-                 -- ^ delivery endpoint of newly published posts of the relay's instance
+                 -- delivery endpoint of newly published posts of the relay's instance
                  :<|> "relay" :> "subscribers" :> ReqBody '[PlainText] Txt.Text :> PostNoContent '[PlainText] NoContent
-                 -- ^ endpoint for delivering the subscriptions and outstanding queue
+                 -- endpoint for delivering the subscriptions and outstanding queue
                  :<|> "post" :> Capture "postid" Txt.Text :> Get '[PlainText] Txt.Text
-                 -- ^ fetch endpoint for posts, full post ID is http://$domain/post/$postid
+                 -- fetch endpoint for posts, full post ID is http://$domain/post/$postid
                  :<|> "posts" :> ReqBody '[PlainText] Txt.Text :> Post '[PlainText] Txt.Text
-                 -- ^ endpoint for fetching multiple posts at once
+                 -- endpoint for fetching multiple posts at once
                  :<|> "posts" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
-                 -- ^ delivery endpoint of newly published posts of the relay's instance
+                 -- delivery endpoint of newly published posts of the relay's instance
                  :<|> "tags" :> Capture "hashtag" Txt.Text :> ReqBody '[PlainText] Txt.Text :> PostCreated '[PlainText] Txt.Text
-                 -- ^ delivery endpoint for posts of $tag at subscribing instance
+                 -- delivery endpoint for posts of $tag at subscribing instance
                  :<|> "tags" :> Capture "hashtag" Txt.Text :> "subscribe" :> Header "Origin" Txt.Text :> Get '[PlainText] Integer
-                 -- ^ endpoint for subscribing the instance specified in
+                 -- endpoint for subscribing the instance specified in
                  -- the Origin header to $hashtag.
                  -- Returns subscription lease time in seconds.
                  :<|> "tags" :> Capture "hashtag" Txt.Text :> "unsubscribe" :> Header "Origin" Txt.Text :> Get '[PlainText] Txt.Text
-                 -- ^ endpoint for unsubscribing the instance specified in
+                 -- endpoint for unsubscribing the instance specified in
                  -- the Origin header to $hashtag
 
 

From 7280f251b5015fed7e76e1c01dcf19145f77cf83 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sat, 1 Aug 2020 11:00:29 +0200
Subject: [PATCH 021/112] server endpoint for tag subscription

---
 Hash2Pub.cabal                 |  2 +-
 app/Main.hs                    |  2 +-
 src/Hash2Pub/FediChordTypes.hs |  2 +-
 src/Hash2Pub/PostService.hs    | 19 ++++++++++++++++---
 4 files changed, 19 insertions(+), 6 deletions(-)

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index 54cb29d..251c60d 100644
--- a/Hash2Pub.cabal
+++ b/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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms
+  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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client
   ghc-options:         -Wall
 
 
diff --git a/app/Main.hs b/app/Main.hs
index 98961c0..3bdb4d4 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -57,7 +57,7 @@ readConfig = do
       , confMaxLookupCacheAge = 300
                            }
         sConf = ServiceConf {
-        confSubscriptionExpiryTime = 2*3600 `div` read speedup
+        confSubscriptionExpiryTime = fromIntegral $ 2*3600 `div` (read speedup :: Integer)
                             , confServicePort = read servicePortString
                             , confServiceHost = confDomainString
                             }
diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs
index e73e7f5..91b3822 100644
--- a/src/Hash2Pub/FediChordTypes.hs
+++ b/src/Hash2Pub/FediChordTypes.hs
@@ -430,7 +430,7 @@ instance Hashable.Hashable NodeID where
     hash = Hashable.hash . getNodeID
 
 data ServiceConf = ServiceConf
-    { confSubscriptionExpiryTime :: Integer
+    { confSubscriptionExpiryTime :: POSIXTime
     -- ^ subscription lease expiration in seconds
     , confServicePort            :: Int
     -- ^ listening port for service
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index dc2164a..d56eb4c 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -16,7 +16,8 @@ import           Control.Concurrent.STM.TQueue
 import           Control.Concurrent.STM.TVar
 import           Control.Monad                 (foldM, forM_, forever)
 import           Control.Monad.IO.Class        (liftIO)
-import qualified Data.ByteString.Lazy.UTF8     as BSU
+import qualified Data.ByteString.Lazy.UTF8     as BSUL
+import qualified Data.ByteString.UTF8          as BSU
 import qualified Data.HashMap.Strict           as HMap
 import qualified Data.HashSet                  as HSet
 import           Data.Maybe                    (fromMaybe, isJust)
@@ -26,6 +27,7 @@ import           Data.Text.Normalize           (NormalizationMode (NFC),
                                                 normalize)
 import           Data.Time.Clock.POSIX
 import           Data.Typeable                 (Typeable)
+import qualified Network.HTTP.Client           as HTTP
 import           System.Random
 
 import qualified Network.Wai.Handler.Warp      as Warp
@@ -235,7 +237,18 @@ tagDelivery serv hashtag posts = do
     pure $ "Received a postID for tag " <> hashtag
 
 tagSubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Integer
-tagSubscribe serv hashtag origin = pure 42
+tagSubscribe serv hashtag origin = do
+    originURL <- maybe
+        (throwError $ err400 { errBody = "Missing Origin header" })
+        pure
+        origin
+    req <- HTTP.parseUrlThrow (Txt.unpack originURL)
+    now <- liftIO getPOSIXTime
+    let leaseTime = now + confSubscriptionExpiryTime (serviceConf serv)
+    -- setup subscription entry
+    _ <- liftIO . atomically $ setupSubscriberChannel (subscribers serv) hashtag (BSU.toString $ HTTP.host req, HTTP.port req) leaseTime
+    pure $ round leaseTime
+
 
 tagUnsubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Text
 tagUnsubscribe serv hashtag origin = pure $ "Here be a dragon unsubscription from " <> fromMaybe "Nothing" origin <> " to " <> hashtag
@@ -310,7 +323,7 @@ normaliseTag = Txt.fromStrict . normalize NFC . Txt.toStrict
 -- No idea what I'm doing with these overlappable instances though ¯\_(ツ)_/¯
 -- TODO: figure out how this overlapping stuff actually works https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#instance-overlap
 instance {-# OVERLAPPABLE #-} Show a => MimeRender PlainText a where
-    mimeRender _ = BSU.fromString . show
+    mimeRender _ = BSUL.fromString . show
 
 
 -- ====== worker threads ======

From 89706f688a332f2966d8c48a12c9a2e983424310 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sat, 1 Aug 2020 11:18:16 +0200
Subject: [PATCH 022/112] server endpoint for tag unsubscription

---
 src/Hash2Pub/PostService.hs | 29 +++++++++++++++++++++++++++--
 1 file changed, 27 insertions(+), 2 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index d56eb4c..838b2c8 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -251,8 +251,14 @@ tagSubscribe serv hashtag origin = do
 
 
 tagUnsubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Text
-tagUnsubscribe serv hashtag origin = pure $ "Here be a dragon unsubscription from " <> fromMaybe "Nothing" origin <> " to " <> hashtag
-
+tagUnsubscribe serv hashtag origin = do
+    originURL <- maybe
+        (throwError $ err400 { errBody = "Missing Origin header" })
+        pure
+        origin
+    req <- HTTP.parseUrlThrow (Txt.unpack originURL)
+    liftIO . atomically $ deleteSubscription (subscribers serv) hashtag (BSU.toString $ HTTP.host req, HTTP.port req)
+    pure "bye bye"
 
 -- ======= data structure manipulations =========
 
@@ -297,6 +303,25 @@ setupSubscriberChannel tagMapSTM tag subscriber leaseTime = do
           Just (tagOutChan, _) -> pure tagOutChan
 
 
+-- | deletes a subscription from the passed subscriber map
+deleteSubscription :: TVar RelayTags -> Hashtag -> (String, Int) -> STM ()
+deleteSubscription tagMapSTM tag subscriber = do
+    tagMap <- readTVar tagMapSTM
+    case lookupTagSubscriptions tag tagMap of
+      -- no subscribers to that tag, just return
+      Nothing -> pure ()
+      Just (foundSubMapSTM, _, _) -> do
+          foundSubMap <- readTVar foundSubMapSTM
+          let newSubMap = HMap.delete subscriber foundSubMap
+          -- if there are no subscriptions for the tag anymore, remove its
+          -- data sttructure altogether
+          if HMap.null newSubMap
+             then writeTVar tagMapSTM $ deleteRMapEntry (genKeyID . Txt.unpack $ tag) tagMap
+          -- otherwise just remove the subscription of that node
+             else writeTVar foundSubMapSTM newSubMap
+
+
+
 -- | returns the broadcast channel of a hashtag if there are any subscribers to it
 getTagBroadcastChannel :: PostService d -> Hashtag -> STM (Maybe (TChan PostID))
 getTagBroadcastChannel serv tag = do

From 8faa9dc0164162d1f2b5ba558faf36a7defee250 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sat, 1 Aug 2020 18:58:30 +0200
Subject: [PATCH 023/112] fix test by providing a MockService

---
 test/FediChordSpec.hs | 19 +++++++++++++++----
 1 file changed, 15 insertions(+), 4 deletions(-)

diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs
index bcc2eaf..ed1f3c8 100644
--- a/test/FediChordSpec.hs
+++ b/test/FediChordSpec.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
 module FediChordSpec where
 
 import           Control.Concurrent.STM.TVar
@@ -292,12 +294,15 @@ exampleNodeState = RemoteNodeState {
   , vServerID = 0
                    }
 
-exampleLocalNode :: IO (LocalNodeState s)
-exampleLocalNode = nodeStateInit =<< (newTVarIO $ RealNode {
+exampleLocalNode :: IO (LocalNodeState MockService)
+exampleLocalNode = do
+    realNode <- newTVarIO $ RealNode {
             vservers = []
           , nodeConfig = exampleFediConf
           , bootstrapNodes = confBootstrapNodes exampleFediConf
-                                                        })
+          , nodeService = MockService
+                                                        }
+    nodeStateInit realNode
 
 
 exampleFediConf :: FediChordConf
@@ -313,3 +318,9 @@ exampleVs :: (Integral i) => i
 exampleVs = 4
 exampleIp :: HostAddress6
 exampleIp = tupleToHostAddress6 (0x2001, 0x16b8, 0x755a, 0xb110, 0x7d6a, 0x12ab, 0xf0c5, 0x386e)
+
+data MockService d = MockService
+
+instance DHT d => Service MockService d where
+    runService _ _ = pure MockService
+    getListeningPortFromService = const 1337

From 20e51ecca43b4453fbea7902c83e00fccf92576e Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sun, 2 Aug 2020 14:58:53 +0200
Subject: [PATCH 024/112] define API client functions

---
 src/Hash2Pub/PostService.hs | 13 +++++++++++++
 1 file changed, 13 insertions(+)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 838b2c8..76dab47 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -29,9 +29,12 @@ import           Data.Time.Clock.POSIX
 import           Data.Typeable                 (Typeable)
 import qualified Network.HTTP.Client           as HTTP
 import           System.Random
+import           Text.Read                     (readEither)
 
 import qualified Network.Wai.Handler.Warp      as Warp
 import           Servant
+import           Servant.Client
+import           Servant.Server
 
 import           Hash2Pub.FediChordTypes
 import           Hash2Pub.RingMap
@@ -260,6 +263,14 @@ tagUnsubscribe serv hashtag origin = do
     liftIO . atomically $ deleteSubscription (subscribers serv) hashtag (BSU.toString $ HTTP.host req, HTTP.port req)
     pure "bye bye"
 
+-- client/ request functions
+
+clientAPI :: Proxy PostServiceAPI
+clientAPI = Proxy
+
+
+relayInboxClient :<|> subscriptionDeliveryClient :<|> postFetchClient :<|> postMultiFetchClient :<|> postInboxClient :<|> tagDeliveryClient :<|> tagSubscribeClient :<|> tagUnsubscribeClient = client clientAPI
+
 -- ======= data structure manipulations =========
 
 -- | Write all pending posts of a subscriber-tag-combination to its queue.
@@ -350,6 +361,8 @@ normaliseTag = Txt.fromStrict . normalize NFC . Txt.toStrict
 instance {-# OVERLAPPABLE #-} Show a => MimeRender PlainText a where
     mimeRender _ = BSUL.fromString . show
 
+instance {-# OVERLAPPABLE #-} Read a => MimeUnrender PlainText a where
+    mimeUnrender _ = readEither . BSUL.toString
 
 -- ====== worker threads ======
 

From 7036867ae002db82e0ec39341c4dca52676f6960 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 3 Aug 2020 22:50:48 +0200
Subject: [PATCH 025/112] implemented first Servant client query

---
 src/Hash2Pub/PostService.hs | 23 +++++++++++++++++++----
 1 file changed, 19 insertions(+), 4 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 76dab47..e9144df 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -271,6 +271,18 @@ clientAPI = Proxy
 
 relayInboxClient :<|> subscriptionDeliveryClient :<|> postFetchClient :<|> postMultiFetchClient :<|> postInboxClient :<|> tagDeliveryClient :<|> tagSubscribeClient :<|> tagUnsubscribeClient = client clientAPI
 
+
+
+-- currently this is unused code
+getClients :: String -> Int -> HTTP.Manager -> Client IO PostServiceAPI
+getClients hostname' port' httpMan = hoistClient clientAPI
+    (fmap (either (error . show) id)
+    . flip runClientM clientEnv
+    )
+    (client clientAPI)
+  where
+      clientEnv = mkClientEnv httpMan (BaseUrl Http hostname' port' "")
+
 -- ======= data structure manipulations =========
 
 -- | Write all pending posts of a subscriber-tag-combination to its queue.
@@ -372,11 +384,14 @@ processIncomingPosts :: DHT d => PostService d -> IO ()
 processIncomingPosts serv = forever $ do
     -- blocks until available
     -- TODO: process multiple in parallel
-    (t, pID, pC) <- atomically . readTQueue $ relayInQueue serv
-    lookupRes <- lookupKey (baseDHT serv) (Txt.unpack t)
+    (tag, pID, pContent) <- atomically . readTQueue $ relayInQueue serv
+    lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag)
     case lookupRes of
       -- no vserver active => wait and retry
       Nothing -> threadDelay $ 10 * 10^6
       Just (responsibleHost, responsiblePort) -> do
-        -- TODO: do actual HTTP requests
-        pure ()
+        httpMan <- HTTP.newManager HTTP.defaultManagerSettings
+        resp <- runClientM (relayInboxClient tag (pID <> "," <> pContent)) (mkClientEnv httpMan (BaseUrl Http responsibleHost (fromIntegral responsiblePort) ""))
+        case resp of
+          Left err -> putStrLn $ "Error: " <> show err
+          Right yay -> putStrLn $ "Yay! " <> show yay

From 96c1963a4f350f617820d96afae2d44d7ffdd749 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Tue, 11 Aug 2020 00:07:45 +0200
Subject: [PATCH 026/112] actually check own responsibility for tags before
 accepting posts

---
 src/Hash2Pub/DHTProtocol.hs    |  1 +
 src/Hash2Pub/FediChord.hs      | 19 +++++++++++
 src/Hash2Pub/FediChordTypes.hs |  2 ++
 src/Hash2Pub/PostService.hs    | 61 +++++++++++++++++++++++++---------
 src/Hash2Pub/RingMap.hs        | 58 +++++++++++++++++++-------------
 5 files changed, 102 insertions(+), 39 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index f962d58..a071132 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -34,6 +34,7 @@ module Hash2Pub.DHTProtocol
     , ackRequest
     , isPossibleSuccessor
     , isPossiblePredecessor
+    , isInOwnResponsibilitySlice
     , isJoined
     , closestCachePredecessors
     )
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 858b38e..7911f3c 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -656,6 +656,25 @@ fediMessageHandler sendQ recvQ nsSTM = do
 instance DHT (RealNodeSTM s) where
     lookupKey nodeSTM keystring = getKeyResponsibility nodeSTM $ genKeyID keystring
     forceLookupKey nodeSTM keystring = updateLookupCache nodeSTM $ genKeyID keystring
+    -- potential better implementation: put all neighbours of all vservers and the vservers on a ringMap, look the key up and see whether it results in a LocalNodeState
+    isResponsibleFor nodeSTM key = do
+        node <- readTVarIO nodeSTM
+        foldM (\responsible vsSTM -> do
+            vs <- readTVarIO vsSTM
+            pure $ responsible || isInOwnResponsibilitySlice key vs
+              )
+              False
+              $ vservers node
+    isResponsibleForSTM nodeSTM key = do
+        node <- readTVar nodeSTM
+        foldM (\responsible vsSTM -> do
+            vs <- readTVar vsSTM
+            pure $ responsible || isInOwnResponsibilitySlice key vs
+              )
+              False
+              $ vservers node
+
+
 
 -- | Returns the hostname and port of the host responsible for a key.
 -- Information is provided from a cache, only on a cache miss a new DHT lookup
diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs
index 91b3822..20d65fe 100644
--- a/src/Hash2Pub/FediChordTypes.hs
+++ b/src/Hash2Pub/FediChordTypes.hs
@@ -446,3 +446,5 @@ class DHT d where
     -- but force the DHT to do a fresh lookup instead of returning a cached result.
     -- Also invalidates old cache entries.
     forceLookupKey :: d -> String -> IO (Maybe (String, PortNumber))
+    isResponsibleFor :: d -> NodeID -> IO Bool
+    isResponsibleForSTM :: d -> NodeID -> STM Bool
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index e9144df..8f47227 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -12,10 +12,13 @@ import           Control.Concurrent
 import           Control.Concurrent.Async
 import           Control.Concurrent.STM
 import           Control.Concurrent.STM.TChan
+import           Control.Concurrent.STM.TChan
 import           Control.Concurrent.STM.TQueue
 import           Control.Concurrent.STM.TVar
-import           Control.Monad                 (foldM, forM_, forever)
+import           Control.Exception             (Exception (..))
+import           Control.Monad                 (foldM, forM, forM_, forever)
 import           Control.Monad.IO.Class        (liftIO)
+import           Control.Monad.STM
 import qualified Data.ByteString.Lazy.UTF8     as BSUL
 import qualified Data.ByteString.UTF8          as BSU
 import qualified Data.HashMap.Strict           as HMap
@@ -109,7 +112,7 @@ instance DHT d => Service PostService d where
 
 
 -- | return a WAI application
-postServiceApplication :: PostService d -> Application
+postServiceApplication :: DHT d => PostService d -> Application
 postServiceApplication serv = serve exposedPostServiceAPI $ postServer serv
 
 
@@ -126,7 +129,7 @@ placeholderPost = Txt.take 5120 . Txt.repeat $ 'O' -- size 5KiB
 
 type PostServiceAPI = "relay" :> "inbox" :> Capture "hashtag" Txt.Text :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
                  -- delivery endpoint of newly published posts of the relay's instance
-                 :<|> "relay" :> "subscribers" :> ReqBody '[PlainText] Txt.Text :> PostNoContent '[PlainText] NoContent
+                 :<|> "relay" :> "subscribers" :> ReqBody '[PlainText] Txt.Text :> PostNoContent '[PlainText] Txt.Text
                  -- endpoint for delivering the subscriptions and outstanding queue
                  :<|> "post" :> Capture "postid" Txt.Text :> Get '[PlainText] Txt.Text
                  -- fetch endpoint for posts, full post ID is http://$domain/post/$postid
@@ -145,7 +148,7 @@ type PostServiceAPI = "relay" :> "inbox" :> Capture "hashtag" Txt.Text :> ReqBod
                  -- the Origin header to $hashtag
 
 
-postServer :: PostService d -> Server PostServiceAPI
+postServer :: DHT d => PostService d -> Server PostServiceAPI
 postServer service = relayInbox service
         :<|> subscriptionDelivery service
         :<|> postFetch service
@@ -156,15 +159,21 @@ postServer service = relayInbox service
         :<|> tagUnsubscribe service
 
 
-relayInbox :: PostService d -> Hashtag -> Txt.Text -> Handler NoContent
+relayInbox :: DHT d => PostService d -> Hashtag -> Txt.Text -> Handler NoContent
 relayInbox serv tag posts = do
     let
     -- skip checking whether the post actually contains the tag, just drop full post
         postIDs = head . Txt.splitOn "," <$> Txt.lines posts
-    broadcastChan <- liftIO $ atomically $ getTagBroadcastChannel serv tag
     -- if tag is not in own responsibility, return a 410 Gone
-    maybe
+    responsible <- liftIO $ isResponsibleFor (baseDHT serv) (genKeyID . Txt.unpack $ tag)
+    if responsible
+       then pure ()
+       else
         (throwError $ err410 { errBody = "Relay is not responsible for this tag"})
+    broadcastChan <- liftIO $ atomically $ getTagBroadcastChannel serv tag
+    maybe
+    -- if noone subscribed to the tag, nothing needs to be done
+        (pure ())
     -- otherwise enqueue posts into broadcast queue of the tag
         (\queue ->
             liftIO $ forM_ postIDs (atomically . writeTChan queue)
@@ -172,15 +181,35 @@ relayInbox serv tag posts = do
         broadcastChan
     pure NoContent
 
-subscriptionDelivery :: PostService d -> Txt.Text -> Handler NoContent
+-- exception to be thrown when a tag is not in the responsibility of a relay
+newtype UnhandledTagException = UnhandledTagException String
+    deriving (Show, Typeable)
+
+instance Exception UnhandledTagException
+
+subscriptionDelivery :: DHT d => PostService d -> Txt.Text -> Handler Txt.Text
 subscriptionDelivery serv subList = do
     let
         tagSubs = Txt.lines subList
-    liftIO $ forM_ tagSubs $ processTag (subscribers serv)
-    pure NoContent
+    -- In favor of having the convenience of rolling back the transaction once a
+    -- not-handled tag occurs, this results in a single large transaction.
+    -- Hopefully the performance isn't too bad.
+    res <- liftIO . atomically $ (foldM (\_ tag' -> do
+        responsible <- isResponsibleForSTM (baseDHT serv) (genKeyID . Txt.unpack $ tag')
+        if responsible
+           then processTag (subscribers serv) tag'
+           else throwSTM $ UnhandledTagException (Txt.unpack tag' <> " not handled by this relay")
+        pure $ Right ()
+           ) (pure ()) tagSubs
+           `catchSTM` (\e -> pure . Left $ show (e :: UnhandledTagException))
+           -- TODO: potentially log this
+                          :: STM (Either String ()))
+    case res of
+      Left err -> throwError err410 {errBody = BSUL.fromString err}
+      Right _  -> pure ""
     -- TODO: check and only accept tags in own (future?) responsibility
   where
-      processTag :: TVar RelayTags -> Txt.Text -> IO ()
+      processTag :: TVar RelayTags -> Txt.Text -> STM ()
       processTag subscriberSTM tagData = do
           let
             tag:subText:lease:posts:_ = Txt.splitOn "," tagData
@@ -292,11 +321,11 @@ enqueueSubscription :: TVar RelayTags    -- tag-subscriber map
                      -> (String, Int)   -- subscriber's connection information
                      -> [PostID]        -- pending posts
                      -> POSIXTime       -- lease expiry time
-                     -> IO ()
+                     -> STM ()
 enqueueSubscription tagMapSTM tag subscriber posts leaseTime = do
     -- get the tag output queue and, if necessary, create it
-    subChan <- atomically $ setupSubscriberChannel tagMapSTM tag subscriber leaseTime
-    forM_ posts (atomically . writeTChan subChan)
+    subChan <- setupSubscriberChannel tagMapSTM tag subscriber leaseTime
+    forM_ posts (writeTChan subChan)
 
 
 -- | STM operation to return the outgoing post queue of a tag to a specified subscriber.
@@ -391,7 +420,7 @@ processIncomingPosts serv = forever $ do
       Nothing -> threadDelay $ 10 * 10^6
       Just (responsibleHost, responsiblePort) -> do
         httpMan <- HTTP.newManager HTTP.defaultManagerSettings
-        resp <- runClientM (relayInboxClient tag (pID <> "," <> pContent)) (mkClientEnv httpMan (BaseUrl Http responsibleHost (fromIntegral responsiblePort) ""))
+        resp <- runClientM (relayInboxClient tag $ pID <> "," <> pContent) (mkClientEnv httpMan (BaseUrl Http responsibleHost (fromIntegral responsiblePort) ""))
         case resp of
-          Left err -> putStrLn $ "Error: " <> show err
+          Left err  -> putStrLn $ "Error: " <> show err
           Right yay -> putStrLn $ "Yay! " <> show yay
diff --git a/src/Hash2Pub/RingMap.hs b/src/Hash2Pub/RingMap.hs
index 016f9f1..9b439e9 100644
--- a/src/Hash2Pub/RingMap.hs
+++ b/src/Hash2Pub/RingMap.hs
@@ -196,29 +196,28 @@ takeRMapEntries_ :: (Integral i, Bounded k, Ord k)
 takeRMapEntries_ getterFunc startAt num rmap = reverse $
     case getterFunc startAt rmap of
       Nothing -> []
-      Just (foundKey, anEntry) -> takeEntriesUntil rmap getterFunc foundKey foundKey (num-1) [anEntry]
-  where
-    -- for some reason, just reusing the already-bound @rmap@ and @getterFunc@
-    -- variables leads to a type error, these need to be passed explicitly
-    takeEntriesUntil :: (Integral i, Bounded k, Ord k)
-                     => RingMap k a
-                     -> (k -> RingMap k a -> Maybe (k, a)) -- getter function
-                     -> k
-                     -> k
-                     -> i
-                     -> [a]
-                     -> [a]
-    takeEntriesUntil rmap' getterFunc' havingReached previousEntry remaining takeAcc
-      -- length limit reached
-      | remaining <= 0 = takeAcc
-      --
-      | otherwise = case nextEntry of
-                      Just (fKey, gotEntry)
-                        | fKey == havingReached -> takeAcc
-                        | otherwise -> takeEntriesUntil rmap' getterFunc' havingReached fKey (remaining - 1) (gotEntry:takeAcc)
-                      Nothing -> takeAcc
-        where
-            nextEntry = getterFunc' previousEntry rmap'
+      Just (foundKey, anEntry) -> takeEntriesUntil_ rmap getterFunc foundKey foundKey (Just $ num-1) [anEntry]
+
+
+takeEntriesUntil_ :: (Integral i, Bounded k, Ord k)
+                 => RingMap k a
+                 -> (k -> RingMap k a -> Maybe (k, a)) -- getter function
+                 -> k           -- limit value
+                 -> k           -- start value
+                 -> Maybe i     -- possible number limit
+                 -> [a]
+                 -> [a]
+takeEntriesUntil_ rmap' getterFunc' havingReached previousEntry (Just remaining) takeAcc
+  -- length limit reached
+  | remaining <= 0 = takeAcc
+takeEntriesUntil_ rmap' getterFunc' havingReached previousEntry numLimit takeAcc =
+    case nextEntry of
+                  Just (fKey, gotEntry)
+                    | fKey == havingReached -> takeAcc
+                    | otherwise -> takeEntriesUntil_ rmap' getterFunc' havingReached fKey (fmap pred numLimit) (gotEntry:takeAcc)
+                  Nothing -> takeAcc
+    where
+        nextEntry = getterFunc' previousEntry rmap'
 
 
 takeRMapPredecessors :: (Integral i, Bounded k, Ord k, Num k)
@@ -235,3 +234,16 @@ takeRMapSuccessors :: (Integral i, Bounded k, Ord k, Num k)
                  -> [a]
 takeRMapSuccessors = takeRMapEntries_ rMapLookupSucc
 
+takeRMapPredecessorsFromTo :: (Bounded k, Ord k, Num k)
+                           => k     -- start value for taking
+                           -> k     -- stop value for taking
+                           -> RingMap k a
+                           -> [a]
+takeRMapPredecessorsFromTo fromVal toVal rmap = takeEntriesUntil_ rmap rMapLookupPred toVal fromVal Nothing []
+
+takeRMapSuccesorsFromTo :: (Bounded k, Ord k, Num k)
+                           => k     -- start value for taking
+                           -> k     -- stop value for taking
+                           -> RingMap k a
+                           -> [a]
+takeRMapSuccesorsFromTo fromVal toVal rmap = takeEntriesUntil_ rmap rMapLookupSucc toVal fromVal Nothing []

From 1258f673da285148c23dd66c43aaffa970f1e4cd Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 12 Aug 2020 12:07:41 +0200
Subject: [PATCH 027/112] flush responsibility cache and retry in post queue
 delivery

---
 src/Hash2Pub/PostService.hs | 24 ++++++++++++++++++++++--
 1 file changed, 22 insertions(+), 2 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 8f47227..ab3f317 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -301,6 +301,20 @@ clientAPI = Proxy
 relayInboxClient :<|> subscriptionDeliveryClient :<|> postFetchClient :<|> postMultiFetchClient :<|> postInboxClient :<|> tagDeliveryClient :<|> tagSubscribeClient :<|> tagUnsubscribeClient = client clientAPI
 
 
+---- | Deliver the subscriber list of all hashtags in the interval [fromTag, toTag]
+---- and their outstanding delivery queue to another instance.
+---- If the transfer succeeds, the transfered subscribers are removed from the local list.
+--clientDeliverSubscriptions :: PostService
+--                           -> Hashtag -- ^ fromTag
+--                           -> Hashtag -- ^ toTag
+--                           -> (String, Int)     -- ^ hostname and port of instance to deliver to
+--                           -> IO (Either String ())     -- Either signals success or failure
+--clientDeliverSubscriptions serv fromTag toTag (toHost, toPort) = do
+--    -- collect tag intearval
+--    intervalTags <- takeRMapSuccesorsFromTo (genKeyID $ Txt.unpack fromTag) (genKeyID $ Txt.unpack fromTag) =<< readTVarIO $ subscribers serv
+--    -- extract subscribers and posts
+--    -- send subscribers
+--    -- on failure return a Left, otherwise flush remaining queues atomically, schedule all newly arrived posts to still be relayed and delete subscription entry
 
 -- currently this is unused code
 getClients :: String -> Int -> HTTP.Manager -> Client IO PostServiceAPI
@@ -407,7 +421,7 @@ instance {-# OVERLAPPABLE #-} Read a => MimeUnrender PlainText a where
 
 -- ====== worker threads ======
 
--- | process the pending relays of incoming posts from the internal queue:
+-- | process the pending relay inbox of incoming posts from the internal queue:
 -- Look up responsible relay node for given hashtag and forward post to it
 processIncomingPosts :: DHT d => PostService d -> IO ()
 processIncomingPosts serv = forever $ do
@@ -422,5 +436,11 @@ processIncomingPosts serv = forever $ do
         httpMan <- HTTP.newManager HTTP.defaultManagerSettings
         resp <- runClientM (relayInboxClient tag $ pID <> "," <> pContent) (mkClientEnv httpMan (BaseUrl Http responsibleHost (fromIntegral responsiblePort) ""))
         case resp of
-          Left err  -> putStrLn $ "Error: " <> show err
+          Left err  -> do
+              putStrLn $ "Error: " <> show err
+              -- 410 error indicates outdated responsibility mapping
+              -- Simplification: just invalidate the mapping entry on all errors, force a re-lookup and re-queue the post
+              -- TODO: keep track of maximum retries
+              _ <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
+              atomically . writeTQueue (relayInQueue serv) $ (tag, pID, pContent)
           Right yay -> putStrLn $ "Yay! " <> show yay

From 1d808b6776c048c06fbf3f202db1a591df843578 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 12 Aug 2020 12:16:20 +0200
Subject: [PATCH 028/112] fix typo

---
 src/Hash2Pub/RingMap.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Hash2Pub/RingMap.hs b/src/Hash2Pub/RingMap.hs
index 9b439e9..e99f8b2 100644
--- a/src/Hash2Pub/RingMap.hs
+++ b/src/Hash2Pub/RingMap.hs
@@ -241,9 +241,9 @@ takeRMapPredecessorsFromTo :: (Bounded k, Ord k, Num k)
                            -> [a]
 takeRMapPredecessorsFromTo fromVal toVal rmap = takeEntriesUntil_ rmap rMapLookupPred toVal fromVal Nothing []
 
-takeRMapSuccesorsFromTo :: (Bounded k, Ord k, Num k)
+takeRMapSuccessorsFromTo :: (Bounded k, Ord k, Num k)
                            => k     -- start value for taking
                            -> k     -- stop value for taking
                            -> RingMap k a
                            -> [a]
-takeRMapSuccesorsFromTo fromVal toVal rmap = takeEntriesUntil_ rmap rMapLookupSucc toVal fromVal Nothing []
+takeRMapSuccessorsFromTo fromVal toVal rmap = takeEntriesUntil_ rmap rMapLookupSucc toVal fromVal Nothing []

From 2e88a4079b0c36888fe924c8aa72592f93926e89 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 12 Aug 2020 14:07:19 +0200
Subject: [PATCH 029/112] extract and build subscriber payload for sending

---
 src/Hash2Pub/PostService.hs | 55 +++++++++++++++++++++++++++----------
 1 file changed, 41 insertions(+), 14 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index ab3f317..11562d4 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -301,20 +301,47 @@ clientAPI = Proxy
 relayInboxClient :<|> subscriptionDeliveryClient :<|> postFetchClient :<|> postMultiFetchClient :<|> postInboxClient :<|> tagDeliveryClient :<|> tagSubscribeClient :<|> tagUnsubscribeClient = client clientAPI
 
 
----- | Deliver the subscriber list of all hashtags in the interval [fromTag, toTag]
----- and their outstanding delivery queue to another instance.
----- If the transfer succeeds, the transfered subscribers are removed from the local list.
---clientDeliverSubscriptions :: PostService
---                           -> Hashtag -- ^ fromTag
---                           -> Hashtag -- ^ toTag
---                           -> (String, Int)     -- ^ hostname and port of instance to deliver to
---                           -> IO (Either String ())     -- Either signals success or failure
---clientDeliverSubscriptions serv fromTag toTag (toHost, toPort) = do
---    -- collect tag intearval
---    intervalTags <- takeRMapSuccesorsFromTo (genKeyID $ Txt.unpack fromTag) (genKeyID $ Txt.unpack fromTag) =<< readTVarIO $ subscribers serv
---    -- extract subscribers and posts
---    -- send subscribers
---    -- on failure return a Left, otherwise flush remaining queues atomically, schedule all newly arrived posts to still be relayed and delete subscription entry
+-- | Deliver the subscriber list of all hashtags in the interval [fromTag, toTag]
+-- and their outstanding delivery queue to another instance.
+-- If the transfer succeeds, the transfered subscribers are removed from the local list.
+clientDeliverSubscriptions :: PostService d
+                           -> Hashtag -- ^ fromTag
+                           -> Hashtag -- ^ toTag
+                           -> (String, Int)     -- ^ hostname and port of instance to deliver to
+                           -> IO (Either String ())     -- Either signals success or failure
+clientDeliverSubscriptions serv fromTag toTag (toHost, toPort) = do
+    -- collect tag intearval
+    intervalTags <- takeRMapSuccessorsFromTo (genKeyID $ Txt.unpack fromTag) (genKeyID $ Txt.unpack fromTag) <$> readTVarIO (subscribers serv)
+    -- returns a [ (TagSubscribersSTM, TChan PostID, Hashtag) ]
+    -- extract subscribers and posts
+    -- no need for extracting as a single atomic operation, as newly incoming posts are supposed to be rejected because of already having re-positioned on the DHT
+    subscriberData <- foldM (\response (subSTM, _, tag) -> do
+        subMap <- readTVarIO subSTM
+        thisTagsData <- foldM (\tagResponse (subscriber, (subChan, lease)) -> do
+            -- duplicate the pending queue to work on a copy, in case of a delivery error
+            pending <- atomically $ do
+                queueCopy <- cloneTChan subChan
+                channelGetAll queueCopy
+            if null pending
+               then pure tagResponse
+               else pure $ tag <> "," <> Txt.pack (show subscriber) <> "," <> Txt.pack (show lease) <> "," <> Txt.unwords pending <> "\n"
+              )
+            ""
+            (HMap.toList subMap)
+        pure $ thisTagsData <> response
+            )
+        ""
+        intervalTags
+    -- send subscribers
+    -- on failure return a Left, otherwise flush remaining queues atomically, schedule all newly arrived posts to still be relayed and delete subscription entry
+    pure . Right $ ()
+  where
+      channelGetAll :: TChan a -> STM [a]
+      channelGetAll chan = channelGetAll' chan []
+      channelGetAll' :: TChan a -> [a] -> STM [a]
+      channelGetAll' chan acc = do
+          haveRead <- tryReadTChan chan
+          maybe (pure acc) (\x -> channelGetAll' chan (x:acc)) haveRead
 
 -- currently this is unused code
 getClients :: String -> Int -> HTTP.Manager -> Client IO PostServiceAPI

From c1ce386b6599931b9e45268c18674457fd4f6ab0 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 12 Aug 2020 15:23:10 +0200
Subject: [PATCH 030/112] send prepared subscriptions and clean up on success

---
 src/Hash2Pub/PostService.hs | 14 +++++++++++---
 1 file changed, 11 insertions(+), 3 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 11562d4..17d585b 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -311,7 +311,7 @@ clientDeliverSubscriptions :: PostService d
                            -> IO (Either String ())     -- Either signals success or failure
 clientDeliverSubscriptions serv fromTag toTag (toHost, toPort) = do
     -- collect tag intearval
-    intervalTags <- takeRMapSuccessorsFromTo (genKeyID $ Txt.unpack fromTag) (genKeyID $ Txt.unpack fromTag) <$> readTVarIO (subscribers serv)
+    intervalTags <- takeRMapSuccessorsFromTo (genKeyID $ Txt.unpack fromTag) (genKeyID $ Txt.unpack toTag) <$> readTVarIO (subscribers serv)
     -- returns a [ (TagSubscribersSTM, TChan PostID, Hashtag) ]
     -- extract subscribers and posts
     -- no need for extracting as a single atomic operation, as newly incoming posts are supposed to be rejected because of already having re-positioned on the DHT
@@ -333,8 +333,16 @@ clientDeliverSubscriptions serv fromTag toTag (toHost, toPort) = do
         ""
         intervalTags
     -- send subscribers
-    -- on failure return a Left, otherwise flush remaining queues atomically, schedule all newly arrived posts to still be relayed and delete subscription entry
-    pure . Right $ ()
+    httpMan <- HTTP.newManager HTTP.defaultManagerSettings
+    resp <- runClientM (subscriptionDeliveryClient subscriberData) (mkClientEnv httpMan (BaseUrl Http toHost (fromIntegral toPort) ""))
+    -- on failure return a Left, otherwise delete subscription entry
+    case resp of
+      Left err -> pure . Left . show $ err
+      Right _ -> do
+          atomically $
+              modifyTVar' (subscribers serv) $ \tagMap ->
+                  foldr deleteRMapEntry tagMap ((\(_, _, t) -> genKeyID . Txt.unpack $ t) <$> intervalTags) 
+          pure . Right $ ()
   where
       channelGetAll :: TChan a -> STM [a]
       channelGetAll chan = channelGetAll' chan []

From 580410e0b4c78150bedfe51d3e5c27a24d02b550 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 13 Aug 2020 13:07:50 +0200
Subject: [PATCH 031/112] simple post fetch worker thread

---
 Hash2Pub.cabal              |  2 +-
 src/Hash2Pub/PostService.hs | 32 +++++++++++++++++++++++++++++---
 2 files changed, 30 insertions(+), 4 deletions(-)

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index 251c60d..5ffff0d 100644
--- a/Hash2Pub.cabal
+++ b/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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client
+  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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types
   ghc-options:         -Wall
 
 
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 17d585b..47a4059 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds             #-}
+{-# laNGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE InstanceSigs          #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -15,7 +15,7 @@ import           Control.Concurrent.STM.TChan
 import           Control.Concurrent.STM.TChan
 import           Control.Concurrent.STM.TQueue
 import           Control.Concurrent.STM.TVar
-import           Control.Exception             (Exception (..))
+import           Control.Exception             (Exception (..), try)
 import           Control.Monad                 (foldM, forM, forM_, forever)
 import           Control.Monad.IO.Class        (liftIO)
 import           Control.Monad.STM
@@ -31,6 +31,7 @@ import           Data.Text.Normalize           (NormalizationMode (NFC),
 import           Data.Time.Clock.POSIX
 import           Data.Typeable                 (Typeable)
 import qualified Network.HTTP.Client           as HTTP
+import qualified Network.HTTP.Types            as HTTPT
 import           System.Random
 import           Text.Read                     (readEither)
 
@@ -341,7 +342,7 @@ clientDeliverSubscriptions serv fromTag toTag (toHost, toPort) = do
       Right _ -> do
           atomically $
               modifyTVar' (subscribers serv) $ \tagMap ->
-                  foldr deleteRMapEntry tagMap ((\(_, _, t) -> genKeyID . Txt.unpack $ t) <$> intervalTags) 
+                  foldr deleteRMapEntry tagMap ((\(_, _, t) -> genKeyID . Txt.unpack $ t) <$> intervalTags)
           pure . Right $ ()
   where
       channelGetAll :: TChan a -> STM [a]
@@ -479,3 +480,28 @@ processIncomingPosts serv = forever $ do
               _ <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
               atomically . writeTQueue (relayInQueue serv) $ (tag, pID, pContent)
           Right yay -> putStrLn $ "Yay! " <> show yay
+
+
+-- | process the pending fetch jobs of delivered post IDs: Delivered posts are tried to be fetched from their URI-ID
+fetchTagPosts :: DHT d => PostService d -> IO ()
+fetchTagPosts serv = forever $ do
+    -- blocks until available
+    -- TODO: batching, retry
+    -- TODO: process multiple in parallel
+    pIdUri <- atomically . readTQueue $ postFetchQueue serv
+    httpMan <- HTTP.newManager HTTP.defaultManagerSettings
+    fetchReq <- HTTP.parseRequest . Txt.unpack $pIdUri
+    resp <- try $ HTTP.httpLbs fetchReq httpMan :: IO (Either HTTP.HttpException (HTTP.Response BSUL.ByteString))
+    case resp of
+      Right response ->
+          if HTTPT.statusCode (HTTP.responseStatus response) == 200
+             then
+             -- success, TODO: statistics
+             putStrLn "post fetch success"
+             else
+             -- TODO error handling, retry
+             pure ()
+      Left _ ->
+             -- TODO error handling, retry
+             pure ()
+

From dcd4a7b563a046f6e05cac27f6abc4c2160189b9 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 13 Aug 2020 13:08:38 +0200
Subject: [PATCH 032/112] add nix shell environment without HIE for smaller
 foot print

---
 shell-minimal.nix | 1 +
 1 file changed, 1 insertion(+)
 create mode 100644 shell-minimal.nix

diff --git a/shell-minimal.nix b/shell-minimal.nix
new file mode 100644
index 0000000..15cd4fb
--- /dev/null
+++ b/shell-minimal.nix
@@ -0,0 +1 @@
+(import ./default.nix {withHIE = false;}).shell

From bdb00a32f334e3f68656b3e697141c37a8de2ebc Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 13 Aug 2020 13:08:38 +0200
Subject: [PATCH 033/112] add nix shell environment without HIE for smaller
 foot print

---
 shell-minimal.nix | 1 +
 1 file changed, 1 insertion(+)
 create mode 100644 shell-minimal.nix

diff --git a/shell-minimal.nix b/shell-minimal.nix
new file mode 100644
index 0000000..15cd4fb
--- /dev/null
+++ b/shell-minimal.nix
@@ -0,0 +1 @@
+(import ./default.nix {withHIE = false;}).shell

From 375014812ac41480f347b7e891713f928dc60ad9 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 13 Aug 2020 19:05:28 +0200
Subject: [PATCH 034/112] use a shared HTTP manager for requests

---
 src/Hash2Pub/PostService.hs | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 47a4059..92cd772 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -1,4 +1,4 @@
-{-# laNGUAGE DataKinds             #-}
+{-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE InstanceSigs          #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -58,6 +58,7 @@ data PostService d = PostService
     , relayInQueue     :: TQueue (Hashtag, PostID, PostContent)
     -- ^ Queue for processing incoming posts of own instance asynchronously
     , postFetchQueue   :: TQueue PostID
+    , httpMan          :: HTTP.Manager
     }
     deriving (Typeable)
 
@@ -84,6 +85,7 @@ instance DHT d => Service PostService d where
         ownPostVar <- newTVarIO HSet.empty
         relayInQueue' <- newTQueueIO
         postFetchQueue' <- newTQueueIO
+        httpMan' <- HTTP.newManager HTTP.defaultManagerSettings
         let
             thisService = PostService {
                 serviceConf = conf
@@ -94,6 +96,7 @@ instance DHT d => Service PostService d where
               , ownPosts = ownPostVar
               , relayInQueue = relayInQueue'
               , postFetchQueue = postFetchQueue'
+              , httpMan = httpMan'
                                       }
             port' = fromIntegral (confServicePort conf)
             warpSettings = Warp.setPort port' . Warp.setHost (fromString . confServiceHost $ conf) $ Warp.defaultSettings
@@ -334,8 +337,7 @@ clientDeliverSubscriptions serv fromTag toTag (toHost, toPort) = do
         ""
         intervalTags
     -- send subscribers
-    httpMan <- HTTP.newManager HTTP.defaultManagerSettings
-    resp <- runClientM (subscriptionDeliveryClient subscriberData) (mkClientEnv httpMan (BaseUrl Http toHost (fromIntegral toPort) ""))
+    resp <- runClientM (subscriptionDeliveryClient subscriberData) (mkClientEnv (httpMan serv) (BaseUrl Http toHost (fromIntegral toPort) ""))
     -- on failure return a Left, otherwise delete subscription entry
     case resp of
       Left err -> pure . Left . show $ err
@@ -469,8 +471,7 @@ processIncomingPosts serv = forever $ do
       -- no vserver active => wait and retry
       Nothing -> threadDelay $ 10 * 10^6
       Just (responsibleHost, responsiblePort) -> do
-        httpMan <- HTTP.newManager HTTP.defaultManagerSettings
-        resp <- runClientM (relayInboxClient tag $ pID <> "," <> pContent) (mkClientEnv httpMan (BaseUrl Http responsibleHost (fromIntegral responsiblePort) ""))
+        resp <- runClientM (relayInboxClient tag $ pID <> "," <> pContent) (mkClientEnv (httpMan serv) (BaseUrl Http responsibleHost (fromIntegral responsiblePort) ""))
         case resp of
           Left err  -> do
               putStrLn $ "Error: " <> show err
@@ -489,9 +490,8 @@ fetchTagPosts serv = forever $ do
     -- TODO: batching, retry
     -- TODO: process multiple in parallel
     pIdUri <- atomically . readTQueue $ postFetchQueue serv
-    httpMan <- HTTP.newManager HTTP.defaultManagerSettings
     fetchReq <- HTTP.parseRequest . Txt.unpack $pIdUri
-    resp <- try $ HTTP.httpLbs fetchReq httpMan :: IO (Either HTTP.HttpException (HTTP.Response BSUL.ByteString))
+    resp <- try $ HTTP.httpLbs fetchReq (httpMan serv) :: IO (Either HTTP.HttpException (HTTP.Response BSUL.ByteString))
     case resp of
       Right response ->
           if HTTPT.statusCode (HTTP.responseStatus response) == 200

From e9ae258ddeec73b424528639c379c18d7c3d3e2c Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 13 Aug 2020 21:12:22 +0200
Subject: [PATCH 035/112] subscribe to tag

---
 src/Hash2Pub/PostService.hs | 15 +++++++++++++++
 1 file changed, 15 insertions(+)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 92cd772..15901e0 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -354,6 +354,21 @@ clientDeliverSubscriptions serv fromTag toTag (toHost, toPort) = do
           haveRead <- tryReadTChan chan
           maybe (pure acc) (\x -> channelGetAll' chan (x:acc)) haveRead
 
+
+-- | Subscribe the client to the given hashtag. On success it returns the given lease time.
+clientSubscribeTo :: DHT d => PostService d -> Hashtag -> IO (Either String Integer)
+clientSubscribeTo serv tag = do
+    lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag)
+    maybe
+        (pure . Left $ "No node found")
+        (\(foundHost, foundPort) -> do
+            resp <- runClientM (tagSubscribeClient tag (Just . fromString . confServiceHost . serviceConf $ serv)) (mkClientEnv (httpMan serv) (BaseUrl Http foundHost (fromIntegral foundPort) ""))
+            case resp of
+              Left err    -> pure . Left . show $ err
+              Right lease -> pure . Right $ lease
+        )
+        lookupRes
+
 -- currently this is unused code
 getClients :: String -> Int -> HTTP.Manager -> Client IO PostServiceAPI
 getClients hostname' port' httpMan = hoistClient clientAPI

From e646045ab294ef88e08598e9c2f3ea3427425358 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 13 Aug 2020 21:57:28 +0200
Subject: [PATCH 036/112] include port in Origin header

---
 src/Hash2Pub/PostService.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 15901e0..1de7302 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -359,10 +359,11 @@ clientDeliverSubscriptions serv fromTag toTag (toHost, toPort) = do
 clientSubscribeTo :: DHT d => PostService d -> Hashtag -> IO (Either String Integer)
 clientSubscribeTo serv tag = do
     lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag)
+    let origin = "http://" <> Txt.pack (confServiceHost $ serviceConf serv) <> ":" <> Txt.pack (show (getListeningPortFromService serv :: Integer))
     maybe
         (pure . Left $ "No node found")
         (\(foundHost, foundPort) -> do
-            resp <- runClientM (tagSubscribeClient tag (Just . fromString . confServiceHost . serviceConf $ serv)) (mkClientEnv (httpMan serv) (BaseUrl Http foundHost (fromIntegral foundPort) ""))
+            resp <- runClientM (tagSubscribeClient tag (Just origin)) (mkClientEnv (httpMan serv) (BaseUrl Http foundHost (fromIntegral foundPort) ""))
             case resp of
               Left err    -> pure . Left . show $ err
               Right lease -> pure . Right $ lease

From 402378a78bd94c351c1bab77fd6b8d1bc985ed18 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 13 Aug 2020 23:44:24 +0200
Subject: [PATCH 037/112] signal and handle non-responsibility to subscriptions

---
 src/Hash2Pub/PostService.hs | 34 +++++++++++++++++++++++-----------
 1 file changed, 23 insertions(+), 11 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 1de7302..26c473b 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -272,8 +272,13 @@ tagDelivery serv hashtag posts = do
             pure ()
     pure $ "Received a postID for tag " <> hashtag
 
-tagSubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Integer
+tagSubscribe :: DHT d => PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Integer
 tagSubscribe serv hashtag origin = do
+    responsible <- liftIO $ isResponsibleFor (baseDHT serv) (genKeyID . Txt.unpack $ hashtag)
+    if not responsible
+       -- GONE if not responsible
+       then throwError err410 { errBody = "not responsible for this tag" }
+       else pure ()
     originURL <- maybe
         (throwError $ err400 { errBody = "Missing Origin header" })
         pure
@@ -359,16 +364,23 @@ clientDeliverSubscriptions serv fromTag toTag (toHost, toPort) = do
 clientSubscribeTo :: DHT d => PostService d -> Hashtag -> IO (Either String Integer)
 clientSubscribeTo serv tag = do
     lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag)
-    let origin = "http://" <> Txt.pack (confServiceHost $ serviceConf serv) <> ":" <> Txt.pack (show (getListeningPortFromService serv :: Integer))
-    maybe
-        (pure . Left $ "No node found")
-        (\(foundHost, foundPort) -> do
-            resp <- runClientM (tagSubscribeClient tag (Just origin)) (mkClientEnv (httpMan serv) (BaseUrl Http foundHost (fromIntegral foundPort) ""))
-            case resp of
-              Left err    -> pure . Left . show $ err
-              Right lease -> pure . Right $ lease
-        )
-        lookupRes
+    doSubscribe lookupRes True
+  where
+      doSubscribe lookupResponse allowRetry = maybe
+          (pure . Left $ "No node found")
+          (\(foundHost, foundPort) -> do
+              let origin = "http://" <> Txt.pack (confServiceHost $ serviceConf serv) <> ":" <> Txt.pack (show (getListeningPortFromService serv :: Integer))
+              resp <- runClientM (tagSubscribeClient tag (Just origin)) (mkClientEnv (httpMan serv) (BaseUrl Http foundHost (fromIntegral foundPort) ""))
+              case resp of
+                Left (FailureResponse _ fresp)
+                  |(HTTPT.statusCode . responseStatusCode $ fresp) == 410 && allowRetry -> do  -- responsibility gone, force new lookup
+                      newRes <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
+                      doSubscribe newRes False
+                Left err    -> pure . Left . show $ err
+                Right lease -> pure . Right $ lease
+          )
+          lookupResponse
+
 
 -- currently this is unused code
 getClients :: String -> Int -> HTTP.Manager -> Client IO PostServiceAPI

From bf277c5a730f92f669929f2f015aa6b471758b59 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 13 Aug 2020 23:50:33 +0200
Subject: [PATCH 038/112] unsubsribe from tag

---
 src/Hash2Pub/PostService.hs | 29 ++++++++++++++++++++++++++++-
 1 file changed, 28 insertions(+), 1 deletion(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 26c473b..99a9efb 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -291,8 +291,13 @@ tagSubscribe serv hashtag origin = do
     pure $ round leaseTime
 
 
-tagUnsubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Text
+tagUnsubscribe :: DHT d => PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Text
 tagUnsubscribe serv hashtag origin = do
+    responsible <- liftIO $ isResponsibleFor (baseDHT serv) (genKeyID . Txt.unpack $ hashtag)
+    if not responsible
+       -- GONE if not responsible
+       then throwError err410 { errBody = "not responsible for this tag" }
+       else pure ()
     originURL <- maybe
         (throwError $ err400 { errBody = "Missing Origin header" })
         pure
@@ -382,6 +387,28 @@ clientSubscribeTo serv tag = do
           lookupResponse
 
 
+-- | Unsubscribe the client from the given hashtag.
+clientUnsubscribeFrom :: DHT d => PostService d -> Hashtag -> IO (Either String ())
+clientUnsubscribeFrom serv tag = do
+    lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag)
+    doUnsubscribe lookupRes True
+  where
+      doUnsubscribe lookupResponse allowRetry = maybe
+          (pure . Left $ "No node found")
+          (\(foundHost, foundPort) -> do
+              let origin = "http://" <> Txt.pack (confServiceHost $ serviceConf serv) <> ":" <> Txt.pack (show (getListeningPortFromService serv :: Integer))
+              resp <- runClientM (tagUnsubscribeClient tag (Just origin)) (mkClientEnv (httpMan serv) (BaseUrl Http foundHost (fromIntegral foundPort) ""))
+              case resp of
+                Left (FailureResponse _ fresp)
+                  |(HTTPT.statusCode . responseStatusCode $ fresp) == 410 && allowRetry -> do  -- responsibility gone, force new lookup
+                      newRes <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
+                      doUnsubscribe newRes False
+                Left err    -> pure . Left . show $ err
+                Right _ -> pure . Right $ ()
+          )
+          lookupResponse
+
+
 -- currently this is unused code
 getClients :: String -> Int -> HTTP.Manager -> Client IO PostServiceAPI
 getClients hostname' port' httpMan = hoistClient clientAPI

From 4339cace201193d11842b95a502ccc6c7bef4742 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 14 Aug 2020 11:06:58 +0200
Subject: [PATCH 039/112] function for initially publishing a post

---
 src/Hash2Pub/PostService.hs | 15 +++++++++++++++
 1 file changed, 15 insertions(+)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 99a9efb..797a9e6 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -19,6 +19,7 @@ import           Control.Exception             (Exception (..), try)
 import           Control.Monad                 (foldM, forM, forM_, forever)
 import           Control.Monad.IO.Class        (liftIO)
 import           Control.Monad.STM
+import           Data.Bifunctor
 import qualified Data.ByteString.Lazy.UTF8     as BSUL
 import qualified Data.ByteString.UTF8          as BSU
 import qualified Data.HashMap.Strict           as HMap
@@ -409,6 +410,20 @@ clientUnsubscribeFrom serv tag = do
           lookupResponse
 
 
+-- | publish a new post to the inbox of a specified relay instance. This
+-- instance will then be the originating instance of the post and will forward
+-- the post to the responsible relays.
+-- As the initial publishing isn't done by a specific relay (but *to* a specific relay
+-- instead), the function does *not* take a PostService as argument.
+clientPublishPost :: HTTP.Manager   -- for better performance, a shared HTTP manager has to be provided
+                  -> String         -- hostname
+                  -> Int            -- port
+                  -> PostContent    -- post content
+                  -> IO (Either String ())  -- error or success
+clientPublishPost httpman hostname port postC = do
+    resp <- runClientM (postInboxClient postC) (mkClientEnv httpman (BaseUrl Http hostname port ""))
+    pure . bimap show (const ()) $ resp
+
 -- currently this is unused code
 getClients :: String -> Int -> HTTP.Manager -> Client IO PostServiceAPI
 getClients hostname' port' httpMan = hoistClient clientAPI

From 5f7ca23f71f9aa1b9e3f1b50634008d7e4d50e01 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 14 Aug 2020 22:59:14 +0200
Subject: [PATCH 040/112] add missing leave request sending function

---
 src/Hash2Pub/DHTProtocol.hs | 38 +++++++++++++++++++++++++++++++++----
 1 file changed, 34 insertions(+), 4 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index a071132..ca87295 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -338,15 +338,15 @@ respondLeave nsSTM msgSet = do
                                               )
                                               ([],[]) msgSet
         aRequestPart = Set.elemAt 0 msgSet
-        senderID = getNid . sender $ aRequestPart
+        leaveSenderID = getNid . sender $ aRequestPart
     responseMsg <- atomically $ do
         nsSnap <- readTVar nsSTM
         -- remove leaving node from successors, predecessors and NodeCache
-        writeTQueue (cacheWriteQueue nsSnap) $ deleteCacheEntry senderID
+        writeTQueue (cacheWriteQueue nsSnap) $ deleteCacheEntry leaveSenderID
         writeTVar nsSTM $
             -- add predecessors and successors of leaving node to own lists
-            setPredecessors (filter ((/=) senderID . getNid) $ requestPreds <> predecessors nsSnap)
-          . setSuccessors (filter ((/=) senderID . getNid) $ requestSuccs <> successors nsSnap) $ nsSnap
+            setPredecessors (filter ((/=) leaveSenderID . getNid) $ requestPreds <> predecessors nsSnap)
+          . setSuccessors (filter ((/=) leaveSenderID . getNid) $ requestSuccs <> successors nsSnap) $ nsSnap
         -- TODO: handle handover of key data
         let leaveResponse = Response {
                 requestID = requestID aRequestPart
@@ -625,6 +625,36 @@ requestStabilise ns neighbour = do
         ) responses
 
 
+-- | Send a Leave request to the specified node.
+-- Service data transfer needs to be done separately, as not all neighbours
+-- that need to know about the leaving handle the new service data.
+requestLeave :: LocalNodeState s
+             -> RemoteNodeState     -- target node
+             -> IO (Either String ())   -- error or success
+requestLeave ns target = do
+    srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
+    let leavePayload = LeaveRequestPayload {
+        leaveSuccessors = successors ns
+      , leavePredecessors = predecessors ns
+                                           }
+    responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close (fmap Right . sendRequestTo 5000 3 (\rid ->
+        Request {
+            requestID = rid
+          , sender = toRemoteNodeState ns
+          , part = 1
+          , isFinalPart = False
+          , action = Leave
+          , payload = Just leavePayload
+                }
+                         )
+                                                                                           ) `catch`  (\e -> pure . Left $ displayException (e :: IOException))
+    either
+        -- forward IO error messages
+        (pure . Left)
+        -- empty payload, so no processing required
+        (const . pure . Right $ ())
+        responses
+
 requestPing :: LocalNodeState s      -- ^ sending node
                  -> RemoteNodeState     -- ^ node to be PINGed
                  -> IO (Either String [RemoteNodeState])   -- ^ all active vServers of the pinged node

From 8db8907163a2771d6659d731bb1c08d134ef9ba2 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sat, 15 Aug 2020 17:19:53 +0200
Subject: [PATCH 041/112] filter out spoofed requests for important operations
 like Join, Leave, Stabilise

---
 src/Hash2Pub/DHTProtocol.hs | 26 +++++++++++++++++++++++---
 1 file changed, 23 insertions(+), 3 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index ca87295..9f9d86d 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -262,6 +262,7 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do
     case headMay . Set.elems $ msgSet of
       Nothing -> pure ()
       Just aPart -> do
+        let (SockAddrInet6 _ _ sourceIP _) = sourceAddr
         queueAddEntries (Identity $ RemoteCacheEntry (sender aPart) now) ns
         -- distinguish on whether and how to respond. If responding, pass message to response generating function and write responses to send queue
         maybe (pure ()) (
@@ -269,17 +270,36 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do
                         )
             =<< (case action aPart of
                 Ping -> Just <$> respondPing nsSTM msgSet
-                Join -> Just <$> respondJoin nsSTM msgSet
+                Join -> dropSpoofedIDs sourceIP nsSTM msgSet respondJoin
                 -- ToDo: figure out what happens if not joined
                 QueryID -> Just <$> respondQueryID nsSTM msgSet
                 -- only when joined
-                Leave -> if isJoined ns then Just <$> respondLeave nsSTM msgSet else pure Nothing
-                Stabilise -> if isJoined ns then Just <$> respondStabilise nsSTM msgSet else pure Nothing
+                Leave -> if isJoined ns then dropSpoofedIDs sourceIP nsSTM msgSet respondLeave else pure Nothing
+                Stabilise -> if isJoined ns then dropSpoofedIDs sourceIP nsSTM msgSet respondStabilise else pure Nothing
             )
       -- for single part request, response starts with part number 1. For multipart requests, response starts with part number n+1.
 
       -- TODO: determine request type only from first part, but catch RecSelError on each record access when folding, because otherwise different request type parts can make this crash
       -- TODO: test case: mixed message types of parts
+  where
+      -- | Filter out requests with spoofed node IDs by recomputing the ID using
+      -- the sender IP.
+      -- For valid (non-spoofed) sender IDs, the passed responder function is invoked.
+      dropSpoofedIDs :: HostAddress6        -- msg source address
+                     -> LocalNodeStateSTM s
+                     -> Set.Set FediChordMessage    -- message parts of the request
+                     -> (LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString))     -- reponder function to be invoked for valid requests
+                     -> IO (Maybe (Map.Map Integer BS.ByteString))
+      dropSpoofedIDs addr nsSTM' msgSet' responder =
+          let 
+            aRequestPart = Set.elemAt 0 msgSet
+            senderNs = sender aRequestPart
+            givenSenderID = getNid senderNs
+            recomputedID = genNodeID addr (getDomain senderNs) (fromInteger $ getVServerID senderNs)
+          in
+          if recomputedID == givenSenderID
+             then Just <$> responder nsSTM' msgSet'
+             else pure Nothing
 
 
 -- ....... response sending .......

From d2e4359a21a17f3c65864ee7cfd260663045c376 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sat, 15 Aug 2020 17:37:06 +0200
Subject: [PATCH 042/112] rename join function to clarify it just joining a
 single vserver

---
 src/Hash2Pub/DHTProtocol.hs |  2 +-
 src/Hash2Pub/FediChord.hs   | 22 ++++++++++------------
 2 files changed, 11 insertions(+), 13 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index 9f9d86d..7ed5ec7 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -291,7 +291,7 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do
                      -> (LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString))     -- reponder function to be invoked for valid requests
                      -> IO (Maybe (Map.Map Integer BS.ByteString))
       dropSpoofedIDs addr nsSTM' msgSet' responder =
-          let 
+          let
             aRequestPart = Set.elemAt 0 msgSet
             senderNs = sender aRequestPart
             givenSenderID = getNid senderNs
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 7911f3c..dbca8a5 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -1,9 +1,8 @@
-{-# LANGUAGE DataKinds            #-}
-{-# LANGUAGE DerivingStrategies   #-}
-{-# LANGUAGE FlexibleContexts     #-}
-{-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE OverloadedStrings    #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE OverloadedStrings  #-}
 {- |
 Module      : FediChord
 Description : An opinionated implementation of the EpiChord DHT by Leong et al.
@@ -40,7 +39,7 @@ module Hash2Pub.FediChord (
   , bsAsIpAddr
   , FediChordConf(..)
   , fediChordInit
-  , fediChordJoin
+  , fediChordVserverJoin
   , fediChordBootstrapJoin
   , tryBootstrapJoining
   , fediMainThreads
@@ -250,10 +249,10 @@ bootstrapQueryId nsSTM (bootstrapHost, bootstrapPort) targetID = do
 
 -- | join a node to the DHT using the global node cache
 -- node's position.
-fediChordJoin :: LocalNodeStateSTM s                    -- ^ the local 'NodeState'
+fediChordVserverJoin :: LocalNodeStateSTM s                    -- ^ the local 'NodeState'
               -> IO (Either String (LocalNodeStateSTM s))  -- ^ the joined 'NodeState' after a
                                                     -- successful join, otherwise an error message
-fediChordJoin nsSTM = do
+fediChordVserverJoin nsSTM = do
     ns <- readTVarIO nsSTM
     -- 1. get routed to the currently responsible node
     currentlyResponsible <- requestQueryID ns $ getNid ns
@@ -284,14 +283,13 @@ joinOnNewEntriesThread nsSTM = loop
               pure ()
           -- otherwise try joining
           FORWARD _ -> do
-              joinResult <- fediChordJoin nsSTM
+              joinResult <- fediChordVserverJoin nsSTM
               either
                 -- on join failure, sleep and retry
                 -- TODO: make delay configurable
                 (const $ threadDelay (30 * 10^6) >> loop)
                 (const $ pure ())
                 joinResult
-    emptyset = Set.empty    -- because pattern matches don't accept qualified names
 
 
 -- | cache updater thread that waits for incoming NodeCache update instructions on
@@ -485,7 +483,7 @@ stabiliseThread nsSTM = forever $ do
     threadDelay (60 * 10^6)
   where
     -- | send a stabilise request to the n-th neighbour
-    -- (specified by the provided getter function) and on failure retr
+    -- (specified by the provided getter function) and on failure retry
     -- with the n+1-th neighbour.
     -- On success, return 2 lists: The failed nodes and the potential neighbours
     -- returned by the queried node.

From 4302452d18dd6fd88d472f2d8f1293e9d4774235 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sat, 15 Aug 2020 22:55:19 +0200
Subject: [PATCH 043/112] implement vserver leave and trigger data transfer
 initiation

still unused though
contributes to #36
---
 src/Hash2Pub/DHTProtocol.hs    |  1 +
 src/Hash2Pub/FediChord.hs      | 35 ++++++++++++++++++++++++++++++++++
 src/Hash2Pub/FediChordTypes.hs |  6 ++++++
 src/Hash2Pub/PostService.hs    | 10 ++++++----
 4 files changed, 48 insertions(+), 4 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index 7ed5ec7..8930edc 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -19,6 +19,7 @@ module Hash2Pub.DHTProtocol
     , sendQueryIdMessages
     , requestQueryID
     , requestJoin
+    , requestLeave
     , requestPing
     , requestStabilise
     , lookupMessage
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index dbca8a5..c55d94c 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -263,6 +263,41 @@ fediChordVserverJoin nsSTM = do
       Left err       -> pure . Left $ "Error joining on " <> err
       Right joinedNS -> pure . Right $ joinedNS
 
+fediChordVserverLeave :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) => LocalNodeState s -> m ()
+fediChordVserverLeave ns = do
+    -- TODO: deal with failure of all successors, e.g. by invoking a stabilise
+    -- and looking up further successors. So far we just fail here.
+    _ <- migrateSuccessor
+    -- then send leave messages to all other neighbours
+    -- TODO: distinguish between sending error causes on our side and on the
+    -- network/ target side. The latter cannot be fixed anyways while the
+    -- former could be worked around
+
+    -- send a leave message to all neighbours
+    forM_ (predecessors ns <> successors ns) $ liftIO . requestLeave ns
+  where
+    sendUntilSuccess i = maybe
+                     (pure $ Left "Exhausted all successors")
+                     (\neighb -> do
+                         leaveResponse <- requestLeave ns neighb
+                         case leaveResponse of
+                           Left _ -> sendUntilSuccess (i+1)
+                           -- return first successfully contacted neighbour,
+                           -- so it can be contacted by the service layer for migration
+                           Right _  -> pure $ Right neighb
+                     )
+                     $ atMay (successors ns) i
+    migrateSuccessor :: (MonadError String m, MonadIO m) => m ()
+    migrateSuccessor = do
+        -- send leave message to first responding successor
+        successorLeave <- liftIO $ sendUntilSuccess 0
+        -- trigger service data transfer for abandoned key space
+        migrateToNode <- liftEither successorLeave
+        ownService <- nodeService <$> (liftIO . readTVarIO $ parentRealNode ns)
+        migrationResult <- liftIO $ migrateData ownService (getNid ns) (getNid migrateToNode) (getDomain migrateToNode, fromIntegral $ getServicePort migrateToNode)
+        liftEither migrationResult
+
+
 
 -- | Wait for new cache entries to appear and then try joining on them.
 -- Exits after successful joining.
diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs
index 20d65fe..214ece2 100644
--- a/src/Hash2Pub/FediChordTypes.hs
+++ b/src/Hash2Pub/FediChordTypes.hs
@@ -424,6 +424,12 @@ class Service s d where
     -- | run the service
     runService :: ServiceConf -> d -> IO (s d)
     getListeningPortFromService :: (Integral i) => s d -> i
+    -- | trigger a service data migration of data between the two given keys
+    migrateData :: s d
+                -> NodeID       -- ^ start key
+                -> NodeID       -- ^ end key
+                -> (String, Int)    -- ^ hostname and port of target service
+                -> IO (Either String ())    -- ^ success or failure
 
 instance Hashable.Hashable NodeID where
     hashWithSalt salt = Hashable.hashWithSalt salt . getNodeID
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 797a9e6..71998df 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -115,6 +115,8 @@ instance DHT d => Service PostService d where
 
     getListeningPortFromService = fromIntegral . confServicePort . serviceConf
 
+    migrateData = clientDeliverSubscriptions
+
 
 -- | return a WAI application
 postServiceApplication :: DHT d => PostService d -> Application
@@ -320,13 +322,13 @@ relayInboxClient :<|> subscriptionDeliveryClient :<|> postFetchClient :<|> postM
 -- and their outstanding delivery queue to another instance.
 -- If the transfer succeeds, the transfered subscribers are removed from the local list.
 clientDeliverSubscriptions :: PostService d
-                           -> Hashtag -- ^ fromTag
-                           -> Hashtag -- ^ toTag
+                           -> NodeID -- ^ fromTag
+                           -> NodeID -- ^ toTag
                            -> (String, Int)     -- ^ hostname and port of instance to deliver to
                            -> IO (Either String ())     -- Either signals success or failure
-clientDeliverSubscriptions serv fromTag toTag (toHost, toPort) = do
+clientDeliverSubscriptions serv fromKey toKey (toHost, toPort) = do
     -- collect tag intearval
-    intervalTags <- takeRMapSuccessorsFromTo (genKeyID $ Txt.unpack fromTag) (genKeyID $ Txt.unpack toTag) <$> readTVarIO (subscribers serv)
+    intervalTags <- takeRMapSuccessorsFromTo fromKey toKey <$> readTVarIO (subscribers serv)
     -- returns a [ (TagSubscribersSTM, TChan PostID, Hashtag) ]
     -- extract subscribers and posts
     -- no need for extracting as a single atomic operation, as newly incoming posts are supposed to be rejected because of already having re-positioned on the DHT

From 470ce6f39af71d77b36e68e17c6033b2d73d4654 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sat, 15 Aug 2020 23:58:47 +0200
Subject: [PATCH 044/112] correct the slice of transfered tags at leave

---
 src/Hash2Pub/FediChord.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index c55d94c..44ea80a 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -293,8 +293,11 @@ fediChordVserverLeave ns = do
         successorLeave <- liftIO $ sendUntilSuccess 0
         -- trigger service data transfer for abandoned key space
         migrateToNode <- liftEither successorLeave
+        let lowerKeyBound = maybe (getNid ns) getNid $ headMay (predecessors ns)
         ownService <- nodeService <$> (liftIO . readTVarIO $ parentRealNode ns)
-        migrationResult <- liftIO $ migrateData ownService (getNid ns) (getNid migrateToNode) (getDomain migrateToNode, fromIntegral $ getServicePort migrateToNode)
+        -- previously held data is the one between the immediate predecessor and
+        -- the own ID
+        migrationResult <- liftIO $ migrateData ownService lowerKeyBound (getNid ns) (getDomain migrateToNode, fromIntegral $ getServicePort migrateToNode)
         liftEither migrationResult
 
 

From 581757965aa107532c81fb31fb72d568c881a42c Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sun, 16 Aug 2020 17:53:48 +0200
Subject: [PATCH 045/112] trigger service data migration at join

---
 src/Hash2Pub/DHTProtocol.hs | 28 +++++++++++++++++++---------
 src/Hash2Pub/FediChord.hs   |  9 +++++----
 2 files changed, 24 insertions(+), 13 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index 8930edc..f5fcdbd 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -41,13 +41,14 @@ module Hash2Pub.DHTProtocol
     )
         where
 
+import           Control.Concurrent
 import           Control.Concurrent.Async
 import           Control.Concurrent.STM
 import           Control.Concurrent.STM.TBQueue
 import           Control.Concurrent.STM.TQueue
 import           Control.Concurrent.STM.TVar
 import           Control.Exception
-import           Control.Monad                  (foldM, forM, forM_)
+import           Control.Monad                  (foldM, forM, forM_, when)
 import qualified Data.ByteString                as BS
 import           Data.Either                    (rights)
 import           Data.Foldable                  (foldl', foldr')
@@ -75,10 +76,11 @@ import           Hash2Pub.FediChordTypes        (CacheEntry (..),
                                                  LocalNodeState (..),
                                                  LocalNodeStateSTM, NodeCache,
                                                  NodeID, NodeState (..),
-                                                 RealNode (..),
+                                                 RealNode (..), RealNodeSTM,
                                                  RemoteNodeState (..),
                                                  RingEntry (..), RingMap (..),
-                                                 addRMapEntry, addRMapEntryWith,
+                                                 Service (..), addRMapEntry,
+                                                 addRMapEntryWith,
                                                  cacheGetNodeStateUnvalidated,
                                                  cacheLookup, cacheLookupPred,
                                                  cacheLookupSucc, genNodeID,
@@ -250,7 +252,8 @@ ackRequest _ _ = Map.empty
 
 -- | Dispatch incoming requests to the dedicated handling and response function, and enqueue
 -- the response to be sent.
-handleIncomingRequest :: LocalNodeStateSTM s                     -- ^ the handling node
+handleIncomingRequest :: Service s (RealNodeSTM s)
+                      => LocalNodeStateSTM s                     -- ^ the handling node
                       -> TQueue (BS.ByteString, SockAddr)   -- ^ send queue
                       -> Set.Set FediChordMessage           -- ^ all parts of the request to handle
                       -> SockAddr                           -- ^ source address of the request
@@ -422,10 +425,10 @@ respondPing nsSTM msgSet = do
 
 -- this modifies node state, so locking and IO seems to be necessary.
 -- Still try to keep as much code as possible pure
-respondJoin :: LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
+respondJoin :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
 respondJoin nsSTM msgSet = do
     -- atomically read and modify the node state according to the parsed request
-    responseMsg <- atomically $ do
+    (dataMigration, responseMsg) <- atomically $ do
         nsSnap <- readTVar nsSTM
         cache <- readTVar $ nodeCacheSTM nsSnap
         let
@@ -455,17 +458,24 @@ respondJoin nsSTM msgSet = do
                , payload = Just responsePayload
                                      }
            writeTVar nsSTM joinedNS
-           pure joinResponse
+           ownService <- nodeService <$> readTVar (parentRealNode nsSnap)
+           let
+             serviceDataMigrator = migrateData ownService lowerKeyBound (getNid senderNS) (getDomain senderNS, fromIntegral $ getServicePort senderNS)
+             lowerKeyBound = maybe (getNid nsSnap) getNid $ headMay (predecessors nsSnap)
+           pure (Just serviceDataMigrator, joinResponse)
         -- otherwise respond with empty payload
-        else pure Response {
+        else pure (Nothing, Response {
              requestID = requestID aRequestPart
            , senderID = getNid nsSnap
            , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1
            , isFinalPart = False
            , action = Join
            , payload = Nothing
-                           }
+                           })
 
+    -- as DHT response is required immediately, fork the service data migration push
+    -- into a new thread. That's kind of ugly but the best I can think of so far
+    when (isJust dataMigration) (forkIO (fromJust dataMigration >> pure ()) >> pure ())
     pure $ serialiseMessage sendMessageSize responseMsg
     -- TODO: notify service layer to copy over data now handled by the new joined node
 
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 44ea80a..f3a482c 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -281,10 +281,10 @@ fediChordVserverLeave ns = do
                      (\neighb -> do
                          leaveResponse <- requestLeave ns neighb
                          case leaveResponse of
-                           Left _ -> sendUntilSuccess (i+1)
+                           Left _  -> sendUntilSuccess (i+1)
                            -- return first successfully contacted neighbour,
                            -- so it can be contacted by the service layer for migration
-                           Right _  -> pure $ Right neighb
+                           Right _ -> pure $ Right neighb
                      )
                      $ atMay (successors ns) i
     migrateSuccessor :: (MonadError String m, MonadIO m) => m ()
@@ -579,7 +579,7 @@ sendThread sock sendQ = forever $ do
     sendAllTo sock packet addr
 
 -- | Sets up and manages the main server threads of FediChord
-fediMainThreads :: Socket -> LocalNodeStateSTM s -> IO ()
+fediMainThreads :: Service s (RealNodeSTM s) => Socket -> LocalNodeStateSTM s -> IO ()
 fediMainThreads sock nsSTM = do
     ns <- readTVarIO nsSTM
     putStrLn "launching threads"
@@ -622,7 +622,8 @@ requestMapPurge mapVar = forever $ do
 
 -- | Wait for messages, deserialise them, manage parts and acknowledgement status,
 -- and pass them to their specific handling function.
-fediMessageHandler :: TQueue (BS.ByteString, SockAddr)  -- ^ send queue
+fediMessageHandler :: Service s (RealNodeSTM s)
+                   => TQueue (BS.ByteString, SockAddr)  -- ^ send queue
                    -> TQueue (BS.ByteString, SockAddr)  -- ^ receive queue
                    -> LocalNodeStateSTM s                  -- ^ acting NodeState
                    -> IO ()

From 414564705a9bb8fb2f1f81938e7f607b4010e78a Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sun, 16 Aug 2020 23:26:18 +0200
Subject: [PATCH 046/112] possibility to wait for a migration to complete

---
 src/Hash2Pub/DHTProtocol.hs    |  2 +-
 src/Hash2Pub/FediChord.hs      |  2 +-
 src/Hash2Pub/FediChordTypes.hs |  3 ++
 src/Hash2Pub/PostService.hs    | 50 ++++++++++++++++++++++++----------
 4 files changed, 41 insertions(+), 16 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index f5fcdbd..52ea5ba 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -460,7 +460,7 @@ respondJoin nsSTM msgSet = do
            writeTVar nsSTM joinedNS
            ownService <- nodeService <$> readTVar (parentRealNode nsSnap)
            let
-             serviceDataMigrator = migrateData ownService lowerKeyBound (getNid senderNS) (getDomain senderNS, fromIntegral $ getServicePort senderNS)
+             serviceDataMigrator = migrateData ownService (getNid nsSnap) lowerKeyBound (getNid senderNS) (getDomain senderNS, fromIntegral $ getServicePort senderNS)
              lowerKeyBound = maybe (getNid nsSnap) getNid $ headMay (predecessors nsSnap)
            pure (Just serviceDataMigrator, joinResponse)
         -- otherwise respond with empty payload
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index f3a482c..8d25186 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -297,7 +297,7 @@ fediChordVserverLeave ns = do
         ownService <- nodeService <$> (liftIO . readTVarIO $ parentRealNode ns)
         -- previously held data is the one between the immediate predecessor and
         -- the own ID
-        migrationResult <- liftIO $ migrateData ownService lowerKeyBound (getNid ns) (getDomain migrateToNode, fromIntegral $ getServicePort migrateToNode)
+        migrationResult <- liftIO $ migrateData ownService (getNid ns) lowerKeyBound (getNid ns) (getDomain migrateToNode, fromIntegral $ getServicePort migrateToNode)
         liftEither migrationResult
 
 
diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs
index 214ece2..cbd3a58 100644
--- a/src/Hash2Pub/FediChordTypes.hs
+++ b/src/Hash2Pub/FediChordTypes.hs
@@ -426,10 +426,13 @@ class Service s d where
     getListeningPortFromService :: (Integral i) => s d -> i
     -- | trigger a service data migration of data between the two given keys
     migrateData :: s d
+                -> NodeID       -- ^ source/ sender node ID
                 -> NodeID       -- ^ start key
                 -> NodeID       -- ^ end key
                 -> (String, Int)    -- ^ hostname and port of target service
                 -> IO (Either String ())    -- ^ success or failure
+    -- | Wait for an incoming migration from a given node to succeed, may block forever
+    waitForMigrationFrom :: s d -> NodeID -> IO ()
 
 instance Hashable.Hashable NodeID where
     hashWithSalt salt = Hashable.hashWithSalt salt . getNodeID
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 71998df..548469e 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -10,6 +10,7 @@ module Hash2Pub.PostService where
 
 import           Control.Concurrent
 import           Control.Concurrent.Async
+import           Control.Concurrent.MVar
 import           Control.Concurrent.STM
 import           Control.Concurrent.STM.TChan
 import           Control.Concurrent.STM.TChan
@@ -46,20 +47,21 @@ import           Hash2Pub.RingMap
 
 
 data PostService d = PostService
-    { serviceConf      :: ServiceConf
+    { serviceConf          :: ServiceConf
     -- queues, other data structures
-    , baseDHT          ::   (DHT d) => d
-    , serviceThread    :: TVar ThreadId
-    , subscribers      :: TVar RelayTags
+    , baseDHT              ::   (DHT d) => d
+    , serviceThread        :: TVar ThreadId
+    , subscribers          :: TVar RelayTags
     -- ^ for each tag store the subscribers + their queue
-    , ownSubscriptions :: TVar (HMap.HashMap NodeID POSIXTime)
+    , ownSubscriptions     :: TVar (HMap.HashMap NodeID POSIXTime)
     -- ^ tags subscribed by the own node have an assigned lease time
-    , ownPosts         :: TVar (HSet.HashSet Txt.Text)
+    , ownPosts             :: TVar (HSet.HashSet Txt.Text)
     -- ^ just store the existence of posts for saving memory,
-    , relayInQueue     :: TQueue (Hashtag, PostID, PostContent)
+    , relayInQueue         :: TQueue (Hashtag, PostID, PostContent)
     -- ^ Queue for processing incoming posts of own instance asynchronously
-    , postFetchQueue   :: TQueue PostID
-    , httpMan          :: HTTP.Manager
+    , postFetchQueue       :: TQueue PostID
+    , migrationsInProgress :: TVar (HMap.HashMap NodeID (MVar ()))
+    , httpMan              :: HTTP.Manager
     }
     deriving (Typeable)
 
@@ -86,6 +88,7 @@ instance DHT d => Service PostService d where
         ownPostVar <- newTVarIO HSet.empty
         relayInQueue' <- newTQueueIO
         postFetchQueue' <- newTQueueIO
+        migrationsInProgress' <- newTVarIO HMap.empty
         httpMan' <- HTTP.newManager HTTP.defaultManagerSettings
         let
             thisService = PostService {
@@ -97,6 +100,7 @@ instance DHT d => Service PostService d where
               , ownPosts = ownPostVar
               , relayInQueue = relayInQueue'
               , postFetchQueue = postFetchQueue'
+              , migrationsInProgress = migrationsInProgress'
               , httpMan = httpMan'
                                       }
             port' = fromIntegral (confServicePort conf)
@@ -117,6 +121,17 @@ instance DHT d => Service PostService d where
 
     migrateData = clientDeliverSubscriptions
 
+    waitForMigrationFrom serv fromID = do
+        migrationSynchroniser <- atomically $ do
+            syncPoint <- HMap.lookup fromID <$> readTVar (migrationsInProgress serv)
+            maybe
+              -- decision: this function blocks until it gets an incoming migration from given ID
+              retry
+              pure
+              syncPoint
+        -- block until migration finished
+        takeMVar migrationSynchroniser
+
 
 -- | return a WAI application
 postServiceApplication :: DHT d => PostService d -> Application
@@ -136,7 +151,7 @@ placeholderPost = Txt.take 5120 . Txt.repeat $ 'O' -- size 5KiB
 
 type PostServiceAPI = "relay" :> "inbox" :> Capture "hashtag" Txt.Text :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
                  -- delivery endpoint of newly published posts of the relay's instance
-                 :<|> "relay" :> "subscribers" :> ReqBody '[PlainText] Txt.Text :> PostNoContent '[PlainText] Txt.Text
+                 :<|> "relay" :> "subscribers" :> Capture "senderID" Integer :> ReqBody '[PlainText] Txt.Text :> PostNoContent '[PlainText] Txt.Text
                  -- endpoint for delivering the subscriptions and outstanding queue
                  :<|> "post" :> Capture "postid" Txt.Text :> Get '[PlainText] Txt.Text
                  -- fetch endpoint for posts, full post ID is http://$domain/post/$postid
@@ -194,10 +209,14 @@ newtype UnhandledTagException = UnhandledTagException String
 
 instance Exception UnhandledTagException
 
-subscriptionDelivery :: DHT d => PostService d -> Txt.Text -> Handler Txt.Text
-subscriptionDelivery serv subList = do
+subscriptionDelivery :: DHT d => PostService d -> Integer -> Txt.Text -> Handler Txt.Text
+subscriptionDelivery serv senderID subList = do
     let
         tagSubs = Txt.lines subList
+    -- signal that the migration is in progress
+    syncMVar <- liftIO newEmptyMVar
+    liftIO . atomically $ modifyTVar' (migrationsInProgress serv) $
+        HMap.insert (fromInteger senderID) syncMVar
     -- In favor of having the convenience of rolling back the transaction once a
     -- not-handled tag occurs, this results in a single large transaction.
     -- Hopefully the performance isn't too bad.
@@ -211,6 +230,8 @@ subscriptionDelivery serv subList = do
            `catchSTM` (\e -> pure . Left $ show (e :: UnhandledTagException))
            -- TODO: potentially log this
                           :: STM (Either String ()))
+    -- TODO: should this always signal migration finished to avoid deadlocksP
+    liftIO $ putMVar syncMVar ()
     case res of
       Left err -> throwError err410 {errBody = BSUL.fromString err}
       Right _  -> pure ""
@@ -322,11 +343,12 @@ relayInboxClient :<|> subscriptionDeliveryClient :<|> postFetchClient :<|> postM
 -- and their outstanding delivery queue to another instance.
 -- If the transfer succeeds, the transfered subscribers are removed from the local list.
 clientDeliverSubscriptions :: PostService d
+                           -> NodeID -- ^ sender node ID
                            -> NodeID -- ^ fromTag
                            -> NodeID -- ^ toTag
                            -> (String, Int)     -- ^ hostname and port of instance to deliver to
                            -> IO (Either String ())     -- Either signals success or failure
-clientDeliverSubscriptions serv fromKey toKey (toHost, toPort) = do
+clientDeliverSubscriptions serv fromNode fromKey toKey (toHost, toPort) = do
     -- collect tag intearval
     intervalTags <- takeRMapSuccessorsFromTo fromKey toKey <$> readTVarIO (subscribers serv)
     -- returns a [ (TagSubscribersSTM, TChan PostID, Hashtag) ]
@@ -350,7 +372,7 @@ clientDeliverSubscriptions serv fromKey toKey (toHost, toPort) = do
         ""
         intervalTags
     -- send subscribers
-    resp <- runClientM (subscriptionDeliveryClient subscriberData) (mkClientEnv (httpMan serv) (BaseUrl Http toHost (fromIntegral toPort) ""))
+    resp <- runClientM (subscriptionDeliveryClient (getNodeID fromNode) subscriberData) (mkClientEnv (httpMan serv) (BaseUrl Http toHost (fromIntegral toPort) ""))
     -- on failure return a Left, otherwise delete subscription entry
     case resp of
       Left err -> pure . Left . show $ err

From c49c1a89c9c5774a810f31c963bb54221901682a Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 17 Aug 2020 00:22:37 +0200
Subject: [PATCH 047/112] wait for migration to complete on join

also clean up migration entry after success
---
 src/Hash2Pub/DHTProtocol.hs | 13 ++++++++-----
 src/Hash2Pub/FediChord.hs   | 18 ++++++++++--------
 src/Hash2Pub/PostService.hs |  6 +++++-
 3 files changed, 23 insertions(+), 14 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index 52ea5ba..13dd434 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -482,7 +482,7 @@ respondJoin nsSTM msgSet = do
 -- ....... request sending .......
 
 -- | send a join request and return the joined 'LocalNodeState' including neighbours
-requestJoin :: NodeState a => a             -- ^ currently responsible node to be contacted
+requestJoin :: (NodeState a, Service s (RealNodeSTM s)) => a             -- ^ currently responsible node to be contacted
             -> LocalNodeStateSTM s               -- ^ joining NodeState
             -> IO (Either String (LocalNodeStateSTM s))    -- ^ node after join with all its new information
 requestJoin toJoinOn ownStateSTM = do
@@ -521,12 +521,15 @@ requestJoin toJoinOn ownStateSTM = do
             pure (cacheInsertQ, newState)
         -- execute the cache insertions
         mapM_ (\f -> f joinedState) cacheInsertQ
-        pure $ if responses == Set.empty
-                  then Left $ "join error: got no response from " <> show (getNid toJoinOn)
+        if responses == Set.empty
+                  then pure . Left $ "join error: got no response from " <> show (getNid toJoinOn)
            else if null (predecessors joinedState) && null (successors joinedState)
-                then Left "join error: no predecessors or successors"
+                then pure $ Left "join error: no predecessors or successors"
                 -- successful join
-                else Right ownStateSTM
+                else do
+                    -- wait for migration data to be completely received
+                    waitForMigrationFrom (nodeService prn) (getNid ownState)
+                    pure $ Right ownStateSTM
                                    )
         `catch` (\e -> pure . Left $ displayException (e :: IOException))
 
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 8d25186..f544061 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -152,9 +152,10 @@ nodeStateInit realNodeSTM = do
 
 -- | Join a new node into the DHT, using a provided bootstrap node as initial cache seed
 -- for resolving the new node's position.
-fediChordBootstrapJoin :: LocalNodeStateSTM s            -- ^ the local 'NodeState'
-                        -> (String, PortNumber)   -- ^ domain and port of a bootstrapping node
-                        -> IO (Either String (LocalNodeStateSTM s)) -- ^ the joined 'NodeState' after a
+fediChordBootstrapJoin :: Service s (RealNodeSTM s)
+                       => LocalNodeStateSTM s            -- ^ the local 'NodeState'
+                       -> (String, PortNumber)   -- ^ domain and port of a bootstrapping node
+                       -> IO (Either String (LocalNodeStateSTM s)) -- ^ the joined 'NodeState' after a
                                             -- successful join, otherwise an error message
 fediChordBootstrapJoin nsSTM bootstrapNode = do
     -- can be invoked multiple times with all known bootstrapping nodes until successfully joined
@@ -170,7 +171,7 @@ fediChordBootstrapJoin nsSTM bootstrapNode = do
 
 -- Periodically lookup own ID through a random bootstrapping node to discover and merge separated DHT clusters.
 -- Unjoined try joining instead.
-convergenceSampleThread :: LocalNodeStateSTM s -> IO ()
+convergenceSampleThread :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> IO ()
 convergenceSampleThread nsSTM = forever $ do
     nsSnap <- readTVarIO nsSTM
     parentNode <- readTVarIO $ parentRealNode nsSnap
@@ -201,7 +202,7 @@ convergenceSampleThread nsSTM = forever $ do
 
 
 -- | Try joining the DHT through any of the bootstrapping nodes until it succeeds.
-tryBootstrapJoining :: LocalNodeStateSTM s -> IO (Either String (LocalNodeStateSTM s))
+tryBootstrapJoining :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> IO (Either String (LocalNodeStateSTM s))
 tryBootstrapJoining nsSTM = do
     bss <- atomically $ do
         nsSnap <- readTVar nsSTM
@@ -249,8 +250,9 @@ bootstrapQueryId nsSTM (bootstrapHost, bootstrapPort) targetID = do
 
 -- | join a node to the DHT using the global node cache
 -- node's position.
-fediChordVserverJoin :: LocalNodeStateSTM s                    -- ^ the local 'NodeState'
-              -> IO (Either String (LocalNodeStateSTM s))  -- ^ the joined 'NodeState' after a
+fediChordVserverJoin :: Service s (RealNodeSTM s)
+                     => LocalNodeStateSTM s                    -- ^ the local 'NodeState'
+                     -> IO (Either String (LocalNodeStateSTM s))  -- ^ the joined 'NodeState' after a
                                                     -- successful join, otherwise an error message
 fediChordVserverJoin nsSTM = do
     ns <- readTVarIO nsSTM
@@ -304,7 +306,7 @@ fediChordVserverLeave ns = do
 
 -- | Wait for new cache entries to appear and then try joining on them.
 -- Exits after successful joining.
-joinOnNewEntriesThread :: LocalNodeStateSTM s -> IO ()
+joinOnNewEntriesThread :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> IO ()
 joinOnNewEntriesThread nsSTM = loop
   where
     loop = do
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 548469e..c277327 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -231,7 +231,11 @@ subscriptionDelivery serv senderID subList = do
            -- TODO: potentially log this
                           :: STM (Either String ()))
     -- TODO: should this always signal migration finished to avoid deadlocksP
-    liftIO $ putMVar syncMVar ()
+    liftIO $ putMVar syncMVar ()    -- wakes up waiting thread
+    liftIO $ putMVar syncMVar ()    -- blocks until waiting thread has resumed
+    -- delete this migration from ongoing ones
+    liftIO . atomically $ modifyTVar' (migrationsInProgress serv) $
+        HMap.delete (fromInteger senderID)
     case res of
       Left err -> throwError err410 {errBody = BSUL.fromString err}
       Right _  -> pure ""

From b8cedada4892a6abbea5b31e2599e80d26220118 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 17 Aug 2020 11:37:04 +0200
Subject: [PATCH 048/112] prevent threads not awaiting migration from blocking
 their response

---
 src/Hash2Pub/PostService.hs | 10 ++++++----
 1 file changed, 6 insertions(+), 4 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index c277327..a871343 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -232,10 +232,12 @@ subscriptionDelivery serv senderID subList = do
                           :: STM (Either String ()))
     -- TODO: should this always signal migration finished to avoid deadlocksP
     liftIO $ putMVar syncMVar ()    -- wakes up waiting thread
-    liftIO $ putMVar syncMVar ()    -- blocks until waiting thread has resumed
-    -- delete this migration from ongoing ones
-    liftIO . atomically $ modifyTVar' (migrationsInProgress serv) $
-        HMap.delete (fromInteger senderID)
+    -- allow response to be completed independently from waiting thread
+    _ <- liftIO . forkIO $ do
+        putMVar syncMVar ()    -- blocks until waiting thread has resumed
+        -- delete this migration from ongoing ones
+        liftIO . atomically $ modifyTVar' (migrationsInProgress serv) $
+            HMap.delete (fromInteger senderID)
     case res of
       Left err -> throwError err410 {errBody = BSUL.fromString err}
       Right _  -> pure ""

From 6982a0b245ebcae0ab4b9c4f8b7cad5b0061a254 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 17 Aug 2020 12:34:47 +0200
Subject: [PATCH 049/112] indicate in LeaveRequest whether to expect a
 migration

this information is used to decide whether to await an incoming
migration in `respondLeave`
---
 FediChord.asn1                |  4 ++--
 src/Hash2Pub/ASN1Coding.hs    | 11 ++++++-----
 src/Hash2Pub/DHTProtocol.hs   | 14 +++++++++-----
 src/Hash2Pub/FediChord.hs     |  4 ++--
 src/Hash2Pub/ProtocolTypes.hs |  1 +
 5 files changed, 20 insertions(+), 14 deletions(-)

diff --git a/FediChord.asn1 b/FediChord.asn1
index f278f8f..79b894a 100644
--- a/FediChord.asn1
+++ b/FediChord.asn1
@@ -89,8 +89,8 @@ StabiliseResponsePayload ::= SEQUENCE {
 
 LeaveRequestPayload ::= SEQUENCE {
 	successors		SEQUENCE OF NodeState,
-	predecessors	SEQUENCE OF NodeState
-	-- ToDo: transfer of own data to newly responsible node
+	predecessors	SEQUENCE OF NodeState,
+	doMigration		BOOLEAN
 	}
 
 LeaveResponsePayload ::= NULL	-- just a confirmation
diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs
index 456dac6..10177ab 100644
--- a/src/Hash2Pub/ASN1Coding.hs
+++ b/src/Hash2Pub/ASN1Coding.hs
@@ -38,6 +38,7 @@ splitPayload numParts pl@LeaveRequestPayload{} = [
     LeaveRequestPayload {
         leaveSuccessors = atDef []  (listInto numParts $ leaveSuccessors pl) (thisPart-1)
       , leavePredecessors = atDef  [] (listInto numParts $ leavePredecessors pl) (thisPart-1)
+      , leaveDoMigration = leaveDoMigration pl
                         } | thisPart <- [1..numParts] ]
 splitPayload numParts pl@StabiliseResponsePayload{} = [
     StabiliseResponsePayload {
@@ -134,9 +135,8 @@ encodePayload payload'@LeaveRequestPayload{} =
   <> [End Sequence
   , Start Sequence]
   <> concatMap encodeNodeState (leavePredecessors payload')
-  <> [End Sequence
-  , End Sequence]
--- currently StabiliseResponsePayload and LeaveRequestPayload are equal
+  <> [End Sequence]
+  <> [Boolean (leaveDoMigration payload'), End Sequence]
 encodePayload payload'@StabiliseResponsePayload{} =
     Start Sequence
   : Start Sequence
@@ -144,8 +144,7 @@ encodePayload payload'@StabiliseResponsePayload{} =
   <> [End Sequence
   , Start Sequence]
   <> concatMap encodeNodeState (stabilisePredecessors payload')
-  <> [End Sequence
-  , End Sequence]
+  <> [End Sequence, End Sequence]
 encodePayload payload'@StabiliseRequestPayload = [Null]
 encodePayload payload'@QueryIDResponsePayload{} =
   let
@@ -415,9 +414,11 @@ parseLeaveRequest :: ParseASN1 ActionPayload
 parseLeaveRequest = onNextContainer Sequence $ do
     succ' <- onNextContainer Sequence (getMany parseNodeState)
     pred' <- onNextContainer Sequence (getMany parseNodeState)
+    doMigration <- parseBool
     pure $ LeaveRequestPayload {
         leaveSuccessors = succ'
       , leavePredecessors = pred'
+      , leaveDoMigration = doMigration
                                       }
 
 parseLeaveResponse :: ParseASN1 ActionPayload
diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index 13dd434..972059f 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -48,7 +48,7 @@ import           Control.Concurrent.STM.TBQueue
 import           Control.Concurrent.STM.TQueue
 import           Control.Concurrent.STM.TVar
 import           Control.Exception
-import           Control.Monad                  (foldM, forM, forM_, when)
+import           Control.Monad                  (foldM, forM, forM_, void, when)
 import qualified Data.ByteString                as BS
 import           Data.Either                    (rights)
 import           Data.Foldable                  (foldl', foldr')
@@ -352,8 +352,7 @@ respondQueryID nsSTM msgSet = do
 
 -- | Respond to a Leave request by removing the leaving node from local data structures
 -- and confirming with response.
--- TODO: copy over key data from leaver and confirm
-respondLeave :: LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
+respondLeave :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
 respondLeave nsSTM msgSet = do
     -- combine payload of all parts
     let (requestPreds, requestSuccs) = foldr' (\msg (predAcc, succAcc) ->
@@ -371,7 +370,6 @@ respondLeave nsSTM msgSet = do
             -- add predecessors and successors of leaving node to own lists
             setPredecessors (filter ((/=) leaveSenderID . getNid) $ requestPreds <> predecessors nsSnap)
           . setSuccessors (filter ((/=) leaveSenderID . getNid) $ requestSuccs <> successors nsSnap) $ nsSnap
-        -- TODO: handle handover of key data
         let leaveResponse = Response {
                 requestID = requestID aRequestPart
               , senderID = getNid nsSnap
@@ -381,6 +379,10 @@ respondLeave nsSTM msgSet = do
               , payload = Just LeaveResponsePayload
                                      }
         pure leaveResponse
+    -- if awaiting an incoming service data migration, collect the lock without blocking this thread
+    when (maybe False leaveDoMigration (payload  aRequestPart)) $ do
+        ownService <- atomically $ nodeService <$> ((readTVar nsSTM) >>= (readTVar . parentRealNode))
+        void (forkIO $ waitForMigrationFrom ownService leaveSenderID)
     pure $ serialiseMessage sendMessageSize responseMsg
 
 -- | respond to stabilise requests by returning successor and predecessor list
@@ -663,13 +665,15 @@ requestStabilise ns neighbour = do
 -- Service data transfer needs to be done separately, as not all neighbours
 -- that need to know about the leaving handle the new service data.
 requestLeave :: LocalNodeState s
+             -> Bool                -- whether to migrate service data
              -> RemoteNodeState     -- target node
              -> IO (Either String ())   -- error or success
-requestLeave ns target = do
+requestLeave ns doMigration target = do
     srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
     let leavePayload = LeaveRequestPayload {
         leaveSuccessors = successors ns
       , leavePredecessors = predecessors ns
+      , leaveDoMigration = doMigration
                                            }
     responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close (fmap Right . sendRequestTo 5000 3 (\rid ->
         Request {
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index f544061..399ddfd 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -276,12 +276,12 @@ fediChordVserverLeave ns = do
     -- former could be worked around
 
     -- send a leave message to all neighbours
-    forM_ (predecessors ns <> successors ns) $ liftIO . requestLeave ns
+    forM_ (predecessors ns <> successors ns) $ liftIO . requestLeave ns False
   where
     sendUntilSuccess i = maybe
                      (pure $ Left "Exhausted all successors")
                      (\neighb -> do
-                         leaveResponse <- requestLeave ns neighb
+                         leaveResponse <- requestLeave ns True neighb
                          case leaveResponse of
                            Left _  -> sendUntilSuccess (i+1)
                            -- return first successfully contacted neighbour,
diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs
index 37c00e9..86825a7 100644
--- a/src/Hash2Pub/ProtocolTypes.hs
+++ b/src/Hash2Pub/ProtocolTypes.hs
@@ -55,6 +55,7 @@ data ActionPayload = QueryIDRequestPayload
     | LeaveRequestPayload
     { leaveSuccessors   :: [RemoteNodeState]
     , leavePredecessors :: [RemoteNodeState]
+    , leaveDoMigration  :: Bool
     }
     | StabiliseRequestPayload
     | PingRequestPayload

From 969f6d7fc204111b7c5653fc4b064bfc489d0ad3 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 17 Aug 2020 13:39:22 +0200
Subject: [PATCH 050/112] fix tests

---
 test/FediChordSpec.hs | 1 +
 1 file changed, 1 insertion(+)

diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs
index ed1f3c8..6a3ca5d 100644
--- a/test/FediChordSpec.hs
+++ b/test/FediChordSpec.hs
@@ -189,6 +189,7 @@ spec = do
             lReqPayload = LeaveRequestPayload {
                 leaveSuccessors = someNodes
               , leavePredecessors = someNodes
+              , leaveDoMigration = True
                                               }
             stabReqPayload = StabiliseRequestPayload
             pingReqPayload = PingRequestPayload

From fce5ff9153ba0efc7494ca915626d93e69e83c33 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Tue, 18 Aug 2020 00:17:13 +0200
Subject: [PATCH 051/112] implement service data migration for stabilise

---
 src/Hash2Pub/DHTProtocol.hs |  5 ++---
 src/Hash2Pub/FediChord.hs   | 30 ++++++++++++++++++++++++++----
 2 files changed, 28 insertions(+), 7 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index 972059f..bd7953f 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -381,7 +381,7 @@ respondLeave nsSTM msgSet = do
         pure leaveResponse
     -- if awaiting an incoming service data migration, collect the lock without blocking this thread
     when (maybe False leaveDoMigration (payload  aRequestPart)) $ do
-        ownService <- atomically $ nodeService <$> ((readTVar nsSTM) >>= (readTVar . parentRealNode))
+        ownService <- atomically $ nodeService <$> (readTVar nsSTM >>= (readTVar . parentRealNode))
         void (forkIO $ waitForMigrationFrom ownService leaveSenderID)
     pure $ serialiseMessage sendMessageSize responseMsg
 
@@ -425,8 +425,7 @@ respondPing nsSTM msgSet = do
                                 }
     pure $ serialiseMessage sendMessageSize pingResponse
 
--- this modifies node state, so locking and IO seems to be necessary.
--- Still try to keep as much code as possible pure
+
 respondJoin :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
 respondJoin nsSTM msgSet = do
     -- atomically read and modify the node state according to the parsed request
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 399ddfd..15563de 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -465,9 +465,9 @@ checkCacheSliceInvariants ns
 -- | Periodically send @StabiliseRequest' s to the closest neighbour nodes, until
 -- one responds, and get their neighbours for maintaining the own neighbour lists.
 -- If necessary, request new neighbours.
-stabiliseThread :: LocalNodeStateSTM s -> IO ()
+stabiliseThread :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> IO ()
 stabiliseThread nsSTM = forever $ do
-    ns <- readTVarIO nsSTM
+    oldNs <- readTVarIO nsSTM
 
     putStrLn "stabilise run: begin"
 
@@ -478,8 +478,8 @@ stabiliseThread nsSTM = forever $ do
 
     -- don't contact all neighbours unless the previous one failed/ Left ed
 
-    predStabilise <- stabiliseClosestResponder ns predecessors 1 []
-    succStabilise <- stabiliseClosestResponder ns predecessors 1 []
+    predStabilise <- stabiliseClosestResponder oldNs predecessors 1 []
+    succStabilise <- stabiliseClosestResponder oldNs predecessors 1 []
 
     let
         (predDeletes, predNeighbours) = either (const ([], [])) id predStabilise
@@ -518,6 +518,28 @@ stabiliseThread nsSTM = forever $ do
             writeTVar nsSTM $ addSuccessors [nextEntry] latestNs
                                                                      )
 
+    newNs <- readTVarIO nsSTM
+
+    let
+        oldPredecessor = headDef (toRemoteNodeState oldNs) $ predecessors oldNs
+        newPredecessor = headMay $ predecessors newNs
+    -- manage need for service data migration:
+    maybe (pure ()) (\newPredecessor' ->
+        when (
+            isJust newPredecessor
+            && oldPredecessor /= newPredecessor'
+        -- case: predecessor has changed in some way => own responsibility has changed in some way
+        -- case 1: new predecessor is further away => broader responsibility, but new pred needs to push the data
+        -- If this is due to a node leaving without transfering its data, try getting it from a redundant copy
+        -- case 2: new predecessor is closer, it takes some of our data but somehow didn't join on us => push data to it
+            && isInOwnResponsibilitySlice newPredecessor' oldNs) $ do
+                ownService <- nodeService <$> (liftIO . readTVarIO $ parentRealNode newNs)
+                migrationResult <- migrateData ownService (getNid newNs) (getNid oldPredecessor) (getNid newPredecessor') (getDomain newPredecessor', fromIntegral $ getServicePort newPredecessor')
+                -- TODO: deal with migration failure, e.g retry
+                pure ()
+                    )
+                    newPredecessor
+
     putStrLn "stabilise run: end"
     -- TODO: make delay configurable
     threadDelay (60 * 10^6)

From 2ee40a7f64c89433996db458a7571140b530a1fd Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 19 Aug 2020 15:49:39 +0200
Subject: [PATCH 052/112] start working on the experiment runner #59

---
 Hash2Pub.cabal    | 16 +++++++++++++++-
 app/Experiment.hs |  3 +++
 2 files changed, 18 insertions(+), 1 deletion(-)
 create mode 100644 app/Experiment.hs

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index 5ffff0d..2cc2d84 100644
--- a/Hash2Pub.cabal
+++ b/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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types
+  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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays
   ghc-options:         -Wall
 
 
@@ -93,6 +93,20 @@ executable Hash2Pub
 
   ghc-options:         -threaded
 
+executable Experiment
+  -- experiment runner
+  import: deps
+
+  build-depends: Hash2Pub
+
+  main-is: Experiment.hs
+
+  hs-source-dirs: app
+
+  default-language: Haskell2010
+
+  ghc-options: -threaded
+
 
 test-suite Hash2Pub-test
   -- Test dependencies.
diff --git a/app/Experiment.hs b/app/Experiment.hs
new file mode 100644
index 0000000..c7abbcb
--- /dev/null
+++ b/app/Experiment.hs
@@ -0,0 +1,3 @@
+module Main where
+
+main = putStrLn "This gives us ALL the insights!"

From 2548b6a507c249462c68a519285c79d17429c344 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 20 Aug 2020 11:49:23 +0200
Subject: [PATCH 053/112] automatically subscribe when publishing to a tag

---
 src/Hash2Pub/PostService.hs | 26 +++++++++++++++++++-------
 1 file changed, 19 insertions(+), 7 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index a871343..0eb6e00 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -17,7 +17,7 @@ import           Control.Concurrent.STM.TChan
 import           Control.Concurrent.STM.TQueue
 import           Control.Concurrent.STM.TVar
 import           Control.Exception             (Exception (..), try)
-import           Control.Monad                 (foldM, forM, forM_, forever)
+import           Control.Monad                 (foldM, forM, forM_, forever, when, void)
 import           Control.Monad.IO.Class        (liftIO)
 import           Control.Monad.STM
 import           Data.Bifunctor
@@ -150,7 +150,7 @@ placeholderPost = Txt.take 5120 . Txt.repeat $ 'O' -- size 5KiB
 -- ========= HTTP API and handlers =============
 
 type PostServiceAPI = "relay" :> "inbox" :> Capture "hashtag" Txt.Text :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
-                 -- delivery endpoint of newly published posts of the relay's instance
+                 -- delivery endpoint at responsible relay for delivering posts of $tag for distribution
                  :<|> "relay" :> "subscribers" :> Capture "senderID" Integer :> ReqBody '[PlainText] Txt.Text :> PostNoContent '[PlainText] Txt.Text
                  -- endpoint for delivering the subscriptions and outstanding queue
                  :<|> "post" :> Capture "postid" Txt.Text :> Get '[PlainText] Txt.Text
@@ -191,7 +191,7 @@ relayInbox serv tag posts = do
     if responsible
        then pure ()
        else
-        (throwError $ err410 { errBody = "Relay is not responsible for this tag"})
+        throwError $ err410 { errBody = "Relay is not responsible for this tag"}
     broadcastChan <- liftIO $ atomically $ getTagBroadcastChannel serv tag
     maybe
     -- if noone subscribed to the tag, nothing needs to be done
@@ -396,7 +396,8 @@ clientDeliverSubscriptions serv fromNode fromKey toKey (toHost, toPort) = do
           maybe (pure acc) (\x -> channelGetAll' chan (x:acc)) haveRead
 
 
--- | Subscribe the client to the given hashtag. On success it returns the given lease time.
+-- | Subscribe the client to the given hashtag. On success it returns the given lease time,
+-- but also records the subscription in its own data structure.
 clientSubscribeTo :: DHT d => PostService d -> Hashtag -> IO (Either String Integer)
 clientSubscribeTo serv tag = do
     lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag)
@@ -413,7 +414,9 @@ clientSubscribeTo serv tag = do
                       newRes <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
                       doSubscribe newRes False
                 Left err    -> pure . Left . show $ err
-                Right lease -> pure . Right $ lease
+                Right lease -> do
+                    atomically . modifyTVar' (ownSubscriptions serv) $ HMap.insert (genKeyID . Txt.unpack $ tag) (fromInteger lease)
+                    pure . Right $ lease
           )
           lookupResponse
 
@@ -435,7 +438,9 @@ clientUnsubscribeFrom serv tag = do
                       newRes <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
                       doUnsubscribe newRes False
                 Left err    -> pure . Left . show $ err
-                Right _ -> pure . Right $ ()
+                Right _ -> do
+                    atomically . modifyTVar' (ownSubscriptions serv) $ HMap.delete (genKeyID . Txt.unpack $ tag)
+                    pure . Right $ ()
           )
           lookupResponse
 
@@ -580,7 +585,14 @@ processIncomingPosts serv = forever $ do
               -- TODO: keep track of maximum retries
               _ <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
               atomically . writeTQueue (relayInQueue serv) $ (tag, pID, pContent)
-          Right yay -> putStrLn $ "Yay! " <> show yay
+          Right yay -> do
+              putStrLn $ "Yay! " <> show yay
+              -- idea for the experiment: each post publication makes the initial posting instance subscribe to all contained tags
+              now <- getPOSIXTime
+              subscriptionStatus <- HMap.lookup (genKeyID . Txt.unpack $ tag) <$> readTVarIO (ownSubscriptions serv)
+              -- if not yet subscribed or subscription expires within 2 minutes, (re)subscribe to tag
+              when (maybe False (\subLease -> now - subLease < 120) subscriptionStatus) $
+                  void $ clientSubscribeTo serv tag
 
 
 -- | process the pending fetch jobs of delivered post IDs: Delivered posts are tried to be fetched from their URI-ID

From 24088581fee3bc609f82811b380c961a4e0624e2 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 20 Aug 2020 15:58:35 +0200
Subject: [PATCH 054/112] bump nixpkgs revision

---
 default.nix | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/default.nix b/default.nix
index 4e77a05..cea4aa3 100644
--- a/default.nix
+++ b/default.nix
@@ -14,7 +14,7 @@ let
       name = "nixpkgs-pinned";
       url = https://github.com/NixOS/nixpkgs/;
       ref = "refs/heads/release-20.03";
-      rev = "076c67fdea6d0529a568c7d0e0a72e6bc161ecf5";
+      rev = "de3780b937d2984f9b5e20d191f23be4f857b3aa";
     }) {
       # Pass no config for purity
           config = {};

From 70145bc5446570bf245fb6a108612b7606073593 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 20 Aug 2020 15:58:35 +0200
Subject: [PATCH 055/112] bump nixpkgs revision

---
 default.nix | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/default.nix b/default.nix
index 4e77a05..cea4aa3 100644
--- a/default.nix
+++ b/default.nix
@@ -14,7 +14,7 @@ let
       name = "nixpkgs-pinned";
       url = https://github.com/NixOS/nixpkgs/;
       ref = "refs/heads/release-20.03";
-      rev = "076c67fdea6d0529a568c7d0e0a72e6bc161ecf5";
+      rev = "de3780b937d2984f9b5e20d191f23be4f857b3aa";
     }) {
       # Pass no config for purity
           config = {};

From 32734102cdbd23ca5e15d682f9c6b73ad7ac9018 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 20 Aug 2020 18:13:50 +0200
Subject: [PATCH 056/112] improve documentation of clientPublishPost

---
 src/Hash2Pub/PostService.hs | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 0eb6e00..2e107b6 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -450,11 +450,11 @@ clientUnsubscribeFrom serv tag = do
 -- the post to the responsible relays.
 -- As the initial publishing isn't done by a specific relay (but *to* a specific relay
 -- instead), the function does *not* take a PostService as argument.
-clientPublishPost :: HTTP.Manager   -- for better performance, a shared HTTP manager has to be provided
-                  -> String         -- hostname
-                  -> Int            -- port
-                  -> PostContent    -- post content
-                  -> IO (Either String ())  -- error or success
+clientPublishPost :: HTTP.Manager   -- ^ for better performance, a shared HTTP manager has to be provided
+                  -> String         -- ^ hostname
+                  -> Int            -- ^ port
+                  -> PostContent    -- ^ post content
+                  -> IO (Either String ())  -- ^ error or success
 clientPublishPost httpman hostname port postC = do
     resp <- runClientM (postInboxClient postC) (mkClientEnv httpman (BaseUrl Http hostname port ""))
     pure . bimap show (const ()) $ resp

From f330ff1070580d042d1bc15e52be3fac4f59c601 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 20 Aug 2020 18:14:23 +0200
Subject: [PATCH 057/112] successful post publishing with MonadState and random
 relay selection

---
 app/Experiment.hs | 43 ++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 42 insertions(+), 1 deletion(-)

diff --git a/app/Experiment.hs b/app/Experiment.hs
index c7abbcb..51b8e88 100644
--- a/app/Experiment.hs
+++ b/app/Experiment.hs
@@ -1,3 +1,44 @@
+{-# LANGUAGE OverloadedStrings     #-}
+
 module Main where
 
-main = putStrLn "This gives us ALL the insights!"
+import System.Random
+import Control.Concurrent
+import Control.Monad (forM_)
+import Control.Monad.State.Class
+import Control.Monad.State.Strict (evalStateT)
+import Control.Monad.IO.Class
+import qualified Network.HTTP.Client           as HTTP
+
+import Hash2Pub.PostService     (clientPublishPost, Hashtag)
+
+-- placeholder post data definition
+
+tagsToPostTo = [ "JustSomeTag", "WantAnotherTag234", "HereWeGoAgain", "Oyä", "通信端末" ]
+
+knownRelays :: [(String, Int)]
+knownRelays =
+  [ ("animalliberation.social", 3342)
+  , ("hostux.social", 3343)
+  , ("social.diskseven.com", 3344)
+  , ("social.imirhil.fr", 3345)
+  ]
+
+main :: IO ()
+main = do
+    -- initialise HTTP manager
+    httpMan <- HTTP.newManager HTTP.defaultManagerSettings
+    -- initialise RNG
+    let initRGen = mkStdGen 12
+    -- cycle through tags and post to a random instance
+    evalStateT (forM_ (cycle tagsToPostTo) $ publishPostRandom httpMan) initRGen
+    -- wait for a specified time
+
+publishPostRandom :: (RandomGen g, MonadIO m, MonadState g m) => HTTP.Manager -> Hashtag -> m ()
+publishPostRandom httpman tag = do
+    index <- state $ randomR (0, length knownRelays - 1)
+    let (pubHost, pubPort) = knownRelays !! index
+    _ <- liftIO . forkIO $ do
+        postResult <- liftIO $ clientPublishPost httpman pubHost pubPort ("foobar #" <> tag)
+        either putStrLn (const $ pure ()) postResult
+    liftIO $ threadDelay 500

From 5511026c8deef79bc8dd5c3377ffd191c6742cea Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 21 Aug 2020 14:40:29 +0200
Subject: [PATCH 058/112] reduce logging verbosity

---
 src/Hash2Pub/DHTProtocol.hs | 3 ---
 src/Hash2Pub/FediChord.hs   | 2 +-
 src/Hash2Pub/PostService.hs | 4 ++--
 3 files changed, 3 insertions(+), 6 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index bd7953f..033f248 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -259,7 +259,6 @@ handleIncomingRequest :: Service s (RealNodeSTM s)
                       -> SockAddr                           -- ^ source address of the request
                       -> IO ()
 handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do
-    putStrLn $ "handling incoming request: " <> show msgSet
     ns <- readTVarIO nsSTM
     -- add nodestate to cache
     now <- getPOSIXTime
@@ -314,7 +313,6 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do
 -- | execute a key ID lookup on local cache and respond with the result
 respondQueryID :: LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)
 respondQueryID nsSTM msgSet = do
-    putStrLn "responding to a QueryID request"
     -- this message cannot be split reasonably, so just
     -- consider the first payload
     let
@@ -749,7 +747,6 @@ sendRequestTo timeoutMillis numAttempts msgIncomplete sock = do
     let
         msgComplete = msgIncomplete randomID
         requests = serialiseMessage sendMessageSize msgComplete
-    putStrLn $ "sending request message " <> show msgComplete
     -- create a queue for passing received response messages back, even after a timeout
     responseQ <- newTBQueueIO $ 2*maximumParts  -- keep room for duplicate packets
     -- start sendAndAck with timeout
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 15563de..2116ca9 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -716,7 +716,7 @@ fediMessageHandler sendQ recvQ nsSTM = do
 
 instance DHT (RealNodeSTM s) where
     lookupKey nodeSTM keystring = getKeyResponsibility nodeSTM $ genKeyID keystring
-    forceLookupKey nodeSTM keystring = updateLookupCache nodeSTM $ genKeyID keystring
+    forceLookupKey nodeSTM keystring = (putStrLn $ "forced responsibility lookup of #" <> keystring) >> (updateLookupCache nodeSTM $ genKeyID keystring)
     -- potential better implementation: put all neighbours of all vservers and the vservers on a ringMap, look the key up and see whether it results in a LocalNodeState
     isResponsibleFor nodeSTM key = do
         node <- readTVarIO nodeSTM
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 2e107b6..348c9a1 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -585,8 +585,8 @@ processIncomingPosts serv = forever $ do
               -- TODO: keep track of maximum retries
               _ <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
               atomically . writeTQueue (relayInQueue serv) $ (tag, pID, pContent)
-          Right yay -> do
-              putStrLn $ "Yay! " <> show yay
+          Right _ -> do
+              -- TODO: stats
               -- idea for the experiment: each post publication makes the initial posting instance subscribe to all contained tags
               now <- getPOSIXTime
               subscriptionStatus <- HMap.lookup (genKeyID . Txt.unpack $ tag) <$> readTVarIO (ownSubscriptions serv)

From 75c1932ef67a38adbeaa0c9c32172b080c0b78fa Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 21 Aug 2020 23:47:42 +0200
Subject: [PATCH 059/112] send fetchable post URIs as ID

---
 src/Hash2Pub/PostService.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 348c9a1..c7300db 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -571,12 +571,13 @@ processIncomingPosts serv = forever $ do
     -- blocks until available
     -- TODO: process multiple in parallel
     (tag, pID, pContent) <- atomically . readTQueue $ relayInQueue serv
+    let pIdUri = "http://" <> (Txt.pack . confServiceHost . serviceConf $ serv) <> ":" <> (fromString . show . confServicePort . serviceConf $ serv) <> "/post/" <> pID
     lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag)
     case lookupRes of
       -- no vserver active => wait and retry
       Nothing -> threadDelay $ 10 * 10^6
       Just (responsibleHost, responsiblePort) -> do
-        resp <- runClientM (relayInboxClient tag $ pID <> "," <> pContent) (mkClientEnv (httpMan serv) (BaseUrl Http responsibleHost (fromIntegral responsiblePort) ""))
+        resp <- runClientM (relayInboxClient tag $ pIdUri <> "," <> pContent) (mkClientEnv (httpMan serv) (BaseUrl Http responsibleHost (fromIntegral responsiblePort) ""))
         case resp of
           Left err  -> do
               putStrLn $ "Error: " <> show err

From c3b1aad1c76f54ef471d5edfed57abb2f6e8fd2b Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 21 Aug 2020 23:55:20 +0200
Subject: [PATCH 060/112] abstract away the hashtag -> NodeID conversion

---
 src/Hash2Pub/PostService.hs | 29 +++++++++++++++++------------
 1 file changed, 17 insertions(+), 12 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index c7300db..fe013a0 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -187,7 +187,7 @@ relayInbox serv tag posts = do
     -- skip checking whether the post actually contains the tag, just drop full post
         postIDs = head . Txt.splitOn "," <$> Txt.lines posts
     -- if tag is not in own responsibility, return a 410 Gone
-    responsible <- liftIO $ isResponsibleFor (baseDHT serv) (genKeyID . Txt.unpack $ tag)
+    responsible <- liftIO $ isResponsibleFor (baseDHT serv) (hashtagToId tag)
     if responsible
        then pure ()
        else
@@ -221,7 +221,7 @@ subscriptionDelivery serv senderID subList = do
     -- not-handled tag occurs, this results in a single large transaction.
     -- Hopefully the performance isn't too bad.
     res <- liftIO . atomically $ (foldM (\_ tag' -> do
-        responsible <- isResponsibleForSTM (baseDHT serv) (genKeyID . Txt.unpack $ tag')
+        responsible <- isResponsibleForSTM (baseDHT serv) (hashtagToId tag')
         if responsible
            then processTag (subscribers serv) tag'
            else throwSTM $ UnhandledTagException (Txt.unpack tag' <> " not handled by this relay")
@@ -295,7 +295,7 @@ tagDelivery :: PostService d -> Txt.Text -> Txt.Text -> Handler Txt.Text
 tagDelivery serv hashtag posts = do
     let postIDs = Txt.lines posts
     subscriptions <- liftIO . readTVarIO . ownSubscriptions $ serv
-    if isJust (HMap.lookup (genKeyID . Txt.unpack $ hashtag) subscriptions)
+    if isJust (HMap.lookup (hashtagToId hashtag) subscriptions)
        then -- TODO: increase a counter/ statistics for received posts of this tag
             liftIO $ forM_ postIDs $ atomically . writeTQueue (postFetchQueue serv)
         else -- silently drop posts from unsubscribed tags
@@ -304,7 +304,7 @@ tagDelivery serv hashtag posts = do
 
 tagSubscribe :: DHT d => PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Integer
 tagSubscribe serv hashtag origin = do
-    responsible <- liftIO $ isResponsibleFor (baseDHT serv) (genKeyID . Txt.unpack $ hashtag)
+    responsible <- liftIO $ isResponsibleFor (baseDHT serv) (hashtagToId hashtag)
     if not responsible
        -- GONE if not responsible
        then throwError err410 { errBody = "not responsible for this tag" }
@@ -323,7 +323,7 @@ tagSubscribe serv hashtag origin = do
 
 tagUnsubscribe :: DHT d => PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Text
 tagUnsubscribe serv hashtag origin = do
-    responsible <- liftIO $ isResponsibleFor (baseDHT serv) (genKeyID . Txt.unpack $ hashtag)
+    responsible <- liftIO $ isResponsibleFor (baseDHT serv) (hashtagToId hashtag)
     if not responsible
        -- GONE if not responsible
        then throwError err410 { errBody = "not responsible for this tag" }
@@ -385,7 +385,7 @@ clientDeliverSubscriptions serv fromNode fromKey toKey (toHost, toPort) = do
       Right _ -> do
           atomically $
               modifyTVar' (subscribers serv) $ \tagMap ->
-                  foldr deleteRMapEntry tagMap ((\(_, _, t) -> genKeyID . Txt.unpack $ t) <$> intervalTags)
+                  foldr deleteRMapEntry tagMap ((\(_, _, t) -> hashtagToId t) <$> intervalTags)
           pure . Right $ ()
   where
       channelGetAll :: TChan a -> STM [a]
@@ -415,7 +415,7 @@ clientSubscribeTo serv tag = do
                       doSubscribe newRes False
                 Left err    -> pure . Left . show $ err
                 Right lease -> do
-                    atomically . modifyTVar' (ownSubscriptions serv) $ HMap.insert (genKeyID . Txt.unpack $ tag) (fromInteger lease)
+                    atomically . modifyTVar' (ownSubscriptions serv) $ HMap.insert (hashtagToId tag) (fromInteger lease)
                     pure . Right $ lease
           )
           lookupResponse
@@ -439,7 +439,7 @@ clientUnsubscribeFrom serv tag = do
                       doUnsubscribe newRes False
                 Left err    -> pure . Left . show $ err
                 Right _ -> do
-                    atomically . modifyTVar' (ownSubscriptions serv) $ HMap.delete (genKeyID . Txt.unpack $ tag)
+                    atomically . modifyTVar' (ownSubscriptions serv) $ HMap.delete (hashtagToId tag)
                     pure . Right $ ()
           )
           lookupResponse
@@ -497,7 +497,7 @@ setupSubscriberChannel tagMapSTM tag subscriber leaseTime = do
         broadcastChan <- newBroadcastTChan
         tagOutChan <- dupTChan broadcastChan
         newSubMapSTM <- newTVar $ HMap.singleton subscriber (tagOutChan, leaseTime)
-        writeTVar tagMapSTM $ addRMapEntry (genKeyID . Txt.unpack $ tag) (newSubMapSTM, broadcastChan, tag) tagMap
+        writeTVar tagMapSTM $ addRMapEntry (hashtagToId tag) (newSubMapSTM, broadcastChan, tag) tagMap
         pure tagOutChan
       Just (foundSubMapSTM, broadcastChan, _) -> do
         -- otherwise use the existing subscriber map
@@ -525,7 +525,7 @@ deleteSubscription tagMapSTM tag subscriber = do
           -- if there are no subscriptions for the tag anymore, remove its
           -- data sttructure altogether
           if HMap.null newSubMap
-             then writeTVar tagMapSTM $ deleteRMapEntry (genKeyID . Txt.unpack $ tag) tagMap
+             then writeTVar tagMapSTM $ deleteRMapEntry (hashtagToId tag) tagMap
           -- otherwise just remove the subscription of that node
              else writeTVar foundSubMapSTM newSubMap
 
@@ -546,13 +546,18 @@ getTagBroadcastChannel serv tag = do
 
 -- | look up the subscription data of a tag
 lookupTagSubscriptions :: Hashtag -> RingMap NodeID a -> Maybe a
-lookupTagSubscriptions tag = rMapLookup (genKeyID . Txt.unpack $ tag)
+lookupTagSubscriptions tag = rMapLookup (hashtagToId tag)
 
 
 -- normalise the unicode representation of a string to NFC
 normaliseTag :: Txt.Text -> Txt.Text
 normaliseTag = Txt.fromStrict . normalize NFC . Txt.toStrict
 
+
+-- | convert a hashtag to its representation on the DHT
+hashtagToId :: Hashtag -> NodeID
+hashtagToId = genKeyID . Txt.unpack
+
 -- | define how to convert all showable types to PlainText
 -- No idea what I'm doing with these overlappable instances though ¯\_(ツ)_/¯
 -- TODO: figure out how this overlapping stuff actually works https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#instance-overlap
@@ -590,7 +595,7 @@ processIncomingPosts serv = forever $ do
               -- TODO: stats
               -- idea for the experiment: each post publication makes the initial posting instance subscribe to all contained tags
               now <- getPOSIXTime
-              subscriptionStatus <- HMap.lookup (genKeyID . Txt.unpack $ tag) <$> readTVarIO (ownSubscriptions serv)
+              subscriptionStatus <- HMap.lookup (hashtagToId tag) <$> readTVarIO (ownSubscriptions serv)
               -- if not yet subscribed or subscription expires within 2 minutes, (re)subscribe to tag
               when (maybe False (\subLease -> now - subLease < 120) subscriptionStatus) $
                   void $ clientSubscribeTo serv tag

From 2b418189a61137ec29dfa8bc1657b95f4f93d47f Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sun, 23 Aug 2020 12:06:26 +0200
Subject: [PATCH 061/112] use hard-coded defaults for DHT request timeout and
 retries

---
 src/Hash2Pub/DHTProtocol.hs | 29 ++++++++++++++++++-----------
 src/Hash2Pub/FediChord.hs   |  2 +-
 2 files changed, 19 insertions(+), 12 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index 033f248..a194dbb 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -490,7 +490,7 @@ requestJoin toJoinOn ownStateSTM = do
     srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ownState)
     bracket (mkSendSocket srcAddr (getDomain toJoinOn) (getDhtPort toJoinOn)) close (\sock -> do
         -- extract own state for getting request information
-        responses <- sendRequestTo 5000 3 (\rid -> Request rid (toRemoteNodeState ownState) 1 True Join (Just JoinRequestPayload)) sock
+        responses <- sendRequestTo (\rid -> Request rid (toRemoteNodeState ownState) 1 True Join (Just JoinRequestPayload)) sock
         (cacheInsertQ, joinedState) <- atomically $ do
             stateSnap <- readTVar ownStateSTM
             let
@@ -586,7 +586,7 @@ sendQueryIdMessages targetID ns lParam targets = do
           srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
           -- ToDo: make attempts and timeout configurable
           queryThreads <- mapM (\resultNode -> async $ bracket (mkSendSocket srcAddr (getDomain resultNode) (getDhtPort resultNode)) close (
-              sendRequestTo 5000 3 (lookupMessage targetID ns Nothing)
+              sendRequestTo (lookupMessage targetID ns Nothing)
                                                                                                                                    )) targets
           -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613
           -- ToDo: exception handling, maybe log them
@@ -628,7 +628,7 @@ requestStabilise :: LocalNodeState s      -- ^ sending node
                  -> IO (Either String ([RemoteNodeState], [RemoteNodeState]))   -- ^ (predecessors, successors) of responding node
 requestStabilise ns neighbour = do
     srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
-    responses <- bracket (mkSendSocket srcAddr (getDomain neighbour) (getDhtPort neighbour)) close (fmap Right . sendRequestTo 5000 3 (\rid ->
+    responses <- bracket (mkSendSocket srcAddr (getDomain neighbour) (getDhtPort neighbour)) close (fmap Right . sendRequestTo (\rid ->
         Request {
             requestID = rid
           , sender = toRemoteNodeState ns
@@ -672,7 +672,7 @@ requestLeave ns doMigration target = do
       , leavePredecessors = predecessors ns
       , leaveDoMigration = doMigration
                                            }
-    responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close (fmap Right . sendRequestTo 5000 3 (\rid ->
+    responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close (fmap Right . sendRequestTo (\rid ->
         Request {
             requestID = rid
           , sender = toRemoteNodeState ns
@@ -697,7 +697,7 @@ requestPing ns target = do
     srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
     responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close
         (\sock -> do
-            resp <- sendRequestTo 5000 3 (\rid ->
+            resp <- sendRequestTo (\rid ->
                 Request {
                     requestID = rid
                   , sender = toRemoteNodeState ns
@@ -733,15 +733,22 @@ requestPing ns target = do
         ) responses
 
 
+-- | 'sendRequestToWithParams' with default timeout and retries already specified.
+-- Generic function for sending a request over a connected socket and collecting the response.
+-- Serialises the message and tries to deliver its parts for a number of attempts within a default timeout.
+sendRequestTo :: (Integer -> FediChordMessage)       -- ^ the message to be sent, still needing a requestID
+              -> Socket                 -- ^ connected socket to use for sending
+              -> IO (Set.Set FediChordMessage)  -- ^ responses
+sendRequestTo = sendRequestToWithParams 5000 3
 
 -- | Generic function for sending a request over a connected socket and collecting the response.
 -- Serialises the message and tries to deliver its parts for a number of attempts within a specified timeout.
-sendRequestTo :: Int                    -- ^ timeout in seconds
-              -> Int                    -- ^ number of retries
-              -> (Integer -> FediChordMessage)       -- ^ the message to be sent, still needing a requestID
-              -> Socket                 -- ^ connected socket to use for sending
-              -> IO (Set.Set FediChordMessage)  -- ^ responses
-sendRequestTo timeoutMillis numAttempts msgIncomplete sock = do
+sendRequestToWithParams :: Int                    -- ^ timeout in seconds
+                        -> Int                    -- ^ number of retries
+                        -> (Integer -> FediChordMessage)       -- ^ the message to be sent, still needing a requestID
+                        -> Socket                 -- ^ connected socket to use for sending
+                        -> IO (Set.Set FediChordMessage)  -- ^ responses
+sendRequestToWithParams timeoutMillis numAttempts msgIncomplete sock = do
     -- give the message a random request ID
     randomID <- randomRIO (0, 2^32-1)
     let
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 2116ca9..54c5e9a 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -225,7 +225,7 @@ bootstrapQueryId nsSTM (bootstrapHost, bootstrapPort) targetID = do
     srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
     bootstrapResponse <- bracket (mkSendSocket srcAddr bootstrapHost bootstrapPort) close (
         -- Initialise an empty cache only with the responses from a bootstrapping node
-        fmap Right . sendRequestTo 5000 3 (lookupMessage targetID ns Nothing)
+        fmap Right . sendRequestTo (lookupMessage targetID ns Nothing)
                                                                                   )
        `catch` (\e -> pure . Left $ "Error at bootstrap QueryId: " <> displayException (e :: IOException))
 

From cd8ea0760007602e58e3d4b6aff253fec5d235a9 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sun, 23 Aug 2020 13:04:58 +0200
Subject: [PATCH 062/112] bugfix: make unjoined nodes consider all IDs to be
 their responsibility

---
 src/Hash2Pub/DHTProtocol.hs | 7 +++----
 1 file changed, 3 insertions(+), 4 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index a194dbb..69995bd 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -106,9 +106,6 @@ queryLocalCache ownState nCache lBestNodes targetID
     -- the closest succeeding node (like with the p initiated parallel queries
       | otherwise = FORWARD $ closestSuccessor `Set.union` closestCachePredecessors (lBestNodes-1) targetID nCache
   where
-    ownID = getNid ownState
-    preds = predecessors ownState
-
     closestSuccessor :: Set.Set RemoteCacheEntry
     closestSuccessor = maybe Set.empty (Set.singleton . toRemoteCacheEntry) $ cacheLookupSucc targetID nCache
 
@@ -433,7 +430,9 @@ respondJoin nsSTM msgSet = do
         let
             aRequestPart = Set.elemAt 0 msgSet
             senderNS = sender aRequestPart
-            responsibilityLookup = queryLocalCache nsSnap cache 1 (getNid senderNS)
+            -- if not joined yet, attract responsibility for
+            -- all keys to make bootstrapping possible
+            responsibilityLookup = if isJoined nsSnap then queryLocalCache nsSnap cache 1 (getNid senderNS) else FOUND (toRemoteNodeState nsSnap)
             thisNodeResponsible (FOUND _)   = True
             thisNodeResponsible (FORWARD _) = False
         -- check whether the joining node falls into our responsibility

From 4ba592d8a2495d845a8af25a8ad44b95b3e00072 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sun, 23 Aug 2020 15:21:24 +0200
Subject: [PATCH 063/112] bugfix: DHT request timeout unit is milliseconds

---
 src/Hash2Pub/DHTProtocol.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index 69995bd..b309b39 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -756,7 +756,7 @@ sendRequestToWithParams timeoutMillis numAttempts msgIncomplete sock = do
     -- create a queue for passing received response messages back, even after a timeout
     responseQ <- newTBQueueIO $ 2*maximumParts  -- keep room for duplicate packets
     -- start sendAndAck with timeout
-    attempts numAttempts . timeout timeoutMillis $ sendAndAck responseQ sock requests
+    attempts numAttempts . timeout (timeoutMillis*1000) $ sendAndAck responseQ sock requests
     -- after timeout, check received responses, delete them from unacked message set/ map and rerun senAndAck with that if necessary.
     recvdParts <- atomically $ flushTBQueue responseQ
     pure $ Set.fromList recvdParts

From 3bd4cb667db2ee4c94c2537e958cfd29e6819f72 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 24 Aug 2020 10:02:45 +0200
Subject: [PATCH 064/112] explicitly pass socket in send-receive-loop

---
 src/Hash2Pub/DHTProtocol.hs | 17 +++++++++--------
 1 file changed, 9 insertions(+), 8 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index b309b39..e22834a 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -742,7 +742,7 @@ sendRequestTo = sendRequestToWithParams 5000 3
 
 -- | Generic function for sending a request over a connected socket and collecting the response.
 -- Serialises the message and tries to deliver its parts for a number of attempts within a specified timeout.
-sendRequestToWithParams :: Int                    -- ^ timeout in seconds
+sendRequestToWithParams :: Int                    -- ^ timeout in milliseconds
                         -> Int                    -- ^ number of retries
                         -> (Integer -> FediChordMessage)       -- ^ the message to be sent, still needing a requestID
                         -> Socket                 -- ^ connected socket to use for sending
@@ -765,19 +765,20 @@ sendRequestToWithParams timeoutMillis numAttempts msgIncomplete sock = do
                -> Socket                            -- ^ the socket used for sending and receiving for this particular remote node
                -> Map.Map Integer BS.ByteString     -- ^ the remaining unacked request parts
                -> IO ()
-    sendAndAck responseQueue sock remainingSends = do
+    sendAndAck responseQueue sock' remainingSends = do
         sendMany sock $ Map.elems remainingSends
         -- if all requests have been acked/ responded to, return prematurely
-        recvLoop responseQueue remainingSends Set.empty Nothing
-    recvLoop :: TBQueue FediChordMessage          -- ^ the queue for putting in the received responses
+        recvLoop sock' responseQueue remainingSends Set.empty Nothing
+    recvLoop :: Socket
+             -> TBQueue FediChordMessage          -- ^ the queue for putting in the received responses
              -> Map.Map Integer BS.ByteString       -- ^ the remaining unacked request parts
              -> Set.Set Integer                     -- ^ already received response part numbers
                -> Maybe Integer                     -- ^ total number of response parts if already known
              -> IO ()
-    recvLoop responseQueue remainingSends' receivedPartNums totalParts = do
+    recvLoop sock' responseQueue remainingSends' receivedPartNums totalParts = do
         -- 65535 is maximum length of UDP packets, as long as
         -- no IPv6 jumbograms are used
-        response <- deserialiseMessage <$> recv sock 65535
+        response <- deserialiseMessage <$> recv sock' 65535
         case response of
           Right msg@Response{} -> do
               atomically $ writeTBQueue responseQueue msg
@@ -787,9 +788,9 @@ sendRequestToWithParams timeoutMillis numAttempts msgIncomplete sock = do
                 newReceivedParts = Set.insert (part msg) receivedPartNums
               if Map.null newRemaining && maybe False (\p -> Set.size receivedPartNums == fromIntegral p) newTotalParts
                  then pure ()
-                 else recvLoop responseQueue newRemaining receivedPartNums newTotalParts
+                 else recvLoop sock' responseQueue newRemaining receivedPartNums newTotalParts
           -- drop errors and invalid messages
-          Left _ -> recvLoop responseQueue remainingSends' receivedPartNums totalParts
+          Left _ -> recvLoop sock' responseQueue remainingSends' receivedPartNums totalParts
 
 
 -- | enqueue a list of RemoteCacheEntries to be added to the global NodeCache

From 6c5e40f8ad78cc9019a9001cdb2a522180eaa0bd Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 24 Aug 2020 15:28:06 +0200
Subject: [PATCH 065/112] fix wrong passing of arguments in receive-loop part
 checking

---
 src/Hash2Pub/DHTProtocol.hs | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index e22834a..fac5a3f 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -766,14 +766,14 @@ sendRequestToWithParams timeoutMillis numAttempts msgIncomplete sock = do
                -> Map.Map Integer BS.ByteString     -- ^ the remaining unacked request parts
                -> IO ()
     sendAndAck responseQueue sock' remainingSends = do
-        sendMany sock $ Map.elems remainingSends
+        sendMany sock' $ Map.elems remainingSends
         -- if all requests have been acked/ responded to, return prematurely
         recvLoop sock' responseQueue remainingSends Set.empty Nothing
     recvLoop :: Socket
              -> TBQueue FediChordMessage          -- ^ the queue for putting in the received responses
              -> Map.Map Integer BS.ByteString       -- ^ the remaining unacked request parts
              -> Set.Set Integer                     -- ^ already received response part numbers
-               -> Maybe Integer                     -- ^ total number of response parts if already known
+             -> Maybe Integer                     -- ^ total number of response parts if already known
              -> IO ()
     recvLoop sock' responseQueue remainingSends' receivedPartNums totalParts = do
         -- 65535 is maximum length of UDP packets, as long as
@@ -786,10 +786,11 @@ sendRequestToWithParams timeoutMillis numAttempts msgIncomplete sock = do
                 newTotalParts = if isFinalPart msg then Just (part msg) else totalParts
                 newRemaining = Map.delete (part msg) remainingSends'
                 newReceivedParts = Set.insert (part msg) receivedPartNums
-              if Map.null newRemaining && maybe False (\p -> Set.size receivedPartNums == fromIntegral p) newTotalParts
+              if  Map.null newRemaining && maybe False (\p -> Set.size newReceivedParts == fromIntegral p) newTotalParts
                  then pure ()
-                 else recvLoop sock' responseQueue newRemaining receivedPartNums newTotalParts
+                 else recvLoop sock' responseQueue newRemaining newReceivedParts newTotalParts
           -- drop errors and invalid messages
+          Right Request{} -> pure ()    -- expecting a response, not a request
           Left _ -> recvLoop sock' responseQueue remainingSends' receivedPartNums totalParts
 
 

From b23201a49c1915ec573a443040cbd30e977f3cda Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Tue, 25 Aug 2020 12:51:33 +0200
Subject: [PATCH 066/112] Make key lookups fail after request exhaustion
 instead of providing default

Returning the own node as a default does not make sense in all contexts:
Especially for bootstrap joining this can be harmful, so signalling
instead that the lookup failed makes distinguishing on a case by case
basis possible.

Also contributes to #57
---
 src/Hash2Pub/DHTProtocol.hs | 17 +++++----
 src/Hash2Pub/FediChord.hs   | 72 ++++++++++++++++++++++---------------
 2 files changed, 53 insertions(+), 36 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index fac5a3f..1cce94d 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -49,6 +49,8 @@ import           Control.Concurrent.STM.TQueue
 import           Control.Concurrent.STM.TVar
 import           Control.Exception
 import           Control.Monad                  (foldM, forM, forM_, void, when)
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Except (MonadError(..), runExceptT)
 import qualified Data.ByteString                as BS
 import           Data.Either                    (rights)
 import           Data.Foldable                  (foldl', foldr')
@@ -533,9 +535,10 @@ requestJoin toJoinOn ownStateSTM = do
 
 
 -- | Send a 'QueryID' 'Request' for getting the node that handles a certain key ID.
-requestQueryID :: LocalNodeState s        -- ^ NodeState of the querying node
+requestQueryID :: (MonadIO m, MonadError String m)
+               => LocalNodeState s        -- ^ NodeState of the querying node
                -> NodeID                -- ^ target key ID to look up
-               -> IO RemoteNodeState    -- ^ the node responsible for handling that key
+               -> m RemoteNodeState    -- ^ the node responsible for handling that key
 -- 1. do a local lookup for the l closest nodes
 -- 2. create l sockets
 -- 3. send a message async concurrently to all l nodes
@@ -543,23 +546,23 @@ requestQueryID :: LocalNodeState s        -- ^ NodeState of the querying node
 -- 5. repeat until FOUND (problem: new entries not necessarily already in cache, explicitly compare with closer results)
 -- TODO: deal with lookup failures
 requestQueryID ns targetID = do
-    firstCacheSnapshot <- readTVarIO . nodeCacheSTM $ ns
+    firstCacheSnapshot <- liftIO . readTVarIO . nodeCacheSTM $ ns
     -- TODO: make maxAttempts configurable
     queryIdLookupLoop firstCacheSnapshot ns 50 targetID
 
 -- | like 'requestQueryID, but allows passing of a custom cache, e.g. for joining
-queryIdLookupLoop :: NodeCache -> LocalNodeState s -> Int -> NodeID -> IO RemoteNodeState
+queryIdLookupLoop :: (MonadIO m, MonadError String m) => NodeCache -> LocalNodeState s -> Int -> NodeID -> m RemoteNodeState
 -- return node itself as default fallback value against infinite recursion.
 -- TODO: consider using an Either instead of a default value
-queryIdLookupLoop _ ns 0 _ = pure $ toRemoteNodeState ns
+queryIdLookupLoop _ ns 0 _ = throwError "exhausted maximum lookup attempts"
 queryIdLookupLoop cacheSnapshot ns maxAttempts targetID = do
     let localResult = queryLocalCache ns cacheSnapshot (lNumBestNodes ns) targetID
     -- FOUND can only be returned if targetID is owned by local node
     case localResult of
       FOUND thisNode -> pure thisNode
       FORWARD nodeSet -> do
-          responseEntries <- sendQueryIdMessages targetID ns Nothing (remoteNode <$> Set.elems nodeSet)
-          now <- getPOSIXTime
+          responseEntries <- liftIO $ sendQueryIdMessages targetID ns Nothing (remoteNode <$> Set.elems nodeSet)
+          now <- liftIO getPOSIXTime
           -- check for a FOUND and return it
           case responseEntries of
             FOUND foundNode -> pure foundNode
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 54c5e9a..15cee10 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -166,6 +166,7 @@ fediChordBootstrapJoin nsSTM bootstrapNode = do
         currentlyResponsible <- liftEither lookupResp
         liftIO . putStrLn $ "Trying to join on " <> show (getNid currentlyResponsible)
         -- 2. then send a join to the currently responsible node
+        liftIO $ putStrLn "send a bootstrap Join"
         joinResult <- liftIO $ requestJoin currentlyResponsible nsSTM
         liftEither joinResult
 
@@ -244,26 +245,24 @@ bootstrapQueryId nsSTM (bootstrapHost, bootstrapPort) targetID = do
                            Just (FORWARD resultset) -> foldr' (addCacheEntryPure now) cacheAcc resultset
                               )
                            initCache resp
-               currentlyResponsible <- queryIdLookupLoop bootstrapCache ns 50 $ getNid ns
-               pure $ Right currentlyResponsible
+               currentlyResponsible <- runExceptT $ queryIdLookupLoop bootstrapCache ns 50 $ getNid ns
+               pure currentlyResponsible
 
 
 -- | join a node to the DHT using the global node cache
 -- node's position.
-fediChordVserverJoin :: Service s (RealNodeSTM s)
+fediChordVserverJoin :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s))
                      => LocalNodeStateSTM s                    -- ^ the local 'NodeState'
-                     -> IO (Either String (LocalNodeStateSTM s))  -- ^ the joined 'NodeState' after a
+                     -> m (LocalNodeStateSTM s)  -- ^ the joined 'NodeState' after a
                                                     -- successful join, otherwise an error message
 fediChordVserverJoin nsSTM = do
-    ns <- readTVarIO nsSTM
+    ns <- liftIO $ readTVarIO nsSTM
     -- 1. get routed to the currently responsible node
     currentlyResponsible <- requestQueryID ns $ getNid ns
-    putStrLn $ "Trying to join on " <> show (getNid currentlyResponsible)
+    liftIO . putStrLn $ "Trying to join on " <> show (getNid currentlyResponsible)
     -- 2. then send a join to the currently responsible node
-    joinResult <- requestJoin currentlyResponsible nsSTM
-    case joinResult of
-      Left err       -> pure . Left $ "Error joining on " <> err
-      Right joinedNS -> pure . Right $ joinedNS
+    joinResult <- liftIO $ requestJoin currentlyResponsible nsSTM
+    liftEither joinResult
 
 fediChordVserverLeave :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) => LocalNodeState s -> m ()
 fediChordVserverLeave ns = do
@@ -323,7 +322,7 @@ joinOnNewEntriesThread nsSTM = loop
               pure ()
           -- otherwise try joining
           FORWARD _ -> do
-              joinResult <- fediChordVserverJoin nsSTM
+              joinResult <- runExceptT $ fediChordVserverJoin nsSTM
               either
                 -- on join failure, sleep and retry
                 -- TODO: make delay configurable
@@ -504,18 +503,26 @@ stabiliseThread nsSTM = forever $ do
     -- try looking up additional neighbours if list too short
     forM_ [(length $ predecessors updatedNs)..(kNeighbours updatedNs)] (\_ -> do
         ns' <- readTVarIO nsSTM
-        nextEntry <- requestQueryID ns' $ pred . getNid $ lastDef (toRemoteNodeState ns') (predecessors ns')
-        atomically $ do
-            latestNs <- readTVar nsSTM
-            writeTVar nsSTM $ addPredecessors [nextEntry] latestNs
+        nextEntry <- runExceptT . requestQueryID ns' $ pred . getNid $ lastDef (toRemoteNodeState ns') (predecessors ns')
+        either 
+            (const $ pure ())
+            (\entry -> atomically $ do
+                latestNs <- readTVar nsSTM
+                writeTVar nsSTM $ addPredecessors [entry] latestNs
+            )
+            nextEntry
                                                                        )
 
     forM_ [(length $ successors updatedNs)..(kNeighbours updatedNs)] (\_ -> do
         ns' <- readTVarIO nsSTM
-        nextEntry <- requestQueryID ns' $ succ . getNid $ lastDef (toRemoteNodeState ns') (successors ns')
-        atomically $ do
-            latestNs <- readTVar nsSTM
-            writeTVar nsSTM $ addSuccessors [nextEntry] latestNs
+        nextEntry <- runExceptT . requestQueryID ns' $ succ . getNid $ lastDef (toRemoteNodeState ns') (successors ns')
+        either
+            (const $ pure ())
+            (\entry -> atomically $ do
+                latestNs <- readTVar nsSTM
+                writeTVar nsSTM $ addSuccessors [entry] latestNs
+            )
+            nextEntry
                                                                      )
 
     newNs <- readTVarIO nsSTM
@@ -638,7 +645,7 @@ requestMapPurge :: MVar RequestMap -> IO ()
 requestMapPurge mapVar = forever $ do
     rMapState <- takeMVar mapVar
     now <- getPOSIXTime
-    putMVar mapVar $ Map.filter (\entry@(RequestMapEntry _ _ ts)  ->
+    putMVar mapVar $ Map.filter (\(RequestMapEntry _ _ ts)  ->
         now - ts < responsePurgeAge
                                 ) rMapState
     threadDelay $ round responsePurgeAge * 2 * 10^6
@@ -757,7 +764,7 @@ getKeyResponsibility nodeSTM lookupKey = do
 -- new entry.
 -- If no vserver is active in the DHT, 'Nothing' is returned.
 updateLookupCache :: RealNodeSTM s -> NodeID -> IO (Maybe (String, PortNumber))
-updateLookupCache nodeSTM lookupKey = do
+updateLookupCache nodeSTM keyToLookup = do
     (node, lookupSource) <- atomically $ do
         node <- readTVar nodeSTM
         let firstVs = headMay (vservers node)
@@ -767,18 +774,25 @@ updateLookupCache nodeSTM lookupKey = do
         pure (node, lookupSource)
     maybe (do
         -- if no local node available, delete cache entry and return Nothing
-        atomically $ modifyTVar' (lookupCacheSTM node) $ Map.delete lookupKey
+        atomically $ modifyTVar' (lookupCacheSTM node) $ Map.delete keyToLookup
         pure Nothing
           )
           (\n -> do
         -- start a lookup from the node, update the cache with the lookup result and return it
-        newResponsible <- requestQueryID n lookupKey
-        let newEntry = (getDomain newResponsible, getServicePort newResponsible)
-        now <- getPOSIXTime
-        -- atomic update against lost updates
-        atomically $ modifyTVar' (lookupCacheSTM node) $
-            Map.insert lookupKey (CacheEntry False newEntry now)
-        pure $ Just newEntry
+        -- TODO: better retry management, because having no vserver joined yet should
+        -- be treated differently than other reasons for not getting a result.
+        newResponsible <- runExceptT $ requestQueryID n keyToLookup
+        either 
+            (const $ pure Nothing)
+            (\result -> do
+                let newEntry = (getDomain result, getServicePort result)
+                now <- getPOSIXTime
+                -- atomic update against lost updates
+                atomically $ modifyTVar' (lookupCacheSTM node) $
+                    Map.insert keyToLookup (CacheEntry False newEntry now)
+                pure $ Just newEntry
+            )
+            newResponsible
            ) lookupSource
 
 

From fc8aa3e330280198d6a6a084f857d68ea3c9a54c Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Tue, 25 Aug 2020 22:01:01 +0200
Subject: [PATCH 067/112] bugfix: properly process QueryID responses so FOUND
 is conserved

fixes dproper discovery of announced responsibility by FOUND
---
 src/Hash2Pub/DHTProtocol.hs | 17 ++++++++++++-----
 1 file changed, 12 insertions(+), 5 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index 1cce94d..bc5d5e3 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -53,7 +53,7 @@ import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Except (MonadError(..), runExceptT)
 import qualified Data.ByteString                as BS
 import           Data.Either                    (rights)
-import           Data.Foldable                  (foldl', foldr')
+import           Data.Foldable                  (foldl', foldr', foldrM)
 import           Data.Functor.Identity
 import           Data.IP                        (IPv6, fromHostAddress6,
                                                  toHostAddress6)
@@ -596,8 +596,10 @@ sendQueryIdMessages targetID ns lParam targets = do
           -- insert new cache entries both into global cache as well as return accumulated QueryResponses for further processing
           now <- getPOSIXTime
           -- collect cache entries from all responses
-          foldM (\acc resp -> do
-            let entrySet = case queryResult <$> payload resp of
+          foldrM (\resp acc -> do
+            let 
+                responseResult = queryResult <$> payload resp
+                entrySet = case responseResult of
                              Just (FOUND result1) -> Set.singleton (RemoteCacheEntry result1 now)
                              Just (FORWARD resultset) -> resultset
                              _ -> Set.empty
@@ -607,10 +609,15 @@ sendQueryIdMessages targetID ns lParam targets = do
             -- return accumulated QueryResult
             pure $ case acc of
               -- once a FOUND as been encountered, return this as a result
-              isFound@FOUND{} -> isFound
-              FORWARD accSet  -> FORWARD $ entrySet `Set.union` accSet
+              FOUND{} -> acc
+              FORWARD accSet 
+                | maybe False isFound responseResult -> fromJust responseResult
+                | otherwise -> FORWARD $ entrySet `Set.union` accSet
 
                             ) (FORWARD Set.empty) responses
+  where
+      isFound FOUND{} = True
+      isFound _ = False
 
 -- | Create a QueryID message to be supplied to 'sendRequestTo'
 lookupMessage :: Integral i

From f1b15d5a9e82c944092b65f5330e4835027539bf Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 26 Aug 2020 17:43:32 +0200
Subject: [PATCH 068/112] bugfix: fix join by adding join node and waiting for
 it

- additionally to adding neighbours of join node, add the join node
  itself as a neighbour as well
- wait for migrations from the node
---
 src/Hash2Pub/DHTProtocol.hs | 15 +++++++--------
 src/Hash2Pub/PostService.hs |  9 +--------
 2 files changed, 8 insertions(+), 16 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index bc5d5e3..61fe7cd 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -516,20 +516,19 @@ requestJoin toJoinOn ownStateSTM = do
                     ([], Set.empty, Set.empty)
                     responses
                 -- sort, slice and set the accumulated successors and predecessors
-                newState = setSuccessors (Set.elems succAccSet) . setPredecessors (Set.elems predAccSet) $ stateSnap
+                -- the contacted node itself is a successor as well and, with few 
+                -- nodes, can be a predecessor as well
+                newState = setSuccessors (toRemoteNodeState toJoinOn:Set.elems succAccSet) . setPredecessors (toRemoteNodeState toJoinOn:Set.elems predAccSet) $ stateSnap
             writeTVar ownStateSTM newState
             pure (cacheInsertQ, newState)
         -- execute the cache insertions
         mapM_ (\f -> f joinedState) cacheInsertQ
         if responses == Set.empty
                   then pure . Left $ "join error: got no response from " <> show (getNid toJoinOn)
-           else if null (predecessors joinedState) && null (successors joinedState)
-                then pure $ Left "join error: no predecessors or successors"
-                -- successful join
-                else do
-                    -- wait for migration data to be completely received
-                    waitForMigrationFrom (nodeService prn) (getNid ownState)
-                    pure $ Right ownStateSTM
+           else do
+                -- wait for migration data to be completely received
+                waitForMigrationFrom (nodeService prn) (getNid toJoinOn)
+                pure $ Right ownStateSTM
                                    )
         `catch` (\e -> pure . Left $ displayException (e :: IOException))
 
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index fe013a0..92f784a 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -10,16 +10,10 @@ module Hash2Pub.PostService where
 
 import           Control.Concurrent
 import           Control.Concurrent.Async
-import           Control.Concurrent.MVar
 import           Control.Concurrent.STM
-import           Control.Concurrent.STM.TChan
-import           Control.Concurrent.STM.TChan
-import           Control.Concurrent.STM.TQueue
-import           Control.Concurrent.STM.TVar
 import           Control.Exception             (Exception (..), try)
 import           Control.Monad                 (foldM, forM, forM_, forever, when, void)
 import           Control.Monad.IO.Class        (liftIO)
-import           Control.Monad.STM
 import           Data.Bifunctor
 import qualified Data.ByteString.Lazy.UTF8     as BSUL
 import qualified Data.ByteString.UTF8          as BSU
@@ -40,7 +34,6 @@ import           Text.Read                     (readEither)
 import qualified Network.Wai.Handler.Warp      as Warp
 import           Servant
 import           Servant.Client
-import           Servant.Server
 
 import           Hash2Pub.FediChordTypes
 import           Hash2Pub.RingMap
@@ -355,7 +348,7 @@ clientDeliverSubscriptions :: PostService d
                            -> (String, Int)     -- ^ hostname and port of instance to deliver to
                            -> IO (Either String ())     -- Either signals success or failure
 clientDeliverSubscriptions serv fromNode fromKey toKey (toHost, toPort) = do
-    -- collect tag intearval
+    -- collect tag interval
     intervalTags <- takeRMapSuccessorsFromTo fromKey toKey <$> readTVarIO (subscribers serv)
     -- returns a [ (TagSubscribersSTM, TChan PostID, Hashtag) ]
     -- extract subscribers and posts

From ab9d593a1bcf91a1d6626c18ab938bcef80bb986 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 27 Aug 2020 00:25:02 +0200
Subject: [PATCH 069/112] bugfix: fix wrong partial Response sender access

- replaces improper record field access of `sender`, only existing in a
  Request, by `senderID` of a Response
- fixes the resulting exception-crash
- adds new function that enqueues a verification mark and timestamp bump
  of an existing cache entry
---
 Hash2Pub.cabal              |  2 +-
 src/Hash2Pub/DHTProtocol.hs | 15 +++++++++++++--
 2 files changed, 14 insertions(+), 3 deletions(-)

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index 2cc2d84..2d195e3 100644
--- a/Hash2Pub.cabal
+++ b/Hash2Pub.cabal
@@ -47,7 +47,7 @@ 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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays
-  ghc-options:         -Wall
+  ghc-options:         -Wall -Wpartial-fields
 
 
 
diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index 61fe7cd..45af727 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -658,8 +658,7 @@ requestStabilise ns neighbour = do
                                                       )
                                                       ([],[]) respSet
             -- update successfully responded neighbour in cache
-            now <- getPOSIXTime
-            maybe (pure ()) (\p -> queueAddEntries (Identity $ RemoteCacheEntry (sender p) now) ns) $ headMay (Set.elems respSet)
+            maybe (pure ()) (\p -> queueUpdateVerifieds (Identity $ senderID p) ns) $ headMay (Set.elems respSet)
             pure $ if null responsePreds && null responseSuccs
                       then Left "no neighbours returned"
                       else Right (responsePreds, responseSuccs)
@@ -826,6 +825,18 @@ queueDeleteEntry :: NodeID
                  -> IO ()
 queueDeleteEntry toDelete = queueDeleteEntries $ Identity toDelete
 
+
+-- | enqueue the timestamp update and verification marking of an entry in the
+-- global 'NodeCache'.
+queueUpdateVerifieds :: Foldable c
+                     => c NodeID
+                     -> LocalNodeState s
+                     -> IO ()
+queueUpdateVerifieds nIds ns = do
+    now <- getPOSIXTime
+    forM_ nIds $ \nid' -> atomically $ writeTQueue (cacheWriteQueue ns) $
+        markCacheEntryAsVerified (Just now) nid'
+
 -- | 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

From 1a962f1500e3af4acafb167023f640aa34eae728 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 27 Aug 2020 00:33:19 +0200
Subject: [PATCH 070/112] stylish run

---
 app/Experiment.hs           | 18 +++++++++---------
 src/Hash2Pub/DHTProtocol.hs | 12 ++++++------
 src/Hash2Pub/FediChord.hs   |  4 ++--
 src/Hash2Pub/PostService.hs | 34 +++++++++++++++++-----------------
 4 files changed, 34 insertions(+), 34 deletions(-)

diff --git a/app/Experiment.hs b/app/Experiment.hs
index 51b8e88..deb4cae 100644
--- a/app/Experiment.hs
+++ b/app/Experiment.hs
@@ -1,16 +1,16 @@
-{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Main where
 
-import System.Random
-import Control.Concurrent
-import Control.Monad (forM_)
-import Control.Monad.State.Class
-import Control.Monad.State.Strict (evalStateT)
-import Control.Monad.IO.Class
-import qualified Network.HTTP.Client           as HTTP
+import           Control.Concurrent
+import           Control.Monad              (forM_)
+import           Control.Monad.IO.Class
+import           Control.Monad.State.Class
+import           Control.Monad.State.Strict (evalStateT)
+import qualified Network.HTTP.Client        as HTTP
+import           System.Random
 
-import Hash2Pub.PostService     (clientPublishPost, Hashtag)
+import           Hash2Pub.PostService       (Hashtag, clientPublishPost)
 
 -- placeholder post data definition
 
diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index 45af727..fa5a54a 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -49,8 +49,8 @@ import           Control.Concurrent.STM.TQueue
 import           Control.Concurrent.STM.TVar
 import           Control.Exception
 import           Control.Monad                  (foldM, forM, forM_, void, when)
-import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Except (MonadError(..), runExceptT)
+import           Control.Monad.Except           (MonadError (..), runExceptT)
+import           Control.Monad.IO.Class         (MonadIO (..))
 import qualified Data.ByteString                as BS
 import           Data.Either                    (rights)
 import           Data.Foldable                  (foldl', foldr', foldrM)
@@ -516,7 +516,7 @@ requestJoin toJoinOn ownStateSTM = do
                     ([], Set.empty, Set.empty)
                     responses
                 -- sort, slice and set the accumulated successors and predecessors
-                -- the contacted node itself is a successor as well and, with few 
+                -- the contacted node itself is a successor as well and, with few
                 -- nodes, can be a predecessor as well
                 newState = setSuccessors (toRemoteNodeState toJoinOn:Set.elems succAccSet) . setPredecessors (toRemoteNodeState toJoinOn:Set.elems predAccSet) $ stateSnap
             writeTVar ownStateSTM newState
@@ -596,7 +596,7 @@ sendQueryIdMessages targetID ns lParam targets = do
           now <- getPOSIXTime
           -- collect cache entries from all responses
           foldrM (\resp acc -> do
-            let 
+            let
                 responseResult = queryResult <$> payload resp
                 entrySet = case responseResult of
                              Just (FOUND result1) -> Set.singleton (RemoteCacheEntry result1 now)
@@ -609,14 +609,14 @@ sendQueryIdMessages targetID ns lParam targets = do
             pure $ case acc of
               -- once a FOUND as been encountered, return this as a result
               FOUND{} -> acc
-              FORWARD accSet 
+              FORWARD accSet
                 | maybe False isFound responseResult -> fromJust responseResult
                 | otherwise -> FORWARD $ entrySet `Set.union` accSet
 
                             ) (FORWARD Set.empty) responses
   where
       isFound FOUND{} = True
-      isFound _ = False
+      isFound _       = False
 
 -- | Create a QueryID message to be supplied to 'sendRequestTo'
 lookupMessage :: Integral i
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 15cee10..45d0bf9 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -504,7 +504,7 @@ stabiliseThread nsSTM = forever $ do
     forM_ [(length $ predecessors updatedNs)..(kNeighbours updatedNs)] (\_ -> do
         ns' <- readTVarIO nsSTM
         nextEntry <- runExceptT . requestQueryID ns' $ pred . getNid $ lastDef (toRemoteNodeState ns') (predecessors ns')
-        either 
+        either
             (const $ pure ())
             (\entry -> atomically $ do
                 latestNs <- readTVar nsSTM
@@ -782,7 +782,7 @@ updateLookupCache nodeSTM keyToLookup = do
         -- TODO: better retry management, because having no vserver joined yet should
         -- be treated differently than other reasons for not getting a result.
         newResponsible <- runExceptT $ requestQueryID n keyToLookup
-        either 
+        either
             (const $ pure Nothing)
             (\result -> do
                 let newEntry = (getDomain result, getServicePort result)
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 92f784a..81cf552 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -11,27 +11,27 @@ module Hash2Pub.PostService where
 import           Control.Concurrent
 import           Control.Concurrent.Async
 import           Control.Concurrent.STM
-import           Control.Exception             (Exception (..), try)
-import           Control.Monad                 (foldM, forM, forM_, forever, when, void)
-import           Control.Monad.IO.Class        (liftIO)
+import           Control.Exception         (Exception (..), try)
+import           Control.Monad             (foldM, forM, forM_, forever, void,
+                                            when)
+import           Control.Monad.IO.Class    (liftIO)
 import           Data.Bifunctor
-import qualified Data.ByteString.Lazy.UTF8     as BSUL
-import qualified Data.ByteString.UTF8          as BSU
-import qualified Data.HashMap.Strict           as HMap
-import qualified Data.HashSet                  as HSet
-import           Data.Maybe                    (fromMaybe, isJust)
-import           Data.String                   (fromString)
-import qualified Data.Text.Lazy                as Txt
-import           Data.Text.Normalize           (NormalizationMode (NFC),
-                                                normalize)
+import qualified Data.ByteString.Lazy.UTF8 as BSUL
+import qualified Data.ByteString.UTF8      as BSU
+import qualified Data.HashMap.Strict       as HMap
+import qualified Data.HashSet              as HSet
+import           Data.Maybe                (fromMaybe, isJust)
+import           Data.String               (fromString)
+import qualified Data.Text.Lazy            as Txt
+import           Data.Text.Normalize       (NormalizationMode (NFC), normalize)
 import           Data.Time.Clock.POSIX
-import           Data.Typeable                 (Typeable)
-import qualified Network.HTTP.Client           as HTTP
-import qualified Network.HTTP.Types            as HTTPT
+import           Data.Typeable             (Typeable)
+import qualified Network.HTTP.Client       as HTTP
+import qualified Network.HTTP.Types        as HTTPT
 import           System.Random
-import           Text.Read                     (readEither)
+import           Text.Read                 (readEither)
 
-import qualified Network.Wai.Handler.Warp      as Warp
+import qualified Network.Wai.Handler.Warp  as Warp
 import           Servant
 import           Servant.Client
 

From 1aee41db88945ec37afebb37c78b288812c4e570 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 31 Aug 2020 13:37:40 +0200
Subject: [PATCH 071/112] enable compiler optimisation

---
 Hash2Pub.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index 2d195e3..2953d97 100644
--- a/Hash2Pub.cabal
+++ b/Hash2Pub.cabal
@@ -47,7 +47,7 @@ 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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays
-  ghc-options:         -Wall -Wpartial-fields
+  ghc-options:         -Wall -Wpartial-fields -O2
 
 
 

From 59beb3441f10623ea614c48777e676aefba40382 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 2 Sep 2020 21:37:01 +0200
Subject: [PATCH 072/112] instrumentation script executes the prepared schedule

- reads CSV schedule from file
- sends the given schedule of post events
- not thoroughly tested yet

implements #59
---
 app/Experiment.hs | 71 ++++++++++++++++++++++++++---------------------
 1 file changed, 39 insertions(+), 32 deletions(-)

diff --git a/app/Experiment.hs b/app/Experiment.hs
index deb4cae..ffa8869 100644
--- a/app/Experiment.hs
+++ b/app/Experiment.hs
@@ -3,42 +3,49 @@
 module Main where
 
 import           Control.Concurrent
-import           Control.Monad              (forM_)
-import           Control.Monad.IO.Class
-import           Control.Monad.State.Class
-import           Control.Monad.State.Strict (evalStateT)
-import qualified Network.HTTP.Client        as HTTP
-import           System.Random
+import           Control.Monad        (forM_)
+import qualified Data.Text.Lazy       as Txt
+import qualified Data.Text.Lazy.IO    as TxtI
+import qualified Network.HTTP.Client  as HTTP
+import           System.Environment   (getArgs)
 
-import           Hash2Pub.PostService       (Hashtag, clientPublishPost)
+import           Hash2Pub.PostService (Hashtag, clientPublishPost)
 
--- placeholder post data definition
-
-tagsToPostTo = [ "JustSomeTag", "WantAnotherTag234", "HereWeGoAgain", "Oyä", "通信端末" ]
-
-knownRelays :: [(String, Int)]
-knownRelays =
-  [ ("animalliberation.social", 3342)
-  , ("hostux.social", 3343)
-  , ("social.diskseven.com", 3344)
-  , ("social.imirhil.fr", 3345)
-  ]
+-- configuration constants
+timelineFile = "../simulationData/inputs/generated/timeline_sample.csv"
 
 main :: IO ()
 main = do
+    -- read CLI parameters
+    speedupStr : _ <- getArgs
+    -- read and parse timeline schedule
+    -- relying on lazyness of HaskellIO, hoping it does not introduce too strong delays
+    postEvents <- parseSchedule <$> TxtI.readFile timelineFile
+    -- actually schedule and send the post events
+    executeSchedule (read speedupStr) postEvents
+    pure ()
+
+
+
+parseSchedule :: Txt.Text
+              -> [(Int, Hashtag, (String, Int))] -- ^ [(delay in microseconds, hashtag, (hostname, port))]
+parseSchedule = fmap (parseEntry . Txt.split (== ';')) . Txt.lines
+  where
+      parseEntry [delayT, contactT, tag] =
+          (read $ Txt.unpack delayT, tag, read $ Txt.unpack contactT)
+      parseEntry _ = error "invalid schedule input format"
+
+executeSchedule :: Int  -- ^ speedup factor
+                -> [(Int, Hashtag, (String, Int))] -- ^ [(delay in microseconds, hashtag, (hostname, port))]
+                -> IO ()
+executeSchedule speedup events = do
     -- initialise HTTP manager
     httpMan <- HTTP.newManager HTTP.defaultManagerSettings
-    -- initialise RNG
-    let initRGen = mkStdGen 12
-    -- cycle through tags and post to a random instance
-    evalStateT (forM_ (cycle tagsToPostTo) $ publishPostRandom httpMan) initRGen
-    -- wait for a specified time
-
-publishPostRandom :: (RandomGen g, MonadIO m, MonadState g m) => HTTP.Manager -> Hashtag -> m ()
-publishPostRandom httpman tag = do
-    index <- state $ randomR (0, length knownRelays - 1)
-    let (pubHost, pubPort) = knownRelays !! index
-    _ <- liftIO . forkIO $ do
-        postResult <- liftIO $ clientPublishPost httpman pubHost pubPort ("foobar #" <> tag)
-        either putStrLn (const $ pure ()) postResult
-    liftIO $ threadDelay 500
+    forM_ events $ \(delay, tag, (pubHost, pubPort)) -> do
+        _ <- forkIO $
+            clientPublishPost httpMan pubHost pubPort ("foobar #" <> tag)
+            >>= either putStrLn (const $ pure ())
+        -- while threadDelay gives only minimum delay guarantees, let's hope the
+        -- additional delays are negligible
+        -- otherwise: evaluate usage of https://hackage.haskell.org/package/schedule-0.3.0.0/docs/Data-Schedule.html
+        threadDelay $ delay `div` speedup

From 20050654bce352e21520995d8524d4060b486f65 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 3 Sep 2020 11:20:38 +0200
Subject: [PATCH 073/112] make passing bootstrap information optional

reason: allow the first node to start without having to wait for a
timeout
part of #58
---
 app/Main.hs | 10 ++++++++--
 1 file changed, 8 insertions(+), 2 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 3bdb4d4..4810fb0 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -45,13 +45,19 @@ main = do
 
 readConfig :: IO (FediChordConf, ServiceConf)
 readConfig = do
-    confDomainString : ipString : portString : bootstrapHost : bootstrapPortString : servicePortString : speedup : _ <- getArgs
+    confDomainString : ipString : portString : servicePortString : speedup : remainingArgs <- getArgs
+    -- allow starting the initial node without bootstrapping info to avoid
+    -- waiting for timeout
     let
+        confBootstrapNodes' = case remainingArgs of
+            bootstrapHost : bootstrapPortString : _ ->
+                [(bootstrapHost, read bootstrapPortString)]
+            _ -> []
         fConf = FediChordConf {
         confDomain = confDomainString
       , confIP = toHostAddress6 . read $ ipString
       , confDhtPort = read portString
-      , confBootstrapNodes = [(bootstrapHost, read bootstrapPortString)]
+      , confBootstrapNodes = confBootstrapNodes'
       --, confStabiliseInterval = 60
       , confBootstrapSamplingInterval = 180
       , confMaxLookupCacheAge = 300

From 4f08d33d2eb78d576308b4e3d0d2ac9de690f256 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 4 Sep 2020 11:08:40 +0200
Subject: [PATCH 074/112] make all delays configurable and scale them according
 to a speedup factor

---
 app/Main.hs                    | 26 +++++++++++---------
 src/Hash2Pub/FediChord.hs      | 43 ++++++++++++++--------------------
 src/Hash2Pub/FediChordTypes.hs | 12 ++++++++--
 3 files changed, 43 insertions(+), 38 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 4810fb0..5f42f09 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -45,27 +45,31 @@ main = do
 
 readConfig :: IO (FediChordConf, ServiceConf)
 readConfig = do
-    confDomainString : ipString : portString : servicePortString : speedup : remainingArgs <- getArgs
+    confDomainString : ipString : portString : servicePortString : speedupString : remainingArgs <- getArgs
     -- allow starting the initial node without bootstrapping info to avoid
     -- waiting for timeout
     let
+        speedup = read speedupString
         confBootstrapNodes' = case remainingArgs of
             bootstrapHost : bootstrapPortString : _ ->
                 [(bootstrapHost, read bootstrapPortString)]
             _ -> []
         fConf = FediChordConf {
-        confDomain = confDomainString
-      , confIP = toHostAddress6 . read $ ipString
-      , confDhtPort = read portString
-      , confBootstrapNodes = confBootstrapNodes'
-      --, confStabiliseInterval = 60
-      , confBootstrapSamplingInterval = 180
-      , confMaxLookupCacheAge = 300
+            confDomain = confDomainString
+          , confIP = toHostAddress6 . read $ ipString
+          , confDhtPort = read portString
+          , confBootstrapNodes = confBootstrapNodes'
+          , confStabiliseInterval = 60 * 10^6
+          , confBootstrapSamplingInterval = 180 * 10^6 `div` speedup
+          , confMaxLookupCacheAge = 300 / fromIntegral speedup
+          , confJoinAttemptsInterval = 60 * 10^6 `div` speedup
+          , confMaxNodeCacheAge = 600 / fromIntegral speedup
+          , confResponsePurgeAge = 60 / fromIntegral speedup
                            }
         sConf = ServiceConf {
-        confSubscriptionExpiryTime = fromIntegral $ 2*3600 `div` (read speedup :: Integer)
-                            , confServicePort = read servicePortString
-                            , confServiceHost = confDomainString
+            confSubscriptionExpiryTime = fromIntegral $ 2*3600 `div` speedup
+          , confServicePort = read servicePortString
+          , confServiceHost = confDomainString
                             }
     pure (fConf, sConf)
 
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 45d0bf9..d1568e4 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -199,7 +199,7 @@ convergenceSampleThread nsSTM = forever $ do
     -- unjoined node: try joining through all bootstrapping nodes
     else tryBootstrapJoining nsSTM >> pure ()
     let delaySecs = confBootstrapSamplingInterval . nodeConfig $ parentNode
-    threadDelay $ delaySecs * 10^6
+    threadDelay delaySecs
 
 
 -- | Try joining the DHT through any of the bootstrapping nodes until it succeeds.
@@ -310,12 +310,13 @@ joinOnNewEntriesThread nsSTM = loop
   where
     loop = do
         nsSnap <- readTVarIO nsSTM
-        (lookupResult, cache) <- atomically $ do
+        (lookupResult, parentNode) <- atomically $ do
             cache <- readTVar $ nodeCacheSTM nsSnap
+            parentNode <- readTVar $ parentRealNode nsSnap
             case queryLocalCache nsSnap cache 1 (getNid nsSnap) of
               -- empty cache, block until cache changes and then retry
               (FORWARD s) | Set.null s -> retry
-              result                   -> pure (result, cache)
+              result                   -> pure (result, parentNode)
         case lookupResult of
           -- already joined
           FOUND _ ->
@@ -325,8 +326,7 @@ joinOnNewEntriesThread nsSTM = loop
               joinResult <- runExceptT $ fediChordVserverJoin nsSTM
               either
                 -- on join failure, sleep and retry
-                -- TODO: make delay configurable
-                (const $ threadDelay (30 * 10^6) >> loop)
+                (const $ threadDelay (confJoinAttemptsInterval . nodeConfig $ parentNode) >> loop)
                 (const $ pure ())
                 joinResult
 
@@ -341,20 +341,16 @@ nodeCacheWriter nsSTM =
         modifyTVar' (nodeCacheSTM ns) cacheModifier
 
 
--- TODO: make max entry age configurable
-maxEntryAge :: POSIXTime
-maxEntryAge = 600
-
-
 -- | Periodically iterate through cache, clean up expired entries and verify unverified ones
 nodeCacheVerifyThread :: LocalNodeStateSTM s -> IO ()
 nodeCacheVerifyThread nsSTM = forever $ do
     putStrLn "cache verify run: begin"
     -- get cache
-    (ns, cache) <- atomically $ do
+    (ns, cache, maxEntryAge) <- atomically $ do
         ns <- readTVar nsSTM
         cache <- readTVar $ nodeCacheSTM ns
-        pure (ns, cache)
+        maxEntryAge <- confMaxNodeCacheAge . nodeConfig <$> readTVar (parentRealNode ns)
+        pure (ns, cache, maxEntryAge)
     -- iterate entries:
     -- for avoiding too many time syscalls, get current time before iterating.
     now <- getPOSIXTime
@@ -402,7 +398,7 @@ nodeCacheVerifyThread nsSTM = forever $ do
                                                              )
 
     putStrLn "cache verify run: end"
-    threadDelay $ 10^6 * round maxEntryAge `div` 20
+    threadDelay $ fromEnum (maxEntryAge / 20) `div` 10^6    -- convert from pico to milliseconds
 
 
 -- | Checks the invariant of at least @jEntries@ per cache slice.
@@ -548,8 +544,8 @@ stabiliseThread nsSTM = forever $ do
                     newPredecessor
 
     putStrLn "stabilise run: end"
-    -- TODO: make delay configurable
-    threadDelay (60 * 10^6)
+    stabiliseDelay <- confStabiliseInterval . nodeConfig <$> readTVarIO (parentRealNode newNs)
+    threadDelay stabiliseDelay
   where
     -- | send a stabilise request to the n-th neighbour
     -- (specified by the provided getter function) and on failure retry
@@ -636,19 +632,15 @@ type RequestMap = Map.Map (SockAddr, Integer) RequestMapEntry
 data RequestMapEntry = RequestMapEntry (Set.Set FediChordMessage) (Maybe Integer)
                   POSIXTime
 
--- TODO: make purge age configurable
--- | periodically clean up old request parts
-responsePurgeAge :: POSIXTime
-responsePurgeAge = 60 -- seconds
 
-requestMapPurge :: MVar RequestMap -> IO ()
-requestMapPurge mapVar = forever $ do
+requestMapPurge :: POSIXTime -> MVar RequestMap -> IO ()
+requestMapPurge purgeAge mapVar = forever $ do
     rMapState <- takeMVar mapVar
     now <- getPOSIXTime
     putMVar mapVar $ Map.filter (\(RequestMapEntry _ _ ts)  ->
-        now - ts < responsePurgeAge
+        now - ts < purgeAge
                                 ) rMapState
-    threadDelay $ round responsePurgeAge * 2 * 10^6
+    threadDelay $ (fromEnum purgeAge * 2) `div` 10^6
 
 
 -- | Wait for messages, deserialise them, manage parts and acknowledgement status,
@@ -663,12 +655,13 @@ fediMessageHandler sendQ recvQ nsSTM = do
     -- not change.
     -- Other functions are passed the nsSTM reference and thus can get the latest state.
     nsSnap <- readTVarIO nsSTM
+    nodeConf <- nodeConfig <$> readTVarIO (parentRealNode nsSnap)
     -- handling multipart messages:
     -- Request parts can be insert into a map (key: (sender IP against spoofing, request ID), value: timestamp + set of message parts, handle all of them when size of set == parts) before being handled. This map needs to be purged periodically by a separate thread and can be protected by an MVar for fairness.
     requestMap <- newMVar (Map.empty :: RequestMap)
     -- run receive loop and requestMapPurge concurrently, so that an exception makes
     -- both of them fail
-    concurrently_ (requestMapPurge requestMap) $ forever $ do
+    concurrently_ (requestMapPurge (confResponsePurgeAge nodeConf) requestMap) $ forever $ do
         -- wait for incoming messages
         (rawMsg, sourceAddr) <- atomically $ readTQueue recvQ
         let aMsg = deserialiseMessage rawMsg
@@ -807,4 +800,4 @@ lookupCacheCleanup nodeSTM = do
                 now - ts < confMaxLookupCacheAge (nodeConfig node)
                        )
                                                        )
-        threadDelay $ round (confMaxLookupCacheAge $ nodeConfig node) * (10^5)
+        threadDelay $ fromEnum (2 * confMaxLookupCacheAge (nodeConfig node)) `div` 10^6
diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs
index cbd3a58..46668ee 100644
--- a/src/Hash2Pub/FediChordTypes.hs
+++ b/src/Hash2Pub/FediChordTypes.hs
@@ -411,10 +411,18 @@ data FediChordConf = FediChordConf
     -- ^ listening port for the FediChord DHT
     , confBootstrapNodes            :: [(String, PortNumber)]
     -- ^ list of potential bootstrapping nodes
+    , confStabiliseInterval         :: Int
+    -- ^ pause between stabilise runs, in milliseconds
     , confBootstrapSamplingInterval :: Int
-    -- ^ pause between sampling the own ID through bootstrap nodes, in seconds
+    -- ^ pause between sampling the own ID through bootstrap nodes, in milliseconds
     , confMaxLookupCacheAge         :: POSIXTime
-    -- ^ maximum age of lookup cache entries in seconds
+    -- ^ maximum age of key lookup cache entries in seconds
+    , confJoinAttemptsInterval      :: Int
+    -- ^ interval between join attempts on newly learned nodes, in milliseconds
+    , confMaxNodeCacheAge           :: POSIXTime
+    -- ^ maximum age of entries in the node cache, in milliseconds
+    , confResponsePurgeAge          :: POSIXTime
+    -- ^ maximum age of message parts in response part cache, in seconds
     }
     deriving (Show, Eq)
 

From c9b0e6611061af4231f691d6a03da19d9e27a38d Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 4 Sep 2020 16:53:48 +0200
Subject: [PATCH 075/112] scale request timeout with speedup and pass it
 directly to function

---
 app/Main.hs                    |  2 ++
 src/Hash2Pub/DHTProtocol.hs    | 49 ++++++++++++++++------------------
 src/Hash2Pub/FediChord.hs      |  5 ++--
 src/Hash2Pub/FediChordTypes.hs |  4 +++
 4 files changed, 32 insertions(+), 28 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 5f42f09..c08cd3c 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -65,6 +65,8 @@ readConfig = do
           , confJoinAttemptsInterval = 60 * 10^6 `div` speedup
           , confMaxNodeCacheAge = 600 / fromIntegral speedup
           , confResponsePurgeAge = 60 / fromIntegral speedup
+          , confRequestTimeout = 5 * 10^6 `div` speedup
+          , confRequestRetries = 3
                            }
         sConf = ServiceConf {
             confSubscriptionExpiryTime = fromIntegral $ 2*3600 `div` speedup
diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index fa5a54a..8258ca3 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -488,10 +488,11 @@ requestJoin :: (NodeState a, Service s (RealNodeSTM s)) => a             -- ^ cu
 requestJoin toJoinOn ownStateSTM = do
     ownState <- readTVarIO ownStateSTM
     prn <- readTVarIO $ parentRealNode ownState
-    srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ownState)
+    nodeConf <- nodeConfig <$> readTVarIO (parentRealNode ownState)
+    let srcAddr = confIP nodeConf
     bracket (mkSendSocket srcAddr (getDomain toJoinOn) (getDhtPort toJoinOn)) close (\sock -> do
         -- extract own state for getting request information
-        responses <- sendRequestTo (\rid -> Request rid (toRemoteNodeState ownState) 1 True Join (Just JoinRequestPayload)) sock
+        responses <- sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid -> Request rid (toRemoteNodeState ownState) 1 True Join (Just JoinRequestPayload)) sock
         (cacheInsertQ, joinedState) <- atomically $ do
             stateSnap <- readTVar ownStateSTM
             let
@@ -584,10 +585,11 @@ sendQueryIdMessages targetID ns lParam targets = do
 
           -- create connected sockets to all query targets and use them for request handling
 
-          srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
+          nodeConf <- nodeConfig <$> readTVarIO (parentRealNode ns)
+          let srcAddr = confIP nodeConf
           -- ToDo: make attempts and timeout configurable
           queryThreads <- mapM (\resultNode -> async $ bracket (mkSendSocket srcAddr (getDomain resultNode) (getDhtPort resultNode)) close (
-              sendRequestTo (lookupMessage targetID ns Nothing)
+              sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (lookupMessage targetID ns Nothing)
                                                                                                                                    )) targets
           -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613
           -- ToDo: exception handling, maybe log them
@@ -635,8 +637,9 @@ requestStabilise :: LocalNodeState s      -- ^ sending node
                  -> RemoteNodeState     -- ^ neighbour node to send to
                  -> IO (Either String ([RemoteNodeState], [RemoteNodeState]))   -- ^ (predecessors, successors) of responding node
 requestStabilise ns neighbour = do
-    srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
-    responses <- bracket (mkSendSocket srcAddr (getDomain neighbour) (getDhtPort neighbour)) close (fmap Right . sendRequestTo (\rid ->
+    nodeConf <- nodeConfig <$> readTVarIO (parentRealNode ns)
+    let srcAddr = confIP nodeConf
+    responses <- bracket (mkSendSocket srcAddr (getDomain neighbour) (getDhtPort neighbour)) close (fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid ->
         Request {
             requestID = rid
           , sender = toRemoteNodeState ns
@@ -673,13 +676,14 @@ requestLeave :: LocalNodeState s
              -> RemoteNodeState     -- target node
              -> IO (Either String ())   -- error or success
 requestLeave ns doMigration target = do
-    srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
-    let leavePayload = LeaveRequestPayload {
+    nodeConf <- nodeConfig <$> readTVarIO (parentRealNode ns)
+    let srcAddr = confIP nodeConf
+        leavePayload = LeaveRequestPayload {
         leaveSuccessors = successors ns
       , leavePredecessors = predecessors ns
       , leaveDoMigration = doMigration
                                            }
-    responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close (fmap Right . sendRequestTo (\rid ->
+    responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close (fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid ->
         Request {
             requestID = rid
           , sender = toRemoteNodeState ns
@@ -701,10 +705,11 @@ requestPing :: LocalNodeState s      -- ^ sending node
                  -> RemoteNodeState     -- ^ node to be PINGed
                  -> IO (Either String [RemoteNodeState])   -- ^ all active vServers of the pinged node
 requestPing ns target = do
-    srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
+    nodeConf <- nodeConfig <$> readTVarIO (parentRealNode ns)
+    let srcAddr = confIP nodeConf
     responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close
         (\sock -> do
-            resp <- sendRequestTo (\rid ->
+            resp <- sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid ->
                 Request {
                     requestID = rid
                   , sender = toRemoteNodeState ns
@@ -740,22 +745,14 @@ requestPing ns target = do
         ) responses
 
 
--- | 'sendRequestToWithParams' with default timeout and retries already specified.
--- Generic function for sending a request over a connected socket and collecting the response.
--- Serialises the message and tries to deliver its parts for a number of attempts within a default timeout.
-sendRequestTo :: (Integer -> FediChordMessage)       -- ^ the message to be sent, still needing a requestID
-              -> Socket                 -- ^ connected socket to use for sending
-              -> IO (Set.Set FediChordMessage)  -- ^ responses
-sendRequestTo = sendRequestToWithParams 5000 3
-
 -- | Generic function for sending a request over a connected socket and collecting the response.
 -- Serialises the message and tries to deliver its parts for a number of attempts within a specified timeout.
-sendRequestToWithParams :: Int                    -- ^ timeout in milliseconds
-                        -> Int                    -- ^ number of retries
-                        -> (Integer -> FediChordMessage)       -- ^ the message to be sent, still needing a requestID
-                        -> Socket                 -- ^ connected socket to use for sending
-                        -> IO (Set.Set FediChordMessage)  -- ^ responses
-sendRequestToWithParams timeoutMillis numAttempts msgIncomplete sock = do
+sendRequestTo :: Int                    -- ^ timeout in milliseconds
+              -> Int                    -- ^ number of retries
+              -> (Integer -> FediChordMessage)       -- ^ the message to be sent, still needing a requestID
+              -> Socket                 -- ^ connected socket to use for sending
+              -> IO (Set.Set FediChordMessage)  -- ^ responses
+sendRequestTo timeoutMillis numAttempts msgIncomplete sock = do
     -- give the message a random request ID
     randomID <- randomRIO (0, 2^32-1)
     let
@@ -764,7 +761,7 @@ sendRequestToWithParams timeoutMillis numAttempts msgIncomplete sock = do
     -- create a queue for passing received response messages back, even after a timeout
     responseQ <- newTBQueueIO $ 2*maximumParts  -- keep room for duplicate packets
     -- start sendAndAck with timeout
-    attempts numAttempts . timeout (timeoutMillis*1000) $ sendAndAck responseQ sock requests
+    _ <- attempts numAttempts . timeout (timeoutMillis*1000) $ sendAndAck responseQ sock requests
     -- after timeout, check received responses, delete them from unacked message set/ map and rerun senAndAck with that if necessary.
     recvdParts <- atomically $ flushTBQueue responseQ
     pure $ Set.fromList recvdParts
diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index d1568e4..33044fa 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -223,10 +223,11 @@ tryBootstrapJoining nsSTM = do
 bootstrapQueryId :: LocalNodeStateSTM s -> (String, PortNumber) -> NodeID -> IO (Either String RemoteNodeState)
 bootstrapQueryId nsSTM (bootstrapHost, bootstrapPort) targetID = do
     ns <- readTVarIO nsSTM
-    srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns)
+    nodeConf <- nodeConfig <$> readTVarIO (parentRealNode ns)
+    let srcAddr = confIP nodeConf
     bootstrapResponse <- bracket (mkSendSocket srcAddr bootstrapHost bootstrapPort) close (
         -- Initialise an empty cache only with the responses from a bootstrapping node
-        fmap Right . sendRequestTo (lookupMessage targetID ns Nothing)
+        fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (lookupMessage targetID ns Nothing)
                                                                                   )
        `catch` (\e -> pure . Left $ "Error at bootstrap QueryId: " <> displayException (e :: IOException))
 
diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs
index 46668ee..3b563e6 100644
--- a/src/Hash2Pub/FediChordTypes.hs
+++ b/src/Hash2Pub/FediChordTypes.hs
@@ -423,6 +423,10 @@ data FediChordConf = FediChordConf
     -- ^ maximum age of entries in the node cache, in milliseconds
     , confResponsePurgeAge          :: POSIXTime
     -- ^ maximum age of message parts in response part cache, in seconds
+    , confRequestTimeout            :: Int
+    -- ^ how long to wait until response has arrived, in milliseconds
+    , confRequestRetries            :: Int
+    -- ^ how often re-sending a timed-out request can be retried
     }
     deriving (Show, Eq)
 

From d3e5eac5c5b62c84a8e18989d39ad873a51cf95a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?H=C3=A9cate?= <hecate+github@glitchbra.in>
Date: Sat, 5 Sep 2020 12:41:18 +0200
Subject: [PATCH 076/112] Unsused imports and syntax error

---
 src/Hash2Pub/PostService.hs | 7 +++----
 src/Hash2Pub/RingMap.hs     | 4 ++--
 2 files changed, 5 insertions(+), 6 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 81cf552..7bf0c3c 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -12,15 +12,14 @@ import           Control.Concurrent
 import           Control.Concurrent.Async
 import           Control.Concurrent.STM
 import           Control.Exception         (Exception (..), try)
-import           Control.Monad             (foldM, forM, forM_, forever, void,
-                                            when)
+import           Control.Monad             (foldM, forM_, forever, void, when)
 import           Control.Monad.IO.Class    (liftIO)
 import           Data.Bifunctor
 import qualified Data.ByteString.Lazy.UTF8 as BSUL
 import qualified Data.ByteString.UTF8      as BSU
 import qualified Data.HashMap.Strict       as HMap
 import qualified Data.HashSet              as HSet
-import           Data.Maybe                (fromMaybe, isJust)
+import           Data.Maybe                (isJust)
 import           Data.String               (fromString)
 import qualified Data.Text.Lazy            as Txt
 import           Data.Text.Normalize       (NormalizationMode (NFC), normalize)
@@ -601,7 +600,7 @@ fetchTagPosts serv = forever $ do
     -- TODO: batching, retry
     -- TODO: process multiple in parallel
     pIdUri <- atomically . readTQueue $ postFetchQueue serv
-    fetchReq <- HTTP.parseRequest . Txt.unpack $pIdUri
+    fetchReq <- HTTP.parseRequest . Txt.unpack $ pIdUri
     resp <- try $ HTTP.httpLbs fetchReq (httpMan serv) :: IO (Either HTTP.HttpException (HTTP.Response BSUL.ByteString))
     case resp of
       Right response ->
diff --git a/src/Hash2Pub/RingMap.hs b/src/Hash2Pub/RingMap.hs
index e99f8b2..ae1ec15 100644
--- a/src/Hash2Pub/RingMap.hs
+++ b/src/Hash2Pub/RingMap.hs
@@ -23,7 +23,7 @@ instance (Bounded k, Ord k, Eq a) => Eq (RingMap k a) where
     a == b = getRingMap a == getRingMap b
 
 instance (Bounded k, Ord k, Show k, Show a) => Show (RingMap k a) where
-    show rmap = shows "RingMap " (show $ getRingMap rmap)
+    show rmap = shows ("RingMap " :: String) (show $ getRingMap rmap)
 
 -- | entry of a 'RingMap' that holds a value and can also
 -- wrap around the lookup direction at the edges of the name space.
@@ -207,7 +207,7 @@ takeEntriesUntil_ :: (Integral i, Bounded k, Ord k)
                  -> Maybe i     -- possible number limit
                  -> [a]
                  -> [a]
-takeEntriesUntil_ rmap' getterFunc' havingReached previousEntry (Just remaining) takeAcc
+takeEntriesUntil_ _rmap' _getterFunc' _havingReached _previousEntry (Just remaining) takeAcc
   -- length limit reached
   | remaining <= 0 = takeAcc
 takeEntriesUntil_ rmap' getterFunc' havingReached previousEntry numLimit takeAcc =

From fa78c6fc430d6903e2a777642ac646722f372c96 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sat, 5 Sep 2020 15:01:14 +0200
Subject: [PATCH 077/112] clarify different nix-shell environments in readme

---
 Readme.md | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/Readme.md b/Readme.md
index 3c7dbe5..daf9e38 100644
--- a/Readme.md
+++ b/Readme.md
@@ -14,4 +14,7 @@ The ASN.1 module schema used for DHT messages can be found in `FediChord.asn1`.
 
 The project and its developent environment are built with [Nix](https://nixos.org/nix/).
 
-The development environment can be entered with `nix-shell`. Then the project can be built with `cabal build` from within the environment, or using `nix-shell --command "cabal build"` to do both steps at once.
+The development environment can be entered with `nix-shell shell-minimal.nix`. Then the project can be built with `cabal build` from within the environment, or using `nix-shell --command "cabal build" shell-minimal.nix` to do both steps at once.
+
+While the `shell-minimal.nix` environment contains everything necessary for building and testing this project, the `shell.nix` additionally contains the Haskell IDE engine *hie* and the documentation for all used Haskell packages for more convenient development.  
+Be aware that these need to be build from source and can take a very long time to build.

From 7d833e064ba414b47f92a89cbd16227e50485c45 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?H=C3=A9cate?= <hecate+github@glitchbra.in>
Date: Sat, 5 Sep 2020 13:10:15 +0200
Subject: [PATCH 078/112] Improve readability

---
 src/Hash2Pub/PostService.hs     | 70 +++++++++++++--------------------
 src/Hash2Pub/PostService/API.hs | 37 +++++++++++++++++
 src/Hash2Pub/ProtocolTypes.hs   |  2 -
 3 files changed, 64 insertions(+), 45 deletions(-)
 create mode 100644 src/Hash2Pub/PostService/API.hs

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 7bf0c3c..89c14d2 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -21,6 +21,7 @@ import qualified Data.HashMap.Strict       as HMap
 import qualified Data.HashSet              as HSet
 import           Data.Maybe                (isJust)
 import           Data.String               (fromString)
+import           Data.Text.Lazy            (Text)
 import qualified Data.Text.Lazy            as Txt
 import           Data.Text.Normalize       (NormalizationMode (NFC), normalize)
 import           Data.Time.Clock.POSIX
@@ -35,6 +36,7 @@ import           Servant
 import           Servant.Client
 
 import           Hash2Pub.FediChordTypes
+import           Hash2Pub.PostService.API
 import           Hash2Pub.RingMap
 
 
@@ -47,7 +49,7 @@ data PostService d = PostService
     -- ^ for each tag store the subscribers + their queue
     , ownSubscriptions     :: TVar (HMap.HashMap NodeID POSIXTime)
     -- ^ tags subscribed by the own node have an assigned lease time
-    , ownPosts             :: TVar (HSet.HashSet Txt.Text)
+    , ownPosts             :: TVar (HSet.HashSet Text)
     -- ^ just store the existence of posts for saving memory,
     , relayInQueue         :: TQueue (Hashtag, PostID, PostContent)
     -- ^ Queue for processing incoming posts of own instance asynchronously
@@ -57,9 +59,9 @@ data PostService d = PostService
     }
     deriving (Typeable)
 
-type Hashtag = Txt.Text
-type PostID = Txt.Text
-type PostContent = Txt.Text
+type Hashtag = Text
+type PostID = Text
+type PostContent = Text
 -- | For each handled tag, store its subscribers and provide a
 -- broadcast 'TChan' for enqueuing posts
 type RelayTags = RingMap NodeID (TagSubscribersSTM, TChan PostID, Hashtag)
@@ -130,38 +132,13 @@ postServiceApplication :: DHT d => PostService d -> Application
 postServiceApplication serv = serve exposedPostServiceAPI $ postServer serv
 
 
--- | needed for guiding type inference
-exposedPostServiceAPI :: Proxy PostServiceAPI
-exposedPostServiceAPI = Proxy
-
 -- ========= constants ===========
 
-placeholderPost :: Txt.Text
+placeholderPost :: Text
 placeholderPost = Txt.take 5120 . Txt.repeat $ 'O' -- size 5KiB
 
 -- ========= HTTP API and handlers =============
 
-type PostServiceAPI = "relay" :> "inbox" :> Capture "hashtag" Txt.Text :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
-                 -- delivery endpoint at responsible relay for delivering posts of $tag for distribution
-                 :<|> "relay" :> "subscribers" :> Capture "senderID" Integer :> ReqBody '[PlainText] Txt.Text :> PostNoContent '[PlainText] Txt.Text
-                 -- endpoint for delivering the subscriptions and outstanding queue
-                 :<|> "post" :> Capture "postid" Txt.Text :> Get '[PlainText] Txt.Text
-                 -- fetch endpoint for posts, full post ID is http://$domain/post/$postid
-                 :<|> "posts" :> ReqBody '[PlainText] Txt.Text :> Post '[PlainText] Txt.Text
-                 -- endpoint for fetching multiple posts at once
-                 :<|> "posts" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent
-                 -- delivery endpoint of newly published posts of the relay's instance
-                 :<|> "tags" :> Capture "hashtag" Txt.Text :> ReqBody '[PlainText] Txt.Text :> PostCreated '[PlainText] Txt.Text
-                 -- delivery endpoint for posts of $tag at subscribing instance
-                 :<|> "tags" :> Capture "hashtag" Txt.Text :> "subscribe" :> Header "Origin" Txt.Text :> Get '[PlainText] Integer
-                 -- endpoint for subscribing the instance specified in
-                 -- the Origin header to $hashtag.
-                 -- Returns subscription lease time in seconds.
-                 :<|> "tags" :> Capture "hashtag" Txt.Text :> "unsubscribe" :> Header "Origin" Txt.Text :> Get '[PlainText] Txt.Text
-                 -- endpoint for unsubscribing the instance specified in
-                 -- the Origin header to $hashtag
-
-
 postServer :: DHT d => PostService d -> Server PostServiceAPI
 postServer service = relayInbox service
         :<|> subscriptionDelivery service
@@ -173,7 +150,7 @@ postServer service = relayInbox service
         :<|> tagUnsubscribe service
 
 
-relayInbox :: DHT d => PostService d -> Hashtag -> Txt.Text -> Handler NoContent
+relayInbox :: DHT d => PostService d -> Hashtag -> Text -> Handler NoContent
 relayInbox serv tag posts = do
     let
     -- skip checking whether the post actually contains the tag, just drop full post
@@ -201,7 +178,7 @@ newtype UnhandledTagException = UnhandledTagException String
 
 instance Exception UnhandledTagException
 
-subscriptionDelivery :: DHT d => PostService d -> Integer -> Txt.Text -> Handler Txt.Text
+subscriptionDelivery :: DHT d => PostService d -> Integer -> Text -> Handler Text
 subscriptionDelivery serv senderID subList = do
     let
         tagSubs = Txt.lines subList
@@ -235,7 +212,7 @@ subscriptionDelivery serv senderID subList = do
       Right _  -> pure ""
     -- TODO: check and only accept tags in own (future?) responsibility
   where
-      processTag :: TVar RelayTags -> Txt.Text -> STM ()
+      processTag :: TVar RelayTags -> Text -> STM ()
       processTag subscriberSTM tagData = do
           let
             tag:subText:lease:posts:_ = Txt.splitOn "," tagData
@@ -246,7 +223,7 @@ subscriptionDelivery serv senderID subList = do
           enqueueSubscription subscriberSTM (normaliseTag tag) sub postList leaseTime
 
 
-postFetch :: PostService d -> Txt.Text -> Handler Txt.Text
+postFetch :: PostService d -> Text -> Handler Text
 postFetch serv postID = do
     postSet <- liftIO . readTVarIO . ownPosts $ serv
     if HSet.member postID postSet
@@ -255,7 +232,7 @@ postFetch serv postID = do
        else throwError $ err404 { errBody = "No post found with this ID" }
 
 
-postMultiFetch :: PostService d -> Txt.Text -> Handler Txt.Text
+postMultiFetch :: PostService d -> Text -> Handler Text
 postMultiFetch serv postIDs = do
     let idList = Txt.lines postIDs
     postSet <- liftIO . readTVarIO . ownPosts $ serv
@@ -267,7 +244,7 @@ postMultiFetch serv postIDs = do
           ) "" idList
 
 
-postInbox :: PostService d -> Txt.Text -> Handler NoContent
+postInbox :: PostService d -> Text -> Handler NoContent
 postInbox serv post = do
     -- extract contained hashtags
     let
@@ -277,13 +254,13 @@ postInbox serv post = do
     -- add ID to own posts
     liftIO . atomically $ modifyTVar' (ownPosts serv) (HSet.insert postId)
     -- enqueue a relay job for each tag
-    liftIO $ forM_ (containedTags :: [Txt.Text]) (\tag ->
+    liftIO $ forM_ (containedTags :: [Text]) (\tag ->
         atomically $ writeTQueue (relayInQueue serv) (tag, postId,  post)
                                  )
     pure NoContent
 
 
-tagDelivery :: PostService d -> Txt.Text -> Txt.Text -> Handler Txt.Text
+tagDelivery :: PostService d -> Text -> Text -> Handler Text
 tagDelivery serv hashtag posts = do
     let postIDs = Txt.lines posts
     subscriptions <- liftIO . readTVarIO . ownSubscriptions $ serv
@@ -294,7 +271,7 @@ tagDelivery serv hashtag posts = do
             pure ()
     pure $ "Received a postID for tag " <> hashtag
 
-tagSubscribe :: DHT d => PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Integer
+tagSubscribe :: DHT d => PostService d -> Text -> Maybe Text -> Handler Integer
 tagSubscribe serv hashtag origin = do
     responsible <- liftIO $ isResponsibleFor (baseDHT serv) (hashtagToId hashtag)
     if not responsible
@@ -313,7 +290,7 @@ tagSubscribe serv hashtag origin = do
     pure $ round leaseTime
 
 
-tagUnsubscribe :: DHT d => PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Text
+tagUnsubscribe :: DHT d => PostService d -> Text -> Maybe Text -> Handler Text
 tagUnsubscribe serv hashtag origin = do
     responsible <- liftIO $ isResponsibleFor (baseDHT serv) (hashtagToId hashtag)
     if not responsible
@@ -333,8 +310,15 @@ tagUnsubscribe serv hashtag origin = do
 clientAPI :: Proxy PostServiceAPI
 clientAPI = Proxy
 
-
-relayInboxClient :<|> subscriptionDeliveryClient :<|> postFetchClient :<|> postMultiFetchClient :<|> postInboxClient :<|> tagDeliveryClient :<|> tagSubscribeClient :<|> tagUnsubscribeClient = client clientAPI
+relayInboxClient :: Text -> Text -> ClientM NoContent
+relayInboxClient :<|> subscriptionDeliveryClient
+                 :<|> postFetchClient
+                 :<|> postMultiFetchClient
+                 :<|> postInboxClient
+                 :<|> tagDeliveryClient
+                 :<|> tagSubscribeClient
+                 :<|> tagUnsubscribeClient
+                 = client clientAPI
 
 
 -- | Deliver the subscriber list of all hashtags in the interval [fromTag, toTag]
@@ -542,7 +526,7 @@ lookupTagSubscriptions tag = rMapLookup (hashtagToId tag)
 
 
 -- normalise the unicode representation of a string to NFC
-normaliseTag :: Txt.Text -> Txt.Text
+normaliseTag :: Text -> Text
 normaliseTag = Txt.fromStrict . normalize NFC . Txt.toStrict
 
 
diff --git a/src/Hash2Pub/PostService/API.hs b/src/Hash2Pub/PostService/API.hs
new file mode 100644
index 0000000..1484631
--- /dev/null
+++ b/src/Hash2Pub/PostService/API.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE InstanceSigs          #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE TypeOperators         #-}
+module Hash2Pub.PostService.API where
+
+import           Data.Text.Lazy (Text)
+
+import           Servant
+
+type PostServiceAPI = "relay" :> "inbox" :> Capture "hashtag" Text :> ReqBody '[PlainText] Text :> PutCreated '[PlainText] NoContent
+                 -- delivery endpoint at responsible relay for delivering posts of $tag for distribution
+                 :<|> "relay" :> "subscribers" :> Capture "senderID" Integer :> ReqBody '[PlainText] Text :> PostNoContent '[PlainText] Text
+                 -- endpoint for delivering the subscriptions and outstanding queue
+                 :<|> "post" :> Capture "postid" Text :> Get '[PlainText] Text
+                 -- fetch endpoint for posts, full post ID is http://$domain/post/$postid
+                 :<|> "posts" :> ReqBody '[PlainText] Text :> Post '[PlainText] Text
+                 -- endpoint for fetching multiple posts at once
+                 :<|> "posts" :> "inbox" :> ReqBody '[PlainText] Text :> PutCreated '[PlainText] NoContent
+                 -- delivery endpoint of newly published posts of the relay's instance
+                 :<|> "tags" :> Capture "hashtag" Text :> ReqBody '[PlainText] Text :> PostCreated '[PlainText] Text
+                 -- delivery endpoint for posts of $tag at subscribing instance
+                 :<|> "tags" :> Capture "hashtag" Text :> "subscribe" :> Header "Origin" Text :> Get '[PlainText] Integer
+                 -- endpoint for subscribing the instance specified in
+                 -- the Origin header to $hashtag.
+                 -- Returns subscription lease time in seconds.
+                 :<|> "tags" :> Capture "hashtag" Text :> "unsubscribe" :> Header "Origin" Text :> Get '[PlainText] Text
+                 -- endpoint for unsubscribing the instance specified in
+                 -- the Origin header to $hashtag
+
+-- | needed for guiding type inference
+exposedPostServiceAPI :: Proxy PostServiceAPI
+exposedPostServiceAPI = Proxy
+
diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs
index 86825a7..a5af10c 100644
--- a/src/Hash2Pub/ProtocolTypes.hs
+++ b/src/Hash2Pub/ProtocolTypes.hs
@@ -1,7 +1,5 @@
 module Hash2Pub.ProtocolTypes where
 
-import qualified Data.Map                as Map
-import           Data.Maybe              (mapMaybe)
 import qualified Data.Set                as Set
 import           Data.Time.Clock.POSIX   (POSIXTime)
 

From 6b166ac4ca7861aa339289cd5772b3dfca452c0d Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 7 Sep 2020 10:32:58 +0200
Subject: [PATCH 079/112] fixup! Merge branch 'measurement_logging' into
 mainline

---
 Hash2Pub.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index 2953d97..8970aaa 100644
--- a/Hash2Pub.cabal
+++ b/Hash2Pub.cabal
@@ -58,7 +58,7 @@ library
   exposed-modules:     Hash2Pub.FediChord, Hash2Pub.FediChordTypes, Hash2Pub.DHTProtocol, Hash2Pub.ASN1Coding, Hash2Pub.ProtocolTypes, Hash2Pub.PostService, Hash2Pub.RingMap
 
   -- Modules included in this library but not exported.
-  other-modules: Hash2Pub.Utils
+  other-modules: Hash2Pub.Utils, Hash2Pub.PostService.API
 
   -- LANGUAGE extensions used by modules in this package.
   other-extensions:    GeneralizedNewtypeDeriving, DataKinds, OverloadedStrings

From c823e6357a911693b5254095e44b57b2ddd0e94f Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 7 Sep 2020 13:00:15 +0200
Subject: [PATCH 080/112] accumulate all statistic/ measurement events to a
 measurement summary

- RingMap can now be mapped over
---
 src/Hash2Pub/PostService.hs | 106 ++++++++++++++++++++++++++++++++++--
 src/Hash2Pub/RingMap.hs     |  13 ++++-
 2 files changed, 114 insertions(+), 5 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 89c14d2..baa2b70 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -19,7 +19,7 @@ import qualified Data.ByteString.Lazy.UTF8 as BSUL
 import qualified Data.ByteString.UTF8      as BSU
 import qualified Data.HashMap.Strict       as HMap
 import qualified Data.HashSet              as HSet
-import           Data.Maybe                (isJust)
+import           Data.Maybe                (isJust, fromJust)
 import           Data.String               (fromString)
 import           Data.Text.Lazy            (Text)
 import qualified Data.Text.Lazy            as Txt
@@ -56,6 +56,7 @@ data PostService d = PostService
     , postFetchQueue       :: TQueue PostID
     , migrationsInProgress :: TVar (HMap.HashMap NodeID (MVar ()))
     , httpMan              :: HTTP.Manager
+    , statsQueue           :: TQueue StatsEvent
     }
     deriving (Typeable)
 
@@ -84,9 +85,10 @@ instance DHT d => Service PostService d where
         postFetchQueue' <- newTQueueIO
         migrationsInProgress' <- newTVarIO HMap.empty
         httpMan' <- HTTP.newManager HTTP.defaultManagerSettings
+        statsQueue' <- newTQueueIO
         let
-            thisService = PostService {
-                serviceConf = conf
+            thisService = PostService
+              { serviceConf = conf
               , baseDHT = dht
               , serviceThread = threadVar
               , subscribers = subscriberVar
@@ -96,7 +98,8 @@ instance DHT d => Service PostService d where
               , postFetchQueue = postFetchQueue'
               , migrationsInProgress = migrationsInProgress'
               , httpMan = httpMan'
-                                      }
+              , statsQueue = statsQueue'
+              }
             port' = fromIntegral (confServicePort conf)
             warpSettings = Warp.setPort port' . Warp.setHost (fromString . confServiceHost $ conf) $ Warp.defaultSettings
         -- Run 'concurrently_' from another thread to be able to return the
@@ -599,3 +602,98 @@ fetchTagPosts serv = forever $ do
              -- TODO error handling, retry
              pure ()
 
+
+-- ======= statistics/measurement and logging =======
+
+data StatsEventType = PostPublishEvent
+                    -- ^ initial publishing of a post by an instance
+                    | RelayReceiveEvent
+                    -- ^ receiving of posts because of being the responsible relay, for estimation of \tau_t
+                    -- TODO: record for which hashtag
+                    | RelayDeliveryEvent
+                    -- ^ delivering (or at least attempt) a post to a subscriber
+                    | IncomingPostFetchEvent
+                    -- ^ another instance fetches a post from this instance
+                    deriving (Enum, Show, Eq)
+
+-- | Represents measurement event of a 'StatsEventType' with a count relevant for a certain key
+data StatsEvent = StatsEvent StatsEventType Int NodeID
+
+-- TODO: make delay configurable
+statsAccuDelay = 300000
+
+-- | periodically flush the stats queue and accumulate all events inside
+accumulateStatsThread :: TQueue StatsEvent -> IO ()
+accumulateStatsThread statsQ = getPOSIXTime >>= flushLoop
+  where
+      flushLoop previousRun = do
+          now <- getPOSIXTime
+          -- TODO: instead of letting the events accumulate in the queue and allocate linear memory, immediately fold the result
+          -- but how to achieve the periodicity when blocking on a queue?
+          -- idea: let another thread periodically exchange the RelayStats, modify it atomically (Konzept "unterm Arsch wegziehen")
+          threadDelay statsAccuDelay
+          latestEvents <- atomically $ flushTQueue statsQ
+          -- accumulate the events
+          -- and now what? write a log to file, probably as a forkIO
+          -- persistently store in a TVar so it can be retrieved later by the DHT
+          flushLoop now
+
+
+accumulateStats :: POSIXTime -> [StatsEvent] -> RelayStats
+accumulateStats timeInterval events =
+    -- first sum all event numbers, then divide through number of seconds passed to
+    -- get rate per second
+    RelayStats
+    { relayReceiveRates = mapRMap (/ intervalSeconds) $ relayReceiveRates summedStats
+    , relayDeliveryRates = mapRMap (/ intervalSeconds) $ relayDeliveryRates summedStats
+    , postPublishRate = postPublishRate summedStats / intervalSeconds
+    , postFetchRate = postFetchRate summedStats / intervalSeconds
+    }
+  where
+      intervalSeconds = fromIntegral (fromEnum timeInterval) / 10^12
+      summedStats = foldl (\stats event -> case event of
+        StatsEvent PostPublishEvent num _ ->
+            stats {postPublishRate = fromIntegral num + postPublishRate stats}
+        StatsEvent RelayReceiveEvent num key ->
+            stats {relayReceiveRates = sumIfEntryExists key (fromIntegral num) (relayReceiveRates stats)}
+        StatsEvent RelayDeliveryEvent num key ->
+            stats {relayDeliveryRates = sumIfEntryExists key (fromIntegral num) (relayDeliveryRates stats)}
+        StatsEvent IncomingPostFetchEvent num _ ->
+            stats {postFetchRate = fromIntegral num + postFetchRate stats}
+        )
+        emptyStats
+        events
+      sumIfEntryExists = addRMapEntryWith (\newVal oldVal ->
+          let toInsert = fromJust $ extractRingEntry newVal
+          in
+          case oldVal of
+            KeyEntry n -> KeyEntry (n + toInsert)
+            ProxyEntry pointer (Just (KeyEntry n)) -> ProxyEntry pointer (Just (KeyEntry $ n + toInsert))
+            ProxyEntry pointer Nothing -> ProxyEntry pointer (Just newVal)
+            _ -> error "RingMap nested too deeply"
+                                          )
+
+-- idea: first just sum with foldl, and then map the time division over all values
+
+
+
+emptyStats :: RelayStats
+emptyStats = RelayStats
+    { relayReceiveRates = emptyRMap
+    , relayDeliveryRates = emptyRMap
+    , postFetchRate = 0
+    , postPublishRate = 0
+    }
+
+-- | measured rates of relay performance
+-- TODO: maybe include other metrics in here as well, like number of subscribers?
+data RelayStats = RelayStats
+    { relayReceiveRates  :: RingMap NodeID Double
+    -- ^ rate of incoming posts in the responsibility of this relay
+    , relayDeliveryRates :: RingMap NodeID Double
+    -- ^ rate of relayed outgoing posts
+    , postFetchRate  :: Double   -- no need to differentiate between tags
+    -- ^ number of post-fetches delivered
+    , postPublishRate :: Double
+    -- ^ rate of initially publishing posts through this instance
+    }
diff --git a/src/Hash2Pub/RingMap.hs b/src/Hash2Pub/RingMap.hs
index ae1ec15..8416278 100644
--- a/src/Hash2Pub/RingMap.hs
+++ b/src/Hash2Pub/RingMap.hs
@@ -133,7 +133,7 @@ rMapLookupPred :: (Bounded k, Ord k, Num k)
 rMapLookupPred = lookupWrapper Map.lookupLT Map.lookupLE Backwards
 
 addRMapEntryWith :: (Bounded k, Ord k)
-                 => (RingEntry k a -> RingEntry k a -> RingEntry k a)
+                 => (RingEntry k a -> RingEntry k a -> RingEntry k a) -- ^ f new_value mold_value
                  -> k   -- ^ key
                  -> a   -- ^ value
                  -> RingMap k a
@@ -247,3 +247,14 @@ takeRMapSuccessorsFromTo :: (Bounded k, Ord k, Num k)
                            -> RingMap k a
                            -> [a]
 takeRMapSuccessorsFromTo fromVal toVal rmap = takeEntriesUntil_ rmap rMapLookupSucc toVal fromVal Nothing []
+
+
+-- | map a function over all payload values of a 'RingMap'
+mapRMap :: (Bounded k, Ord k, Num k)
+        => (a -> b) -> RingMap k a -> RingMap k b
+mapRMap f = RingMap . Map.map traversingF . getRingMap
+  where
+      --traversingF :: RingEntry k a -> RingEntry k b
+      traversingF (KeyEntry a) = KeyEntry (f a)
+      traversingF (ProxyEntry pointer (Just entry)) = ProxyEntry pointer (Just $ traversingF entry)
+      traversingF (ProxyEntry pointer Nothing) = ProxyEntry pointer Nothing

From 5c338b9cd7d5ea5a7b7061bd28eac16a7b05e356 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 7 Sep 2020 16:27:19 +0200
Subject: [PATCH 081/112] split up stats summing and evaluating, launch threads

---
 src/Hash2Pub/PostService.hs | 165 +++++++++++++++++++++---------------
 1 file changed, 99 insertions(+), 66 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index baa2b70..938ca0e 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -19,7 +19,7 @@ import qualified Data.ByteString.Lazy.UTF8 as BSUL
 import qualified Data.ByteString.UTF8      as BSU
 import qualified Data.HashMap.Strict       as HMap
 import qualified Data.HashSet              as HSet
-import           Data.Maybe                (isJust, fromJust)
+import           Data.Maybe                (fromJust, isJust)
 import           Data.String               (fromString)
 import           Data.Text.Lazy            (Text)
 import qualified Data.Text.Lazy            as Txt
@@ -54,9 +54,11 @@ data PostService d = PostService
     , relayInQueue         :: TQueue (Hashtag, PostID, PostContent)
     -- ^ Queue for processing incoming posts of own instance asynchronously
     , postFetchQueue       :: TQueue PostID
+    -- ^ queue of posts to be fetched
     , migrationsInProgress :: TVar (HMap.HashMap NodeID (MVar ()))
     , httpMan              :: HTTP.Manager
     , statsQueue           :: TQueue StatsEvent
+    , loadStats            :: TVar RelayStats
     }
     deriving (Typeable)
 
@@ -86,6 +88,7 @@ instance DHT d => Service PostService d where
         migrationsInProgress' <- newTVarIO HMap.empty
         httpMan' <- HTTP.newManager HTTP.defaultManagerSettings
         statsQueue' <- newTQueueIO
+        loadStats' <- newTVarIO emptyStats
         let
             thisService = PostService
               { serviceConf = conf
@@ -99,6 +102,7 @@ instance DHT d => Service PostService d where
               , migrationsInProgress = migrationsInProgress'
               , httpMan = httpMan'
               , statsQueue = statsQueue'
+              , loadStats = loadStats'
               }
             port' = fromIntegral (confServicePort conf)
             warpSettings = Warp.setPort port' . Warp.setHost (fromString . confServiceHost $ conf) $ Warp.defaultSettings
@@ -109,7 +113,11 @@ instance DHT d => Service PostService d where
             concurrently_
                 -- web server
                 (Warp.runSettings warpSettings $ postServiceApplication thisService)
-                (processIncomingPosts thisService)
+                $ concurrently
+                    -- post queue processing
+                    (processIncomingPosts thisService)
+                    -- statistics/ measurements
+                    (launchStatsThreads thisService)
         -- update thread ID after fork
         atomically $ writeTVar threadVar servThreadID
         pure thisService
@@ -606,63 +614,64 @@ fetchTagPosts serv = forever $ do
 -- ======= statistics/measurement and logging =======
 
 data StatsEventType = PostPublishEvent
-                    -- ^ initial publishing of a post by an instance
-                    | RelayReceiveEvent
-                    -- ^ receiving of posts because of being the responsible relay, for estimation of \tau_t
-                    -- TODO: record for which hashtag
-                    | RelayDeliveryEvent
-                    -- ^ delivering (or at least attempt) a post to a subscriber
-                    | IncomingPostFetchEvent
-                    -- ^ another instance fetches a post from this instance
-                    deriving (Enum, Show, Eq)
+    | RelayReceiveEvent
+    | RelayDeliveryEvent
+    | IncomingPostFetchEvent
+    deriving (Enum, Show, Eq)
 
 -- | Represents measurement event of a 'StatsEventType' with a count relevant for a certain key
 data StatsEvent = StatsEvent StatsEventType Int NodeID
 
--- TODO: make delay configurable
-statsAccuDelay = 300000
 
--- | periodically flush the stats queue and accumulate all events inside
-accumulateStatsThread :: TQueue StatsEvent -> IO ()
-accumulateStatsThread statsQ = getPOSIXTime >>= flushLoop
-  where
-      flushLoop previousRun = do
-          now <- getPOSIXTime
-          -- TODO: instead of letting the events accumulate in the queue and allocate linear memory, immediately fold the result
-          -- but how to achieve the periodicity when blocking on a queue?
-          -- idea: let another thread periodically exchange the RelayStats, modify it atomically (Konzept "unterm Arsch wegziehen")
-          threadDelay statsAccuDelay
-          latestEvents <- atomically $ flushTQueue statsQ
-          -- accumulate the events
-          -- and now what? write a log to file, probably as a forkIO
-          -- persistently store in a TVar so it can be retrieved later by the DHT
-          flushLoop now
-
-
-accumulateStats :: POSIXTime -> [StatsEvent] -> RelayStats
-accumulateStats timeInterval events =
-    -- first sum all event numbers, then divide through number of seconds passed to
-    -- get rate per second
-    RelayStats
-    { relayReceiveRates = mapRMap (/ intervalSeconds) $ relayReceiveRates summedStats
-    , relayDeliveryRates = mapRMap (/ intervalSeconds) $ relayDeliveryRates summedStats
-    , postPublishRate = postPublishRate summedStats / intervalSeconds
-    , postFetchRate = postFetchRate summedStats / intervalSeconds
+-- | measured rates of relay performance
+-- TODO: maybe include other metrics in here as well, like number of subscribers?
+data RelayStats = RelayStats
+    { relayReceiveRates  :: RingMap NodeID Double
+    -- ^ rate of incoming posts in the responsibility of this relay
+    , relayDeliveryRates :: RingMap NodeID Double
+    -- ^ rate of relayed outgoing posts
+    , postFetchRate      :: Double -- no need to differentiate between tags
+    -- ^ number of post-fetches delivered
+    , postPublishRate    :: Double
+    -- ^ rate of initially publishing posts through this instance
     }
+
+
+-- TODO: make delay configurable
+statsEvalDelay = 300000
+
+
+launchStatsThreads :: PostService d -> IO ()
+launchStatsThreads serv = do
+    -- create shared accumulator
+    sharedAccum <- newTVarIO emptyStats
+    concurrently_
+        (accumulateStatsThread sharedAccum $ statsQueue serv)
+        (evaluateStatsThread serv sharedAccum)
+
+
+-- | Read stats events from queue and add them to a shared accumulator.
+-- Instead of letting the events accumulate in the queue and allocate linear memory, immediately fold the result.
+accumulateStatsThread :: TVar RelayStats -> TQueue StatsEvent -> IO ()
+accumulateStatsThread statsAccumulator statsQ = forever $ do
+    -- blocks until stats event arrives
+    event <- atomically $ readTQueue statsQ
+    -- add the event number to current accumulator
+    atomically $ modifyTVar' statsAccumulator $ statsAdder event
+
+
+-- | add incoming stats events to accumulator value
+statsAdder :: StatsEvent -> RelayStats -> RelayStats
+statsAdder event stats = case event of
+    StatsEvent PostPublishEvent num _ ->
+        stats {postPublishRate = fromIntegral num + postPublishRate stats}
+    StatsEvent RelayReceiveEvent num key ->
+        stats {relayReceiveRates = sumIfEntryExists key (fromIntegral num) (relayReceiveRates stats)}
+    StatsEvent RelayDeliveryEvent num key ->
+        stats {relayDeliveryRates = sumIfEntryExists key (fromIntegral num) (relayDeliveryRates stats)}
+    StatsEvent IncomingPostFetchEvent num _ ->
+        stats {postFetchRate = fromIntegral num + postFetchRate stats}
   where
-      intervalSeconds = fromIntegral (fromEnum timeInterval) / 10^12
-      summedStats = foldl (\stats event -> case event of
-        StatsEvent PostPublishEvent num _ ->
-            stats {postPublishRate = fromIntegral num + postPublishRate stats}
-        StatsEvent RelayReceiveEvent num key ->
-            stats {relayReceiveRates = sumIfEntryExists key (fromIntegral num) (relayReceiveRates stats)}
-        StatsEvent RelayDeliveryEvent num key ->
-            stats {relayDeliveryRates = sumIfEntryExists key (fromIntegral num) (relayDeliveryRates stats)}
-        StatsEvent IncomingPostFetchEvent num _ ->
-            stats {postFetchRate = fromIntegral num + postFetchRate stats}
-        )
-        emptyStats
-        events
       sumIfEntryExists = addRMapEntryWith (\newVal oldVal ->
           let toInsert = fromJust $ extractRingEntry newVal
           in
@@ -673,8 +682,45 @@ accumulateStats timeInterval events =
             _ -> error "RingMap nested too deeply"
                                           )
 
--- idea: first just sum with foldl, and then map the time division over all values
 
+-- Periodically exchange the accumulated statistics with empty ones, evaluate them
+-- and make them the current statistics of the service.
+evaluateStatsThread :: PostService d -> TVar RelayStats -> IO ()
+evaluateStatsThread serv statsAcc = getPOSIXTime >>= loop
+  where
+      loop previousTs = do
+          threadDelay statsEvalDelay
+          -- get and reset the stats accumulator
+          summedStats <- atomically $ do
+              stats <- readTVar statsAcc
+              writeTVar statsAcc emptyStats
+              pure stats
+          -- as the transaction might retry several times, current time needs to
+          -- be read afterwards
+          now <- getPOSIXTime
+          -- evaluate stats rate and replace server stats
+          atomically . writeTVar (loadStats serv) . evaluateStats (now - previousTs) $ summedStats
+          -- idea: let another thread periodically exchange the RelayStats, modify it atomically (Konzept "unterm Arsch wegziehen")
+          -- and now what? write a log to file, probably as a forkIO
+          -- persistently store in a TVar so it can be retrieved later by the DHT
+          loop now
+
+
+-- | Evaluate the accumulated statistic events: Currently mostly calculates the event
+-- rates by dividing through the collection time frame
+evaluateStats :: POSIXTime -> RelayStats -> RelayStats
+evaluateStats timeInterval summedStats =
+    -- first sum all event numbers, then divide through number of seconds passed to
+    -- get rate per second
+    RelayStats
+    { relayReceiveRates = mapRMap (/ intervalSeconds) $ relayReceiveRates summedStats
+    , relayDeliveryRates = mapRMap (/ intervalSeconds) $ relayDeliveryRates summedStats
+    , postPublishRate = postPublishRate summedStats / intervalSeconds
+    , postFetchRate = postFetchRate summedStats / intervalSeconds
+    }
+  where
+      -- TODO: take speedup into account
+      intervalSeconds = fromIntegral (fromEnum timeInterval) / 10^12
 
 
 emptyStats :: RelayStats
@@ -684,16 +730,3 @@ emptyStats = RelayStats
     , postFetchRate = 0
     , postPublishRate = 0
     }
-
--- | measured rates of relay performance
--- TODO: maybe include other metrics in here as well, like number of subscribers?
-data RelayStats = RelayStats
-    { relayReceiveRates  :: RingMap NodeID Double
-    -- ^ rate of incoming posts in the responsibility of this relay
-    , relayDeliveryRates :: RingMap NodeID Double
-    -- ^ rate of relayed outgoing posts
-    , postFetchRate  :: Double   -- no need to differentiate between tags
-    -- ^ number of post-fetches delivered
-    , postPublishRate :: Double
-    -- ^ rate of initially publishing posts through this instance
-    }

From c536994afe762016f70b91ea5bd3f59cd23d6b63 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 7 Sep 2020 16:35:59 +0200
Subject: [PATCH 082/112] re-format Servant client pattern matching

---
 src/Hash2Pub/PostService.hs | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 938ca0e..c1ea936 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -321,15 +321,15 @@ tagUnsubscribe serv hashtag origin = do
 clientAPI :: Proxy PostServiceAPI
 clientAPI = Proxy
 
-relayInboxClient :: Text -> Text -> ClientM NoContent
-relayInboxClient :<|> subscriptionDeliveryClient
-                 :<|> postFetchClient
-                 :<|> postMultiFetchClient
-                 :<|> postInboxClient
-                 :<|> tagDeliveryClient
-                 :<|> tagSubscribeClient
-                 :<|> tagUnsubscribeClient
-                 = client clientAPI
+relayInboxClient
+    :<|> subscriptionDeliveryClient
+    :<|> postFetchClient
+    :<|> postMultiFetchClient
+    :<|> postInboxClient
+    :<|> tagDeliveryClient
+    :<|> tagSubscribeClient
+    :<|> tagUnsubscribeClient
+    = client clientAPI
 
 
 -- | Deliver the subscriber list of all hashtags in the interval [fromTag, toTag]

From df479982fa15b463a2c0f0daab99cad4755eb32c Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Tue, 8 Sep 2020 08:46:36 +0200
Subject: [PATCH 083/112] make RingMap instance of Functor and Foldable

---
 src/Hash2Pub/PostService.hs |  4 ++--
 src/Hash2Pub/RingMap.hs     | 34 +++++++++++++++++++++++-----------
 2 files changed, 25 insertions(+), 13 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index c1ea936..b111455 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -713,8 +713,8 @@ evaluateStats timeInterval summedStats =
     -- first sum all event numbers, then divide through number of seconds passed to
     -- get rate per second
     RelayStats
-    { relayReceiveRates = mapRMap (/ intervalSeconds) $ relayReceiveRates summedStats
-    , relayDeliveryRates = mapRMap (/ intervalSeconds) $ relayDeliveryRates summedStats
+    { relayReceiveRates = (/ intervalSeconds) <$> relayReceiveRates summedStats
+    , relayDeliveryRates = (/ intervalSeconds) <$> relayDeliveryRates summedStats
     , postPublishRate = postPublishRate summedStats / intervalSeconds
     , postFetchRate = postFetchRate summedStats / intervalSeconds
     }
diff --git a/src/Hash2Pub/RingMap.hs b/src/Hash2Pub/RingMap.hs
index 8416278..a2fe3ae 100644
--- a/src/Hash2Pub/RingMap.hs
+++ b/src/Hash2Pub/RingMap.hs
@@ -25,6 +25,29 @@ instance (Bounded k, Ord k, Eq a) => Eq (RingMap k a) where
 instance (Bounded k, Ord k, Show k, Show a) => Show (RingMap k a) where
     show rmap = shows ("RingMap " :: String) (show $ getRingMap rmap)
 
+
+instance (Bounded k, Ord k) => Functor (RingMap k) where
+    -- | map a function over all payload values of a 'RingMap'
+    fmap f = RingMap . Map.map traversingF . getRingMap
+      where
+          traversingF (KeyEntry a) = KeyEntry (f a)
+          traversingF (ProxyEntry pointer (Just entry)) = ProxyEntry pointer (Just $ traversingF entry)
+          traversingF (ProxyEntry pointer Nothing) = ProxyEntry pointer Nothing
+
+
+instance (Bounded k, Ord k) => Foldable (RingMap k) where
+    foldr f initVal = Map.foldr traversingFR initVal . getRingMap
+      where
+          traversingFR (KeyEntry a) acc = f a acc
+          traversingFR (ProxyEntry _ Nothing) acc = acc
+          traversingFR (ProxyEntry _ (Just entry)) acc = traversingFR entry acc
+    foldl f initVal = Map.foldl traversingFL initVal . getRingMap
+      where
+          traversingFL acc (KeyEntry a) = f acc a
+          traversingFL acc (ProxyEntry _ Nothing) = acc
+          traversingFL acc (ProxyEntry _ (Just entry)) = traversingFL acc entry
+
+
 -- | entry of a 'RingMap' that holds a value and can also
 -- wrap around the lookup direction at the edges of the name space.
 data RingEntry k a = KeyEntry a
@@ -247,14 +270,3 @@ takeRMapSuccessorsFromTo :: (Bounded k, Ord k, Num k)
                            -> RingMap k a
                            -> [a]
 takeRMapSuccessorsFromTo fromVal toVal rmap = takeEntriesUntil_ rmap rMapLookupSucc toVal fromVal Nothing []
-
-
--- | map a function over all payload values of a 'RingMap'
-mapRMap :: (Bounded k, Ord k, Num k)
-        => (a -> b) -> RingMap k a -> RingMap k b
-mapRMap f = RingMap . Map.map traversingF . getRingMap
-  where
-      --traversingF :: RingEntry k a -> RingEntry k b
-      traversingF (KeyEntry a) = KeyEntry (f a)
-      traversingF (ProxyEntry pointer (Just entry)) = ProxyEntry pointer (Just $ traversingF entry)
-      traversingF (ProxyEntry pointer Nothing) = ProxyEntry pointer Nothing

From 2b39648a77dcc16c5689020d26dcd6abc8218a89 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 9 Sep 2020 11:39:48 +0200
Subject: [PATCH 084/112] actually implement simple relaying of posts

was still missing for #41
---
 src/Hash2Pub/DHTProtocol.hs |  1 -
 src/Hash2Pub/PostService.hs | 28 ++++++++++++++++++++++++++++
 2 files changed, 28 insertions(+), 1 deletion(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index 8258ca3..3639c08 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -587,7 +587,6 @@ sendQueryIdMessages targetID ns lParam targets = do
 
           nodeConf <- nodeConfig <$> readTVarIO (parentRealNode ns)
           let srcAddr = confIP nodeConf
-          -- ToDo: make attempts and timeout configurable
           queryThreads <- mapM (\resultNode -> async $ bracket (mkSendSocket srcAddr (getDomain resultNode) (getDhtPort resultNode)) close (
               sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (lookupMessage targetID ns Nothing)
                                                                                                                                    )) targets
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index b111455..099855d 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -17,6 +17,7 @@ import           Control.Monad.IO.Class    (liftIO)
 import           Data.Bifunctor
 import qualified Data.ByteString.Lazy.UTF8 as BSUL
 import qualified Data.ByteString.UTF8      as BSU
+import           Data.Either               (rights)
 import qualified Data.HashMap.Strict       as HMap
 import qualified Data.HashSet              as HSet
 import           Data.Maybe                (fromJust, isJust)
@@ -611,6 +612,33 @@ fetchTagPosts serv = forever $ do
              pure ()
 
 
+-- TODO: paralellelisation
+-- TODO: make sure it doesn't busy-wait
+relayWorker :: PostService d -> IO ()
+relayWorker serv = forever $ do
+    subscriptionMap <- readTVarIO $ subscribers serv
+    -- for each tag, try to deliver some posts to subscriber
+    forM_ subscriptionMap (\(subscriberMapSTM, _, tag) -> do
+        subscriberMap <- readTVarIO subscriberMapSTM
+        forM_ (HMap.toList subscriberMap) (\((subHost, subPort), (postChan, _)) -> do
+            postsToDeliver <- readUpTo 500 postChan
+            response <- runClientM (tagDeliveryClient tag (Txt.unlines postsToDeliver)) (mkClientEnv (httpMan serv) (BaseUrl Http subHost (fromIntegral subPort) ""))
+            -- so far just dropping failed attempts, TODO: retry mechanism
+            -- TODO: stats
+            pure ()
+            )
+        )
+  where
+      readUpTo :: Int -> TChan a -> IO [a]
+      readUpTo 0 _ = pure []
+      readUpTo n chan = do
+          readFromChan <- atomically (tryReadTChan chan)
+          case readFromChan of
+               Nothing -> pure []
+               Just val -> do
+                   moreReads <- readUpTo (pred n) chan
+                   pure (val:moreReads)
+
 -- ======= statistics/measurement and logging =======
 
 data StatsEventType = PostPublishEvent

From 0ffe9effc0dee2c8ab1591dd44565f3e6f8a17b7 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 9 Sep 2020 14:23:36 +0200
Subject: [PATCH 085/112] refactor relay processing to STM-retry instead of
 busy-wait

---
 Hash2Pub.cabal              |  2 +-
 src/Hash2Pub/PostService.hs | 48 +++++++++++++++++++++++++------------
 2 files changed, 34 insertions(+), 16 deletions(-)

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index 2953d97..5e8d25d 100644
--- a/Hash2Pub.cabal
+++ b/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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays
+  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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays, dlist
   ghc-options:         -Wall -Wpartial-fields -O2
 
 
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 099855d..c556d7f 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -17,6 +17,7 @@ import           Control.Monad.IO.Class    (liftIO)
 import           Data.Bifunctor
 import qualified Data.ByteString.Lazy.UTF8 as BSUL
 import qualified Data.ByteString.UTF8      as BSU
+import qualified Data.DList                as D
 import           Data.Either               (rights)
 import qualified Data.HashMap.Strict       as HMap
 import qualified Data.HashSet              as HSet
@@ -39,6 +40,7 @@ import           Servant.Client
 import           Hash2Pub.FediChordTypes
 import           Hash2Pub.PostService.API
 import           Hash2Pub.RingMap
+import           Hash2Pub.Utils
 
 
 data PostService d = PostService
@@ -612,27 +614,43 @@ fetchTagPosts serv = forever $ do
              pure ()
 
 
+-- TODO: make configurable
+numParallelDeliveries = 10
+
 -- TODO: paralellelisation
--- TODO: make sure it doesn't busy-wait
 relayWorker :: PostService d -> IO ()
 relayWorker serv = forever $ do
-    subscriptionMap <- readTVarIO $ subscribers serv
-    -- for each tag, try to deliver some posts to subscriber
-    forM_ subscriptionMap (\(subscriberMapSTM, _, tag) -> do
-        subscriberMap <- readTVarIO subscriberMapSTM
-        forM_ (HMap.toList subscriberMap) (\((subHost, subPort), (postChan, _)) -> do
-            postsToDeliver <- readUpTo 500 postChan
-            response <- runClientM (tagDeliveryClient tag (Txt.unlines postsToDeliver)) (mkClientEnv (httpMan serv) (BaseUrl Http subHost (fromIntegral subPort) ""))
-            -- so far just dropping failed attempts, TODO: retry mechanism
-            -- TODO: stats
-            pure ()
-            )
-        )
+    -- atomically (to be able to retry) fold a list of due delivery actions
+    jobsToProcess <- atomically $ do
+        subscriptionMap <- readTVar $ subscribers serv
+        jobList <- D.toList <$> foldM (\jobAcc (subscriberMapSTM, _, tag) -> do
+            subscriberMap <- readTVar subscriberMapSTM
+            foldM (\jobAcc' ((subHost, subPort), (postChan, _)) -> do
+                postsToDeliver <- readUpTo 500 postChan
+                -- append fetch job to job list
+                pure $ if not (null postsToDeliver)
+                   then jobAcc' `D.snoc` runClientM (tagDeliveryClient tag (Txt.unlines postsToDeliver)) (mkClientEnv (httpMan serv) (BaseUrl Http subHost (fromIntegral subPort) ""))
+                   else jobAcc'
+                ) jobAcc $ HMap.toList subscriberMap
+            ) D.empty subscriptionMap
+        -- if no relay jobs, then retry
+        if null jobList
+           then retry
+           else pure jobList
+
+    -- when processing the list, send several deliveries in parallel
+    forM_ (chunksOf numParallelDeliveries jobsToProcess) $ \jobset -> do
+        runningJobs <- mapM async jobset
+        -- so far just dropping failed attempts, TODO: retry mechanism
+        successfulResults <- rights <$> mapM waitCatch runningJobs
+        -- TODO: stats
+        pure ()
+
   where
-      readUpTo :: Int -> TChan a -> IO [a]
+      readUpTo :: Int -> TChan a -> STM [a]
       readUpTo 0 _ = pure []
       readUpTo n chan = do
-          readFromChan <- atomically (tryReadTChan chan)
+          readFromChan <- tryReadTChan chan
           case readFromChan of
                Nothing -> pure []
                Just val -> do

From 72eca0f4fe13c4636163329f0c9a9c03c4924cac Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 9 Sep 2020 17:12:56 +0200
Subject: [PATCH 086/112] log metrics to file

contributes to #60
---
 app/Main.hs                    | 13 +++++++------
 src/Hash2Pub/FediChordTypes.hs |  2 ++
 src/Hash2Pub/PostService.hs    | 17 ++++++++++++++---
 3 files changed, 23 insertions(+), 9 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index c08cd3c..80c0520 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -54,8 +54,8 @@ readConfig = do
             bootstrapHost : bootstrapPortString : _ ->
                 [(bootstrapHost, read bootstrapPortString)]
             _ -> []
-        fConf = FediChordConf {
-            confDomain = confDomainString
+        fConf = FediChordConf
+          { confDomain = confDomainString
           , confIP = toHostAddress6 . read $ ipString
           , confDhtPort = read portString
           , confBootstrapNodes = confBootstrapNodes'
@@ -67,11 +67,12 @@ readConfig = do
           , confResponsePurgeAge = 60 / fromIntegral speedup
           , confRequestTimeout = 5 * 10^6 `div` speedup
           , confRequestRetries = 3
-                           }
-        sConf = ServiceConf {
-            confSubscriptionExpiryTime = fromIntegral $ 2*3600 `div` speedup
+          }
+        sConf = ServiceConf
+          { confSubscriptionExpiryTime = fromIntegral $ 2*3600 `div` speedup
           , confServicePort = read servicePortString
           , confServiceHost = confDomainString
-                            }
+          , confLogfilePath = "../simulationData/logs/" <> confDomainString <> ".log"
+          }
     pure (fConf, sConf)
 
diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs
index 3b563e6..725031e 100644
--- a/src/Hash2Pub/FediChordTypes.hs
+++ b/src/Hash2Pub/FediChordTypes.hs
@@ -457,6 +457,8 @@ data ServiceConf = ServiceConf
     -- ^ listening port for service
     , confServiceHost            :: String
     -- ^ hostname of service
+    , confLogfilePath            :: String
+    -- ^ where to store the (measurement) log file
     }
 
 class DHT d where
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index c556d7f..2abf3b8 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -25,6 +25,7 @@ import           Data.Maybe                (fromJust, isJust)
 import           Data.String               (fromString)
 import           Data.Text.Lazy            (Text)
 import qualified Data.Text.Lazy            as Txt
+import qualified Data.Text.Lazy.IO         as TxtI
 import           Data.Text.Normalize       (NormalizationMode (NFC), normalize)
 import           Data.Time.Clock.POSIX
 import           Data.Typeable             (Typeable)
@@ -109,6 +110,8 @@ instance DHT d => Service PostService d where
               }
             port' = fromIntegral (confServicePort conf)
             warpSettings = Warp.setPort port' . Warp.setHost (fromString . confServiceHost $ conf) $ Warp.defaultSettings
+        -- log a start message, this also truncates existing files
+        TxtI.writeFile (confLogfilePath conf) "# Starting mock relay implementation\n"
         -- Run 'concurrently_' from another thread to be able to return the
         -- 'PostService'.
         -- Terminating that parent thread will make all child threads terminate as well.
@@ -745,10 +748,18 @@ evaluateStatsThread serv statsAcc = getPOSIXTime >>= loop
           -- be read afterwards
           now <- getPOSIXTime
           -- evaluate stats rate and replace server stats
-          atomically . writeTVar (loadStats serv) . evaluateStats (now - previousTs) $ summedStats
-          -- idea: let another thread periodically exchange the RelayStats, modify it atomically (Konzept "unterm Arsch wegziehen")
-          -- and now what? write a log to file, probably as a forkIO
           -- persistently store in a TVar so it can be retrieved later by the DHT
+          atomically . writeTVar (loadStats serv) . evaluateStats (now - previousTs) $ summedStats
+          -- and now what? write a log to file
+          -- format: total relayReceiveRates;total relayDeliveryRates;postFetchRate;postPublishRate
+          -- later: current (reported) load, target load
+          TxtI.appendFile (confLogfilePath . serviceConf $ serv) $
+              Txt.intercalate ";" (Txt.pack <$> (
+              [ show . sum . relayReceiveRates
+              , show . sum . relayDeliveryRates
+              , show . postPublishRate
+              , show . postFetchRate
+              ] <*> pure summedStats)) <> "\n"
           loop now
 
 

From 12fcd137541c8813ecc7e2b87733799616b3337e Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 9 Sep 2020 18:01:51 +0200
Subject: [PATCH 087/112] annotate the PostService server/ request-handler
 functions

---
 src/Hash2Pub/PostService.hs | 9 +++++++++
 1 file changed, 9 insertions(+)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 2abf3b8..3d1df68 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -167,6 +167,7 @@ postServer service = relayInbox service
         :<|> tagUnsubscribe service
 
 
+-- | delivery endpoint: receive posts of a handled tag and enqueue them for relaying
 relayInbox :: DHT d => PostService d -> Hashtag -> Text -> Handler NoContent
 relayInbox serv tag posts = do
     let
@@ -195,6 +196,7 @@ newtype UnhandledTagException = UnhandledTagException String
 
 instance Exception UnhandledTagException
 
+-- | delivery endpoint: receives a list of subscribers of tags and their outstanding queues for migration
 subscriptionDelivery :: DHT d => PostService d -> Integer -> Text -> Handler Text
 subscriptionDelivery serv senderID subList = do
     let
@@ -240,6 +242,7 @@ subscriptionDelivery serv senderID subList = do
           enqueueSubscription subscriberSTM (normaliseTag tag) sub postList leaseTime
 
 
+-- | endpoint for fetching a post by its ID
 postFetch :: PostService d -> Text -> Handler Text
 postFetch serv postID = do
     postSet <- liftIO . readTVarIO . ownPosts $ serv
@@ -249,6 +252,7 @@ postFetch serv postID = do
        else throwError $ err404 { errBody = "No post found with this ID" }
 
 
+-- | endpoint for fetching multiple posts of this instance by their IDs
 postMultiFetch :: PostService d -> Text -> Handler Text
 postMultiFetch serv postIDs = do
     let idList = Txt.lines postIDs
@@ -261,6 +265,7 @@ postMultiFetch serv postIDs = do
           ) "" idList
 
 
+-- | delivery endpoint: inbox for initially publishing a post at an instance
 postInbox :: PostService d -> Text -> Handler NoContent
 postInbox serv post = do
     -- extract contained hashtags
@@ -277,6 +282,7 @@ postInbox serv post = do
     pure NoContent
 
 
+-- | delivery endpoint: receive postIDs of a certain subscribed hashtag
 tagDelivery :: PostService d -> Text -> Text -> Handler Text
 tagDelivery serv hashtag posts = do
     let postIDs = Txt.lines posts
@@ -288,6 +294,8 @@ tagDelivery serv hashtag posts = do
             pure ()
     pure $ "Received a postID for tag " <> hashtag
 
+
+-- | receive subscription requests to a handled hashtag
 tagSubscribe :: DHT d => PostService d -> Text -> Maybe Text -> Handler Integer
 tagSubscribe serv hashtag origin = do
     responsible <- liftIO $ isResponsibleFor (baseDHT serv) (hashtagToId hashtag)
@@ -307,6 +315,7 @@ tagSubscribe serv hashtag origin = do
     pure $ round leaseTime
 
 
+-- | receive and handle unsubscription requests regarding a handled tag
 tagUnsubscribe :: DHT d => PostService d -> Text -> Maybe Text -> Handler Text
 tagUnsubscribe serv hashtag origin = do
     responsible <- liftIO $ isResponsibleFor (baseDHT serv) (hashtagToId hashtag)

From e3a8912360f4dad0a5f808ddd2e5966d91d24057 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 9 Sep 2020 18:50:45 +0200
Subject: [PATCH 088/112] process incoming posts in parallel

---
 src/Hash2Pub/PostService.hs | 105 ++++++++++++++++++++++--------------
 1 file changed, 64 insertions(+), 41 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 3d1df68..02278bf 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -12,7 +12,8 @@ import           Control.Concurrent
 import           Control.Concurrent.Async
 import           Control.Concurrent.STM
 import           Control.Exception         (Exception (..), try)
-import           Control.Monad             (foldM, forM_, forever, void, when)
+import           Control.Monad             (foldM, forM, forM_, forever, void,
+                                            when)
 import           Control.Monad.IO.Class    (liftIO)
 import           Data.Bifunctor
 import qualified Data.ByteString.Lazy.UTF8 as BSUL
@@ -560,6 +561,28 @@ normaliseTag = Txt.fromStrict . normalize NFC . Txt.toStrict
 hashtagToId :: Hashtag -> NodeID
 hashtagToId = genKeyID . Txt.unpack
 
+
+readUpToTChan :: Int -> TChan a -> STM [a]
+readUpToTChan 0 _ = pure []
+readUpToTChan n chan = do
+  readFromChan <- tryReadTChan chan
+  case readFromChan of
+       Nothing -> pure []
+       Just val -> do
+           moreReads <- readUpToTChan (pred n) chan
+           pure (val:moreReads)
+
+
+readUpToTQueue :: Int -> TQueue a -> STM [a]
+readUpToTQueue 0 _ = pure []
+readUpToTQueue n q = do
+    readFromQueue <- tryReadTQueue q
+    case readFromQueue of
+      Nothing -> pure []
+      Just val -> do
+          moreReads <- readUpToTQueue (pred n) q
+          pure (val:moreReads)
+
 -- | define how to convert all showable types to PlainText
 -- No idea what I'm doing with these overlappable instances though ¯\_(ツ)_/¯
 -- TODO: figure out how this overlapping stuff actually works https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#instance-overlap
@@ -571,36 +594,50 @@ instance {-# OVERLAPPABLE #-} Read a => MimeUnrender PlainText a where
 
 -- ====== worker threads ======
 
+-- TODO: make configurable
+numParallelDeliveries = 10
+
+
 -- | process the pending relay inbox of incoming posts from the internal queue:
 -- Look up responsible relay node for given hashtag and forward post to it
 processIncomingPosts :: DHT d => PostService d -> IO ()
 processIncomingPosts serv = forever $ do
     -- blocks until available
-    -- TODO: process multiple in parallel
-    (tag, pID, pContent) <- atomically . readTQueue $ relayInQueue serv
-    let pIdUri = "http://" <> (Txt.pack . confServiceHost . serviceConf $ serv) <> ":" <> (fromString . show . confServicePort . serviceConf $ serv) <> "/post/" <> pID
-    lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag)
-    case lookupRes of
-      -- no vserver active => wait and retry
-      Nothing -> threadDelay $ 10 * 10^6
-      Just (responsibleHost, responsiblePort) -> do
-        resp <- runClientM (relayInboxClient tag $ pIdUri <> "," <> pContent) (mkClientEnv (httpMan serv) (BaseUrl Http responsibleHost (fromIntegral responsiblePort) ""))
-        case resp of
-          Left err  -> do
-              putStrLn $ "Error: " <> show err
-              -- 410 error indicates outdated responsibility mapping
-              -- Simplification: just invalidate the mapping entry on all errors, force a re-lookup and re-queue the post
-              -- TODO: keep track of maximum retries
-              _ <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
-              atomically . writeTQueue (relayInQueue serv) $ (tag, pID, pContent)
-          Right _ -> do
-              -- TODO: stats
-              -- idea for the experiment: each post publication makes the initial posting instance subscribe to all contained tags
-              now <- getPOSIXTime
-              subscriptionStatus <- HMap.lookup (hashtagToId tag) <$> readTVarIO (ownSubscriptions serv)
-              -- if not yet subscribed or subscription expires within 2 minutes, (re)subscribe to tag
-              when (maybe False (\subLease -> now - subLease < 120) subscriptionStatus) $
-                  void $ clientSubscribeTo serv tag
+    deliveriesToProcess <- atomically $ do
+        readResult <- readUpToTQueue numParallelDeliveries $ relayInQueue serv
+        if null readResult
+           then retry
+           else pure readResult
+    runningJobs <- forM deliveriesToProcess $ \(tag, pID, pContent) -> async $ do
+        let pIdUri = "http://" <> (Txt.pack . confServiceHost . serviceConf $ serv) <> ":" <> (fromString . show . confServicePort . serviceConf $ serv) <> "/post/" <> pID
+        lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag)
+        case lookupRes of
+          -- no vserver active => wait and retry
+          Nothing -> threadDelay (10 * 10^6) >> pure (Left "no vserver active")
+          Just (responsibleHost, responsiblePort) -> do
+            resp <- runClientM (relayInboxClient tag $ pIdUri <> "," <> pContent) (mkClientEnv (httpMan serv) (BaseUrl Http responsibleHost (fromIntegral responsiblePort) ""))
+            case resp of
+              Left err  -> do
+                  -- 410 error indicates outdated responsibility mapping
+                  -- Simplification: just invalidate the mapping entry on all errors, force a re-lookup and re-queue the post
+                  -- TODO: keep track of maximum retries
+                  _ <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
+                  atomically . writeTQueue (relayInQueue serv) $ (tag, pID, pContent)
+                  pure . Left $ "Error: " <> show err
+              Right _ -> do
+                  -- idea for the experiment: each post publication makes the initial posting instance subscribe to all contained tags
+                  now <- getPOSIXTime
+                  subscriptionStatus <- HMap.lookup (hashtagToId tag) <$> readTVarIO (ownSubscriptions serv)
+                  -- if not yet subscribed or subscription expires within 2 minutes, (re)subscribe to tag
+                  when (maybe False (\subLease -> now - subLease < 120) subscriptionStatus) $
+                      void $ clientSubscribeTo serv tag
+
+                  -- for evaluation, return the tag of the successfully forwarded post
+                  pure $ Right tag
+
+    -- collect async results
+    results <- mapM waitCatch runningJobs
+    -- TODO: statistics
 
 
 -- | process the pending fetch jobs of delivered post IDs: Delivered posts are tried to be fetched from their URI-ID
@@ -626,10 +663,6 @@ fetchTagPosts serv = forever $ do
              pure ()
 
 
--- TODO: make configurable
-numParallelDeliveries = 10
-
--- TODO: paralellelisation
 relayWorker :: PostService d -> IO ()
 relayWorker serv = forever $ do
     -- atomically (to be able to retry) fold a list of due delivery actions
@@ -638,7 +671,7 @@ relayWorker serv = forever $ do
         jobList <- D.toList <$> foldM (\jobAcc (subscriberMapSTM, _, tag) -> do
             subscriberMap <- readTVar subscriberMapSTM
             foldM (\jobAcc' ((subHost, subPort), (postChan, _)) -> do
-                postsToDeliver <- readUpTo 500 postChan
+                postsToDeliver <- readUpToTChan 500 postChan
                 -- append fetch job to job list
                 pure $ if not (null postsToDeliver)
                    then jobAcc' `D.snoc` runClientM (tagDeliveryClient tag (Txt.unlines postsToDeliver)) (mkClientEnv (httpMan serv) (BaseUrl Http subHost (fromIntegral subPort) ""))
@@ -658,16 +691,6 @@ relayWorker serv = forever $ do
         -- TODO: stats
         pure ()
 
-  where
-      readUpTo :: Int -> TChan a -> STM [a]
-      readUpTo 0 _ = pure []
-      readUpTo n chan = do
-          readFromChan <- tryReadTChan chan
-          case readFromChan of
-               Nothing -> pure []
-               Just val -> do
-                   moreReads <- readUpTo (pred n) chan
-                   pure (val:moreReads)
 
 -- ======= statistics/measurement and logging =======
 

From 85d10f677314bea16cd20479f6cd5f4095fa8ea2 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 9 Sep 2020 18:50:55 +0200
Subject: [PATCH 089/112] report published posts to statistics

---
 src/Hash2Pub/PostService.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 02278bf..c6bac4a 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -637,7 +637,10 @@ processIncomingPosts serv = forever $ do
 
     -- collect async results
     results <- mapM waitCatch runningJobs
-    -- TODO: statistics
+    -- report the count of published posts for statistics
+    atomically . writeTQueue (statsQueue serv) $ StatsEvent PostPublishEvent (length . rights $ results) 0    -- hashtag published to doesn't matter
+    pure ()
+
 
 
 -- | process the pending fetch jobs of delivered post IDs: Delivered posts are tried to be fetched from their URI-ID

From 620e998876e449c4694eb1b7b73cfea06d7c0dfd Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 9 Sep 2020 19:25:48 +0200
Subject: [PATCH 090/112] report incoming relay posts to statistics

---
 src/Hash2Pub/PostService.hs | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index c6bac4a..f9b2fc4 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -185,8 +185,10 @@ relayInbox serv tag posts = do
     -- if noone subscribed to the tag, nothing needs to be done
         (pure ())
     -- otherwise enqueue posts into broadcast queue of the tag
-        (\queue ->
+        (\queue -> do
             liftIO $ forM_ postIDs (atomically . writeTChan queue)
+            -- report the received post for statistic purposes
+            liftIO . atomically . writeTQueue (statsQueue serv) $ StatsEvent RelayReceiveEvent (length postIDs) (hashtagToId tag)
         )
         broadcastChan
     pure NoContent

From f8d30d0cc40b4b13cbcf1c740a33bf37441bd50c Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 9 Sep 2020 19:55:34 +0200
Subject: [PATCH 091/112] report post fetches to statistics

---
 src/Hash2Pub/PostService.hs | 23 ++++++++++++++++++-----
 1 file changed, 18 insertions(+), 5 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index f9b2fc4..608551f 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -251,7 +251,9 @@ postFetch serv postID = do
     postSet <- liftIO . readTVarIO . ownPosts $ serv
     if HSet.member postID postSet
        -- decision: always return the same placeholder post
-       then pure placeholderPost
+       then do
+           liftIO . atomically . writeTQueue (statsQueue serv) $ StatsEvent IncomingPostFetchEvent 1 0  -- tag fetched for is irrelevant
+           pure placeholderPost
        else throwError $ err404 { errBody = "No post found with this ID" }
 
 
@@ -261,11 +263,14 @@ postMultiFetch serv postIDs = do
     let idList = Txt.lines postIDs
     postSet <- liftIO . readTVarIO . ownPosts $ serv
     -- look up existence of all given post IDs, fail if even one is missing
-    foldM (\response postID ->
+    response <- foldM (\response postID ->
         if HSet.member postID postSet
            then pure $ placeholderPost <> "\n" <> response
            else throwError $ err404 { errBody = "No post found with this ID" }
           ) "" idList
+    -- this shouldn't be reached in case of error
+    liftIO . atomically . writeTQueue (statsQueue serv) $ StatsEvent IncomingPostFetchEvent (length idList) 0  -- tag fetched for is irrelevant
+    pure response
 
 
 -- | delivery endpoint: inbox for initially publishing a post at an instance
@@ -677,9 +682,18 @@ relayWorker serv = forever $ do
             subscriberMap <- readTVar subscriberMapSTM
             foldM (\jobAcc' ((subHost, subPort), (postChan, _)) -> do
                 postsToDeliver <- readUpToTChan 500 postChan
-                -- append fetch job to job list
+                let postDeliveryAction = runClientM (tagDeliveryClient tag (Txt.unlines postsToDeliver)) (mkClientEnv (httpMan serv) (BaseUrl Http subHost (fromIntegral subPort) ""))
+                -- append relay push job to job list
                 pure $ if not (null postsToDeliver)
-                   then jobAcc' `D.snoc` runClientM (tagDeliveryClient tag (Txt.unlines postsToDeliver)) (mkClientEnv (httpMan serv) (BaseUrl Http subHost (fromIntegral subPort) ""))
+                          then jobAcc' `D.snoc` (do
+                              deliveryResult <- postDeliveryAction
+                              either
+                                (const $ pure ())
+                                -- on successful push, record that event for statistics
+                                (const . atomically . writeTQueue (statsQueue serv) $ StatsEvent RelayDeliveryEvent (length postsToDeliver) (hashtagToId tag))
+                                deliveryResult
+                              pure deliveryResult
+                                                )
                    else jobAcc'
                 ) jobAcc $ HMap.toList subscriberMap
             ) D.empty subscriptionMap
@@ -693,7 +707,6 @@ relayWorker serv = forever $ do
         runningJobs <- mapM async jobset
         -- so far just dropping failed attempts, TODO: retry mechanism
         successfulResults <- rights <$> mapM waitCatch runningJobs
-        -- TODO: stats
         pure ()
 
 

From 3c76544afbd017a4704e62c67cf1a21def6324ad Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 10 Sep 2020 12:00:17 +0200
Subject: [PATCH 092/112] launch background worker threads

---
 src/Hash2Pub/PostService.hs | 10 ++++++++--
 1 file changed, 8 insertions(+), 2 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 608551f..b943ea6 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -121,8 +121,8 @@ instance DHT d => Service PostService d where
                 -- web server
                 (Warp.runSettings warpSettings $ postServiceApplication thisService)
                 $ concurrently
-                    -- post queue processing
-                    (processIncomingPosts thisService)
+                    -- background processing workers
+                    (launchWorkerThreads thisService)
                     -- statistics/ measurements
                     (launchStatsThreads thisService)
         -- update thread ID after fork
@@ -604,6 +604,12 @@ instance {-# OVERLAPPABLE #-} Read a => MimeUnrender PlainText a where
 -- TODO: make configurable
 numParallelDeliveries = 10
 
+launchWorkerThreads :: DHT d => PostService d -> IO ()
+launchWorkerThreads serv = concurrently_
+    (processIncomingPosts serv)
+    $ concurrently_
+        (fetchTagPosts serv)
+        (relayWorker serv)
 
 -- | process the pending relay inbox of incoming posts from the internal queue:
 -- Look up responsible relay node for given hashtag and forward post to it

From 3ac89d301c9755cab1ccedc548fd1e62a8c48d7c Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 10 Sep 2020 13:09:28 +0200
Subject: [PATCH 093/112] bugfix: subscribe as default if not subscribed yet,
 when posting to a tag

---
 src/Hash2Pub/PostService.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index b943ea6..d84b58b 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -611,6 +611,7 @@ launchWorkerThreads serv = concurrently_
         (fetchTagPosts serv)
         (relayWorker serv)
 
+
 -- | process the pending relay inbox of incoming posts from the internal queue:
 -- Look up responsible relay node for given hashtag and forward post to it
 processIncomingPosts :: DHT d => PostService d -> IO ()
@@ -642,7 +643,7 @@ processIncomingPosts serv = forever $ do
                   now <- getPOSIXTime
                   subscriptionStatus <- HMap.lookup (hashtagToId tag) <$> readTVarIO (ownSubscriptions serv)
                   -- if not yet subscribed or subscription expires within 2 minutes, (re)subscribe to tag
-                  when (maybe False (\subLease -> now - subLease < 120) subscriptionStatus) $
+                  when (maybe True (\subLease -> now - subLease < 120) subscriptionStatus) $
                       void $ clientSubscribeTo serv tag
 
                   -- for evaluation, return the tag of the successfully forwarded post

From 8f917130c495d932ae7132a88710a83964bb6a10 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 10 Sep 2020 13:14:48 +0200
Subject: [PATCH 094/112] tag normalisation includes lower case conversion

---
 Hash2Pub.cabal              | 2 +-
 src/Hash2Pub/PostService.hs | 4 ++--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index 5e8d25d..f7a1676 100644
--- a/Hash2Pub.cabal
+++ b/Hash2Pub.cabal
@@ -47,7 +47,7 @@ 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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays, dlist
-  ghc-options:         -Wall -Wpartial-fields -O2
+  ghc-options:         -Wall -Wpartial-fields
 
 
 
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index d84b58b..7a082d0 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -559,9 +559,9 @@ lookupTagSubscriptions :: Hashtag -> RingMap NodeID a -> Maybe a
 lookupTagSubscriptions tag = rMapLookup (hashtagToId tag)
 
 
--- normalise the unicode representation of a string to NFC
+-- normalise the unicode representation of a string to NFC and convert to lower case
 normaliseTag :: Text -> Text
-normaliseTag = Txt.fromStrict . normalize NFC . Txt.toStrict
+normaliseTag = Txt.toLower . Txt.fromStrict . normalize NFC . Txt.toStrict
 
 
 -- | convert a hashtag to its representation on the DHT

From 34ecdd66e1b92af9b9dcd262f9c1c994f614d8bb Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 10 Sep 2020 21:23:21 +0200
Subject: [PATCH 095/112] make stats measurement delay configurable, take
 speedup into account

---
 app/Main.hs                    | 2 ++
 src/Hash2Pub/FediChordTypes.hs | 4 ++++
 src/Hash2Pub/PostService.hs    | 9 +++------
 3 files changed, 9 insertions(+), 6 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 80c0520..a620fe8 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -73,6 +73,8 @@ readConfig = do
           , confServicePort = read servicePortString
           , confServiceHost = confDomainString
           , confLogfilePath = "../simulationData/logs/" <> confDomainString <> ".log"
+          , confSpeedupFactor = speedup
+          , confStatsEvalDelay = 35 * 10^6 `div` speedup
           }
     pure (fConf, sConf)
 
diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs
index 725031e..4ce20a7 100644
--- a/src/Hash2Pub/FediChordTypes.hs
+++ b/src/Hash2Pub/FediChordTypes.hs
@@ -459,6 +459,10 @@ data ServiceConf = ServiceConf
     -- ^ hostname of service
     , confLogfilePath            :: String
     -- ^ where to store the (measurement) log file
+    , confStatsEvalDelay         :: Int
+    -- ^ delay between statistic rate measurement samplings, in microseconds
+    , confSpeedupFactor          :: Int
+    -- While the speedup factor needs to be already included in all
     }
 
 class DHT d where
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 7a082d0..d3e7daf 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -743,9 +743,6 @@ data RelayStats = RelayStats
     }
 
 
--- TODO: make delay configurable
-statsEvalDelay = 300000
-
 
 launchStatsThreads :: PostService d -> IO ()
 launchStatsThreads serv = do
@@ -795,7 +792,7 @@ evaluateStatsThread :: PostService d -> TVar RelayStats -> IO ()
 evaluateStatsThread serv statsAcc = getPOSIXTime >>= loop
   where
       loop previousTs = do
-          threadDelay statsEvalDelay
+          threadDelay $ confStatsEvalDelay (serviceConf serv)
           -- get and reset the stats accumulator
           summedStats <- atomically $ do
               stats <- readTVar statsAcc
@@ -806,7 +803,8 @@ evaluateStatsThread serv statsAcc = getPOSIXTime >>= loop
           now <- getPOSIXTime
           -- evaluate stats rate and replace server stats
           -- persistently store in a TVar so it can be retrieved later by the DHT
-          atomically . writeTVar (loadStats serv) . evaluateStats (now - previousTs) $ summedStats
+          let timePassed = (now - previousTs) * fromIntegral (confSpeedupFactor $ serviceConf serv)
+          atomically . writeTVar (loadStats serv) . evaluateStats timePassed $ summedStats
           -- and now what? write a log to file
           -- format: total relayReceiveRates;total relayDeliveryRates;postFetchRate;postPublishRate
           -- later: current (reported) load, target load
@@ -833,7 +831,6 @@ evaluateStats timeInterval summedStats =
     , postFetchRate = postFetchRate summedStats / intervalSeconds
     }
   where
-      -- TODO: take speedup into account
       intervalSeconds = fromIntegral (fromEnum timeInterval) / 10^12
 
 

From 0f9727c05a44875270582a8d57cdbdb6c1078792 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 10 Sep 2020 22:40:56 +0200
Subject: [PATCH 096/112] log the post rates instead of the absolute sums

---
 src/Hash2Pub/PostService.hs | 10 +++++++---
 1 file changed, 7 insertions(+), 3 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index d3e7daf..2170945 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -44,6 +44,7 @@ import           Hash2Pub.PostService.API
 import           Hash2Pub.RingMap
 import           Hash2Pub.Utils
 
+import           Debug.Trace
 
 data PostService d = PostService
     { serviceConf          :: ServiceConf
@@ -727,6 +728,7 @@ data StatsEventType = PostPublishEvent
 
 -- | Represents measurement event of a 'StatsEventType' with a count relevant for a certain key
 data StatsEvent = StatsEvent StatsEventType Int NodeID
+    deriving (Show, Eq)
 
 
 -- | measured rates of relay performance
@@ -741,6 +743,7 @@ data RelayStats = RelayStats
     , postPublishRate    :: Double
     -- ^ rate of initially publishing posts through this instance
     }
+    deriving (Show, Eq)
 
 
 
@@ -804,7 +807,8 @@ evaluateStatsThread serv statsAcc = getPOSIXTime >>= loop
           -- evaluate stats rate and replace server stats
           -- persistently store in a TVar so it can be retrieved later by the DHT
           let timePassed = (now - previousTs) * fromIntegral (confSpeedupFactor $ serviceConf serv)
-          atomically . writeTVar (loadStats serv) . evaluateStats timePassed $ summedStats
+          let rateStats = evaluateStats timePassed summedStats
+          atomically $ writeTVar (loadStats serv) rateStats
           -- and now what? write a log to file
           -- format: total relayReceiveRates;total relayDeliveryRates;postFetchRate;postPublishRate
           -- later: current (reported) load, target load
@@ -814,7 +818,7 @@ evaluateStatsThread serv statsAcc = getPOSIXTime >>= loop
               , show . sum . relayDeliveryRates
               , show . postPublishRate
               , show . postFetchRate
-              ] <*> pure summedStats)) <> "\n"
+              ] <*> pure rateStats)) <> "\n"
           loop now
 
 
@@ -831,7 +835,7 @@ evaluateStats timeInterval summedStats =
     , postFetchRate = postFetchRate summedStats / intervalSeconds
     }
   where
-      intervalSeconds = fromIntegral (fromEnum timeInterval) / 10^12
+      intervalSeconds = realToFrac timeInterval
 
 
 emptyStats :: RelayStats

From e12d8ef70af043b17f764409767c69850a4dac72 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 10 Sep 2020 23:54:51 +0200
Subject: [PATCH 097/112] properly format stats log numbers: no e-notation

---
 Hash2Pub.cabal              |  2 +-
 src/Hash2Pub/PostService.hs | 17 ++++++++++-------
 2 files changed, 11 insertions(+), 8 deletions(-)

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index f7a1676..92ec096 100644
--- a/Hash2Pub.cabal
+++ b/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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays, dlist
+  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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays, dlist, formatting
   ghc-options:         -Wall -Wpartial-fields
 
 
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 2170945..662b0a1 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -35,6 +35,7 @@ import qualified Network.HTTP.Types        as HTTPT
 import           System.Random
 import           Text.Read                 (readEither)
 
+import           Formatting                (float, format, (%), fixed)
 import qualified Network.Wai.Handler.Warp  as Warp
 import           Servant
 import           Servant.Client
@@ -113,7 +114,10 @@ instance DHT d => Service PostService d where
             port' = fromIntegral (confServicePort conf)
             warpSettings = Warp.setPort port' . Warp.setHost (fromString . confServiceHost $ conf) $ Warp.defaultSettings
         -- log a start message, this also truncates existing files
-        TxtI.writeFile (confLogfilePath conf) "# Starting mock relay implementation\n"
+        TxtI.writeFile (confLogfilePath conf) $ Txt.unlines
+            [ "# Starting mock relay implementation\n"
+            , "#relay receive rate   ;relay delivery rate   ;instance publish rate ;instance fetch rate"
+            ]
         -- Run 'concurrently_' from another thread to be able to return the
         -- 'PostService'.
         -- Terminating that parent thread will make all child threads terminate as well.
@@ -813,12 +817,11 @@ evaluateStatsThread serv statsAcc = getPOSIXTime >>= loop
           -- format: total relayReceiveRates;total relayDeliveryRates;postFetchRate;postPublishRate
           -- later: current (reported) load, target load
           TxtI.appendFile (confLogfilePath . serviceConf $ serv) $
-              Txt.intercalate ";" (Txt.pack <$> (
-              [ show . sum . relayReceiveRates
-              , show . sum . relayDeliveryRates
-              , show . postPublishRate
-              , show . postFetchRate
-              ] <*> pure rateStats)) <> "\n"
+              format ((fixed 20) % ";" % (fixed 20) % ";" % (fixed 20) % ";" % (fixed 20) % "\n")
+                  (sum . relayReceiveRates $ rateStats)
+                  (sum . relayDeliveryRates $ rateStats)
+                  (postPublishRate rateStats)
+                  (postFetchRate rateStats)
           loop now
 
 

From da579a0756986c5fb5b6aa1ef4848ed6fda52ae3 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 11 Sep 2020 00:36:00 +0200
Subject: [PATCH 098/112] decrease logging verbosity

---
 src/Hash2Pub/FediChord.hs   |  4 ----
 src/Hash2Pub/PostService.hs | 16 ++++++++--------
 2 files changed, 8 insertions(+), 12 deletions(-)

diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs
index 33044fa..9f14a1e 100644
--- a/src/Hash2Pub/FediChord.hs
+++ b/src/Hash2Pub/FediChord.hs
@@ -345,7 +345,6 @@ nodeCacheWriter nsSTM =
 -- | Periodically iterate through cache, clean up expired entries and verify unverified ones
 nodeCacheVerifyThread :: LocalNodeStateSTM s -> IO ()
 nodeCacheVerifyThread nsSTM = forever $ do
-    putStrLn "cache verify run: begin"
     -- get cache
     (ns, cache, maxEntryAge) <- atomically $ do
         ns <- readTVar nsSTM
@@ -398,7 +397,6 @@ nodeCacheVerifyThread nsSTM = forever $ do
         forkIO $ sendQueryIdMessages targetID latestNs (Just (1 + jEntriesPerSlice latestNs)) (nodesToQuery targetID) >> pure () -- ask for 1 entry more than j because of querying the middle
                                                              )
 
-    putStrLn "cache verify run: end"
     threadDelay $ fromEnum (maxEntryAge / 20) `div` 10^6    -- convert from pico to milliseconds
 
 
@@ -465,7 +463,6 @@ stabiliseThread :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> IO ()
 stabiliseThread nsSTM = forever $ do
     oldNs <- readTVarIO nsSTM
 
-    putStrLn "stabilise run: begin"
 
     -- iterate through the same snapshot, collect potential new neighbours
     -- and nodes to be deleted, and modify these changes only at the end of
@@ -544,7 +541,6 @@ stabiliseThread nsSTM = forever $ do
                     )
                     newPredecessor
 
-    putStrLn "stabilise run: end"
     stabiliseDelay <- confStabiliseInterval . nodeConfig <$> readTVarIO (parentRealNode newNs)
     threadDelay stabiliseDelay
   where
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 662b0a1..5e6ddcb 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -673,13 +673,13 @@ fetchTagPosts serv = forever $ do
     resp <- try $ HTTP.httpLbs fetchReq (httpMan serv) :: IO (Either HTTP.HttpException (HTTP.Response BSUL.ByteString))
     case resp of
       Right response ->
-          if HTTPT.statusCode (HTTP.responseStatus response) == 200
-             then
-             -- success, TODO: statistics
-             putStrLn "post fetch success"
-             else
-             -- TODO error handling, retry
-             pure ()
+          -- TODO error handling, retry
+          --if HTTPT.statusCode (HTTP.responseStatus response) == 200
+          --   then
+          --   -- success, TODO: statistics
+          --   putStrLn "post fetch success"
+          --   else
+          pure ()
       Left _ ->
              -- TODO error handling, retry
              pure ()
@@ -817,7 +817,7 @@ evaluateStatsThread serv statsAcc = getPOSIXTime >>= loop
           -- format: total relayReceiveRates;total relayDeliveryRates;postFetchRate;postPublishRate
           -- later: current (reported) load, target load
           TxtI.appendFile (confLogfilePath . serviceConf $ serv) $
-              format ((fixed 20) % ";" % (fixed 20) % ";" % (fixed 20) % ";" % (fixed 20) % "\n")
+              format (fixed 20 % ";" % fixed 20 % ";" % fixed 20 % ";" % fixed 20 % "\n")
                   (sum . relayReceiveRates $ rateStats)
                   (sum . relayDeliveryRates $ rateStats)
                   (postPublishRate rateStats)

From 1fc264a226419355683657e1f1ca692062c0dcea Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 11 Sep 2020 14:04:35 +0200
Subject: [PATCH 099/112] manage logging via file handle

reason: `appendFile` combined with lazy evaluation lead to exhaustion of
open file descriptors, as each file is opened again for each write and
due to lazy evaluation is kept open multiple times.
---
 src/Hash2Pub/PostService.hs | 14 +++++++++-----
 1 file changed, 9 insertions(+), 5 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 5e6ddcb..bb94e86 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -32,10 +32,11 @@ import           Data.Time.Clock.POSIX
 import           Data.Typeable             (Typeable)
 import qualified Network.HTTP.Client       as HTTP
 import qualified Network.HTTP.Types        as HTTPT
+import           System.IO
 import           System.Random
 import           Text.Read                 (readEither)
 
-import           Formatting                (float, format, (%), fixed)
+import           Formatting                (fixed, float, format, (%))
 import qualified Network.Wai.Handler.Warp  as Warp
 import           Servant
 import           Servant.Client
@@ -66,6 +67,7 @@ data PostService d = PostService
     , httpMan              :: HTTP.Manager
     , statsQueue           :: TQueue StatsEvent
     , loadStats            :: TVar RelayStats
+    , logFileHandle        :: Handle
     }
     deriving (Typeable)
 
@@ -96,6 +98,7 @@ instance DHT d => Service PostService d where
         httpMan' <- HTTP.newManager HTTP.defaultManagerSettings
         statsQueue' <- newTQueueIO
         loadStats' <- newTVarIO emptyStats
+        loggingFile <- openFile (confLogfilePath conf) WriteMode
         let
             thisService = PostService
               { serviceConf = conf
@@ -110,12 +113,13 @@ instance DHT d => Service PostService d where
               , httpMan = httpMan'
               , statsQueue = statsQueue'
               , loadStats = loadStats'
+              , logFileHandle = loggingFile
               }
             port' = fromIntegral (confServicePort conf)
             warpSettings = Warp.setPort port' . Warp.setHost (fromString . confServiceHost $ conf) $ Warp.defaultSettings
         -- log a start message, this also truncates existing files
-        TxtI.writeFile (confLogfilePath conf) $ Txt.unlines
-            [ "# Starting mock relay implementation\n"
+        TxtI.hPutStrLn loggingFile $ Txt.unlines
+            [ "# Starting mock relay implementation"
             , "#relay receive rate   ;relay delivery rate   ;instance publish rate ;instance fetch rate"
             ]
         -- Run 'concurrently_' from another thread to be able to return the
@@ -816,8 +820,8 @@ evaluateStatsThread serv statsAcc = getPOSIXTime >>= loop
           -- and now what? write a log to file
           -- format: total relayReceiveRates;total relayDeliveryRates;postFetchRate;postPublishRate
           -- later: current (reported) load, target load
-          TxtI.appendFile (confLogfilePath . serviceConf $ serv) $
-              format (fixed 20 % ";" % fixed 20 % ";" % fixed 20 % ";" % fixed 20 % "\n")
+          TxtI.hPutStrLn (logFileHandle serv) $
+              format (fixed 20 % ";" % fixed 20 % ";" % fixed 20 % ";" % fixed 20)
                   (sum . relayReceiveRates $ rateStats)
                   (sum . relayDeliveryRates $ rateStats)
                   (postPublishRate rateStats)

From 3c28cde9421a296acf687e183e811f557e92ecef Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Sat, 12 Sep 2020 15:45:03 +0200
Subject: [PATCH 100/112] catch and print all Socket bind exceptions

---
 src/Hash2Pub/DHTProtocol.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs
index 3639c08..c86c0f1 100644
--- a/src/Hash2Pub/DHTProtocol.hs
+++ b/src/Hash2Pub/DHTProtocol.hs
@@ -865,7 +865,7 @@ 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
+    bind sock sockAddr `catch` (\e -> putStrLn $ "Caught exception while bind " <> show sock <> " " <> show sockAddr <> ": " <> show (e :: SomeException))
     pure sock
 
 -- | create a UDP datagram socket, connected to a destination.
@@ -881,6 +881,6 @@ mkSendSocket srcIp dest destPort = do
     setSocketOption sendSock IPv6Only 1
     -- bind to the configured local IP to make sure that outgoing packets are sent from
     -- this source address
-    bind sendSock srcAddr
+    bind sendSock srcAddr `catch` (\e -> putStrLn $ "Caught exception while mkSendSocket bind " <> show sendSock <> " " <> show srcAddr <> ": " <> show (e :: SomeException))
     connect sendSock destAddr
     pure sendSock

From a0e7142a7d8f8eff19469d71d4d07b8c8fc29021 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 14 Sep 2020 14:57:25 +0200
Subject: [PATCH 101/112] report number of subscriptions

---
 Hash2Pub.cabal              |  2 +-
 app/Experiment.hs           |  2 +-
 app/Main.hs                 |  2 +-
 src/Hash2Pub/PostService.hs | 21 ++++++++++++++++-----
 4 files changed, 19 insertions(+), 8 deletions(-)

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index 92ec096..7be7ecf 100644
--- a/Hash2Pub.cabal
+++ b/Hash2Pub.cabal
@@ -47,7 +47,7 @@ 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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays, dlist, formatting
-  ghc-options:         -Wall -Wpartial-fields
+  ghc-options:         -Wall -Wpartial-fields -O2
 
 
 
diff --git a/app/Experiment.hs b/app/Experiment.hs
index ffa8869..a999dea 100644
--- a/app/Experiment.hs
+++ b/app/Experiment.hs
@@ -33,7 +33,7 @@ parseSchedule = fmap (parseEntry . Txt.split (== ';')) . Txt.lines
   where
       parseEntry [delayT, contactT, tag] =
           (read $ Txt.unpack delayT, tag, read $ Txt.unpack contactT)
-      parseEntry _ = error "invalid schedule input format"
+      parseEntry entry = error $ "invalid schedule input format: " <> show entry
 
 executeSchedule :: Int  -- ^ speedup factor
                 -> [(Int, Hashtag, (String, Int))] -- ^ [(delay in microseconds, hashtag, (hostname, port))]
diff --git a/app/Main.hs b/app/Main.hs
index a620fe8..c10e0c8 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -74,7 +74,7 @@ readConfig = do
           , confServiceHost = confDomainString
           , confLogfilePath = "../simulationData/logs/" <> confDomainString <> ".log"
           , confSpeedupFactor = speedup
-          , confStatsEvalDelay = 35 * 10^6 `div` speedup
+          , confStatsEvalDelay = 120 * 10^6 `div` speedup
           }
     pure (fConf, sConf)
 
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index bb94e86..f2a8a18 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -36,7 +36,7 @@ import           System.IO
 import           System.Random
 import           Text.Read                 (readEither)
 
-import           Formatting                (fixed, float, format, (%))
+import           Formatting                (fixed, format, int, (%))
 import qualified Network.Wai.Handler.Warp  as Warp
 import           Servant
 import           Servant.Client
@@ -67,6 +67,7 @@ data PostService d = PostService
     , httpMan              :: HTTP.Manager
     , statsQueue           :: TQueue StatsEvent
     , loadStats            :: TVar RelayStats
+    -- ^ current load stats, replaced periodically
     , logFileHandle        :: Handle
     }
     deriving (Typeable)
@@ -120,7 +121,7 @@ instance DHT d => Service PostService d where
         -- log a start message, this also truncates existing files
         TxtI.hPutStrLn loggingFile $ Txt.unlines
             [ "# Starting mock relay implementation"
-            , "#relay receive rate   ;relay delivery rate   ;instance publish rate ;instance fetch rate"
+            , "#relay receive rate   ;relay delivery rate   ;instance publish rate ;instance fetch rate   ;total subscriptions"
             ]
         -- Run 'concurrently_' from another thread to be able to return the
         -- 'PostService'.
@@ -681,7 +682,6 @@ fetchTagPosts serv = forever $ do
           --if HTTPT.statusCode (HTTP.responseStatus response) == 200
           --   then
           --   -- success, TODO: statistics
-          --   putStrLn "post fetch success"
           --   else
           pure ()
       Left _ ->
@@ -723,6 +723,7 @@ relayWorker serv = forever $ do
         runningJobs <- mapM async jobset
         -- so far just dropping failed attempts, TODO: retry mechanism
         successfulResults <- rights <$> mapM waitCatch runningJobs
+        putStrLn $ "successfully relayed " <> show (length successfulResults)
         pure ()
 
 
@@ -818,16 +819,26 @@ evaluateStatsThread serv statsAcc = getPOSIXTime >>= loop
           let rateStats = evaluateStats timePassed summedStats
           atomically $ writeTVar (loadStats serv) rateStats
           -- and now what? write a log to file
-          -- format: total relayReceiveRates;total relayDeliveryRates;postFetchRate;postPublishRate
+          -- format: total relayReceiveRates;total relayDeliveryRates;postFetchRate;postPublishRate; subscriberSum
           -- later: current (reported) load, target load
+          subscriberSum <- sumSubscribers
           TxtI.hPutStrLn (logFileHandle serv) $
-              format (fixed 20 % ";" % fixed 20 % ";" % fixed 20 % ";" % fixed 20)
+              format (fixed 20 % ";" % fixed 20 % ";" % fixed 20 % ";" % fixed 20 % ";" % int )
                   (sum . relayReceiveRates $ rateStats)
                   (sum . relayDeliveryRates $ rateStats)
                   (postPublishRate rateStats)
                   (postFetchRate rateStats)
+                  subscriberSum
           loop now
 
+      sumSubscribers = do
+          tagMap <- readTVarIO $ subscribers serv
+          foldM (\subscriberSum (subscriberMapSTM, _, _) -> do
+              subscriberMap <- readTVarIO subscriberMapSTM
+              pure $ subscriberSum + HMap.size subscriberMap
+                )
+                0 tagMap
+
 
 -- | Evaluate the accumulated statistic events: Currently mostly calculates the event
 -- rates by dividing through the collection time frame

From c036dea7f9f91a03f3d068ac9cb3a827961c5db4 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 14 Sep 2020 15:49:44 +0200
Subject: [PATCH 102/112] periodically purge expired subscriptions

---
 app/Main.hs                 |  2 +-
 src/Hash2Pub/PostService.hs | 26 ++++++++++++++++++++++----
 2 files changed, 23 insertions(+), 5 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index c10e0c8..d7be0a5 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -69,7 +69,7 @@ readConfig = do
           , confRequestRetries = 3
           }
         sConf = ServiceConf
-          { confSubscriptionExpiryTime = fromIntegral $ 2*3600 `div` speedup
+          { confSubscriptionExpiryTime = fromIntegral 12*3600 / fromIntegral speedup
           , confServicePort = read servicePortString
           , confServiceHost = confDomainString
           , confLogfilePath = "../simulationData/logs/" <> confDomainString <> ".log"
diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index f2a8a18..69f1b13 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -618,8 +618,26 @@ launchWorkerThreads :: DHT d => PostService d -> IO ()
 launchWorkerThreads serv = concurrently_
     (processIncomingPosts serv)
     $ concurrently_
-        (fetchTagPosts serv)
-        (relayWorker serv)
+        (purgeSubscriptionsThread serv)
+        $ concurrently_
+            (fetchTagPosts serv)
+            (relayWorker serv)
+
+
+-- | periodically remove expired subscription entries from relay subscribers
+purgeSubscriptionsThread :: PostService d -> IO ()
+purgeSubscriptionsThread serv = forever $ do
+    -- read config
+    now <- getPOSIXTime
+    let
+        purgeInterval = confSubscriptionExpiryTime (serviceConf serv) / 10
+    -- no need to atomically lock this, as newly incoming subscriptions do not
+    -- need to be purged
+    tagMap <- readTVarIO $ subscribers serv
+    forM_ tagMap $ \(subscriberMapSTM, _, _) ->
+        -- but each subscriberMap needs to be modified atomically
+        atomically . modifyTVar' subscriberMapSTM $ HMap.filter (\(_, ts) -> ts > now)
+    threadDelay $ fromEnum purgeInterval `div` 10^6
 
 
 -- | process the pending relay inbox of incoming posts from the internal queue:
@@ -652,8 +670,8 @@ processIncomingPosts serv = forever $ do
                   -- idea for the experiment: each post publication makes the initial posting instance subscribe to all contained tags
                   now <- getPOSIXTime
                   subscriptionStatus <- HMap.lookup (hashtagToId tag) <$> readTVarIO (ownSubscriptions serv)
-                  -- if not yet subscribed or subscription expires within 2 minutes, (re)subscribe to tag
-                  when (maybe True (\subLease -> now - subLease < 120) subscriptionStatus) $
+                  -- if not yet subscribed or subscription expires within 5 minutes, (re)subscribe to tag
+                  when (maybe True (\subLease -> now - subLease < 300) subscriptionStatus) $
                       void $ clientSubscribeTo serv tag
 
                   -- for evaluation, return the tag of the successfully forwarded post

From bb17b136d6505090d3f10a1cc231f404d1abec20 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 16 Sep 2020 01:54:40 +0200
Subject: [PATCH 103/112] increase stabilise interval

---
 app/Main.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index d7be0a5..d02507e 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -59,7 +59,7 @@ readConfig = do
           , confIP = toHostAddress6 . read $ ipString
           , confDhtPort = read portString
           , confBootstrapNodes = confBootstrapNodes'
-          , confStabiliseInterval = 60 * 10^6
+          , confStabiliseInterval = 80 * 10^6
           , confBootstrapSamplingInterval = 180 * 10^6 `div` speedup
           , confMaxLookupCacheAge = 300 / fromIntegral speedup
           , confJoinAttemptsInterval = 60 * 10^6 `div` speedup
@@ -69,7 +69,7 @@ readConfig = do
           , confRequestRetries = 3
           }
         sConf = ServiceConf
-          { confSubscriptionExpiryTime = fromIntegral 12*3600 / fromIntegral speedup
+          { confSubscriptionExpiryTime = 12*3600 / fromIntegral speedup
           , confServicePort = read servicePortString
           , confServiceHost = confDomainString
           , confLogfilePath = "../simulationData/logs/" <> confDomainString <> ".log"

From a2f268d374982c3987b154bae66bfffb1e383e3b Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 16 Sep 2020 01:54:50 +0200
Subject: [PATCH 104/112] improve logging: line buffering, time stamps

contributes to #60
---
 src/Hash2Pub/PostService.hs | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 69f1b13..bd83506 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -100,6 +100,7 @@ instance DHT d => Service PostService d where
         statsQueue' <- newTQueueIO
         loadStats' <- newTVarIO emptyStats
         loggingFile <- openFile (confLogfilePath conf) WriteMode
+        hSetBuffering loggingFile LineBuffering
         let
             thisService = PostService
               { serviceConf = conf
@@ -121,7 +122,7 @@ instance DHT d => Service PostService d where
         -- log a start message, this also truncates existing files
         TxtI.hPutStrLn loggingFile $ Txt.unlines
             [ "# Starting mock relay implementation"
-            , "#relay receive rate   ;relay delivery rate   ;instance publish rate ;instance fetch rate   ;total subscriptions"
+            , "#time stamp         ; relay receive rate   ;relay delivery rate   ;instance publish rate ;instance fetch rate   ;total subscriptions"
             ]
         -- Run 'concurrently_' from another thread to be able to return the
         -- 'PostService'.
@@ -841,7 +842,8 @@ evaluateStatsThread serv statsAcc = getPOSIXTime >>= loop
           -- later: current (reported) load, target load
           subscriberSum <- sumSubscribers
           TxtI.hPutStrLn (logFileHandle serv) $
-              format (fixed 20 % ";" % fixed 20 % ";" % fixed 20 % ";" % fixed 20 % ";" % int )
+              format (fixed 9 % ";" % fixed 20 % ";" % fixed 20 % ";" % fixed 20 % ";" % fixed 20 % ";" % int )
+                  (realToFrac now :: Double)
                   (sum . relayReceiveRates $ rateStats)
                   (sum . relayDeliveryRates $ rateStats)
                   (postPublishRate rateStats)

From f5de7601bbef988d82e756d42e3f2197f2646325 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 16 Sep 2020 13:49:26 +0200
Subject: [PATCH 105/112] do not store published posts for reducing memory
 consumption

---
 src/Hash2Pub/PostService.hs | 36 +++++++++++++++---------------------
 1 file changed, 15 insertions(+), 21 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index bd83506..75bdd33 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -57,7 +57,7 @@ data PostService d = PostService
     -- ^ for each tag store the subscribers + their queue
     , ownSubscriptions     :: TVar (HMap.HashMap NodeID POSIXTime)
     -- ^ tags subscribed by the own node have an assigned lease time
-    , ownPosts             :: TVar (HSet.HashSet Text)
+    --, ownPosts             :: TVar (HSet.HashSet Text)
     -- ^ just store the existence of posts for saving memory,
     , relayInQueue         :: TQueue (Hashtag, PostID, PostContent)
     -- ^ Queue for processing incoming posts of own instance asynchronously
@@ -92,7 +92,7 @@ instance DHT d => Service PostService d where
         threadVar <- newTVarIO =<< myThreadId -- own thread ID as placeholder
         subscriberVar <- newTVarIO emptyRMap
         ownSubsVar <- newTVarIO HMap.empty
-        ownPostVar <- newTVarIO HSet.empty
+        --ownPostVar <- newTVarIO HSet.empty
         relayInQueue' <- newTQueueIO
         postFetchQueue' <- newTQueueIO
         migrationsInProgress' <- newTVarIO HMap.empty
@@ -108,7 +108,7 @@ instance DHT d => Service PostService d where
               , serviceThread = threadVar
               , subscribers = subscriberVar
               , ownSubscriptions = ownSubsVar
-              , ownPosts = ownPostVar
+              --, ownPosts = ownPostVar
               , relayInQueue = relayInQueue'
               , postFetchQueue = postFetchQueue'
               , migrationsInProgress = migrationsInProgress'
@@ -258,28 +258,23 @@ subscriptionDelivery serv senderID subList = do
 
 -- | endpoint for fetching a post by its ID
 postFetch :: PostService d -> Text -> Handler Text
-postFetch serv postID = do
-    postSet <- liftIO . readTVarIO . ownPosts $ serv
-    if HSet.member postID postSet
-       -- decision: always return the same placeholder post
-       then do
-           liftIO . atomically . writeTQueue (statsQueue serv) $ StatsEvent IncomingPostFetchEvent 1 0  -- tag fetched for is irrelevant
-           pure placeholderPost
-       else throwError $ err404 { errBody = "No post found with this ID" }
+postFetch serv _ = do
+    -- decision: for saving memory do not store published posts, just
+    -- pretend there is a post for each requested ID
+    liftIO . atomically . writeTQueue (statsQueue serv) $ StatsEvent IncomingPostFetchEvent 1 0  -- tag fetched for is irrelevant
+    pure placeholderPost
 
 
 -- | endpoint for fetching multiple posts of this instance by their IDs
 postMultiFetch :: PostService d -> Text -> Handler Text
 postMultiFetch serv postIDs = do
-    let idList = Txt.lines postIDs
-    postSet <- liftIO . readTVarIO . ownPosts $ serv
-    -- look up existence of all given post IDs, fail if even one is missing
-    response <- foldM (\response postID ->
-        if HSet.member postID postSet
-           then pure $ placeholderPost <> "\n" <> response
-           else throwError $ err404 { errBody = "No post found with this ID" }
+    let
+        idList = Txt.lines postIDs
+        -- decision: for saving memory do not store published posts, just
+        -- pretend there is a post for each requested ID
+        response = foldl (\response' _ ->
+           placeholderPost <> "\n" <> response'
           ) "" idList
-    -- this shouldn't be reached in case of error
     liftIO . atomically . writeTQueue (statsQueue serv) $ StatsEvent IncomingPostFetchEvent (length idList) 0  -- tag fetched for is irrelevant
     pure response
 
@@ -292,8 +287,7 @@ postInbox serv post = do
         containedTags = fmap (normaliseTag . Txt.tail) . filter ((==) '#' . Txt.head) . Txt.words $ post
     -- generate post ID
     postId <- liftIO $ Txt.pack . show <$> (randomRIO (0, 2^(128::Integer)-1) :: IO Integer)
-    -- add ID to own posts
-    liftIO . atomically $ modifyTVar' (ownPosts serv) (HSet.insert postId)
+    -- decision: for saving memory do not store published post IDs, just deliver a post for any requested ID
     -- enqueue a relay job for each tag
     liftIO $ forM_ (containedTags :: [Text]) (\tag ->
         atomically $ writeTQueue (relayInQueue serv) (tag, postId,  post)

From 556b69d887dcbf99287d819a7625f59a6163476c Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Wed, 16 Sep 2020 16:07:39 +0200
Subject: [PATCH 106/112] increase subscription lease to 1 (simulated) day for
 achieving higher subscriber numbers

---
 app/Main.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/app/Main.hs b/app/Main.hs
index d02507e..eac223d 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -69,7 +69,7 @@ readConfig = do
           , confRequestRetries = 3
           }
         sConf = ServiceConf
-          { confSubscriptionExpiryTime = 12*3600 / fromIntegral speedup
+          { confSubscriptionExpiryTime = 24*3600 / fromIntegral speedup
           , confServicePort = read servicePortString
           , confServiceHost = confDomainString
           , confLogfilePath = "../simulationData/logs/" <> confDomainString <> ".log"

From eee40ce4fb7bd74fd0ebd8b9455a5cab22bcd5e5 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Thu, 17 Sep 2020 02:03:45 +0200
Subject: [PATCH 107/112] add log messages for failed relays as well

---
 src/Hash2Pub/PostService.hs | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs
index 75bdd33..ffeef17 100644
--- a/src/Hash2Pub/PostService.hs
+++ b/src/Hash2Pub/PostService.hs
@@ -12,14 +12,14 @@ import           Control.Concurrent
 import           Control.Concurrent.Async
 import           Control.Concurrent.STM
 import           Control.Exception         (Exception (..), try)
-import           Control.Monad             (foldM, forM, forM_, forever, void,
-                                            when)
+import           Control.Monad             (foldM, forM, forM_, forever, unless,
+                                            void, when)
 import           Control.Monad.IO.Class    (liftIO)
 import           Data.Bifunctor
 import qualified Data.ByteString.Lazy.UTF8 as BSUL
 import qualified Data.ByteString.UTF8      as BSU
 import qualified Data.DList                as D
-import           Data.Either               (rights)
+import           Data.Either               (lefts, rights)
 import qualified Data.HashMap.Strict       as HMap
 import qualified Data.HashSet              as HSet
 import           Data.Maybe                (fromJust, isJust)
@@ -57,8 +57,6 @@ data PostService d = PostService
     -- ^ for each tag store the subscribers + their queue
     , ownSubscriptions     :: TVar (HMap.HashMap NodeID POSIXTime)
     -- ^ tags subscribed by the own node have an assigned lease time
-    --, ownPosts             :: TVar (HSet.HashSet Text)
-    -- ^ just store the existence of posts for saving memory,
     , relayInQueue         :: TQueue (Hashtag, PostID, PostContent)
     -- ^ Queue for processing incoming posts of own instance asynchronously
     , postFetchQueue       :: TQueue PostID
@@ -325,6 +323,7 @@ tagSubscribe serv hashtag origin = do
     let leaseTime = now + confSubscriptionExpiryTime (serviceConf serv)
     -- setup subscription entry
     _ <- liftIO . atomically $ setupSubscriberChannel (subscribers serv) hashtag (BSU.toString $ HTTP.host req, HTTP.port req) leaseTime
+    --liftIO . putStrLn $ "just got a subscription to " <> Txt.unpack hashtag
     pure $ round leaseTime
 
 
@@ -427,10 +426,12 @@ clientSubscribeTo serv tag = do
                 Left (FailureResponse _ fresp)
                   |(HTTPT.statusCode . responseStatusCode $ fresp) == 410 && allowRetry -> do  -- responsibility gone, force new lookup
                       newRes <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
+                      --putStrLn $ "failed subscribing to " <> Txt.unpack tag <> " on " <> foundHost
                       doSubscribe newRes False
                 Left err    -> pure . Left . show $ err
                 Right lease -> do
                     atomically . modifyTVar' (ownSubscriptions serv) $ HMap.insert (hashtagToId tag) (fromInteger lease)
+                    --putStrLn $ "just subscribed to " <> Txt.unpack tag <> " on " <> foundHost
                     pure . Right $ lease
           )
           lookupResponse
@@ -735,7 +736,11 @@ relayWorker serv = forever $ do
     forM_ (chunksOf numParallelDeliveries jobsToProcess) $ \jobset -> do
         runningJobs <- mapM async jobset
         -- so far just dropping failed attempts, TODO: retry mechanism
-        successfulResults <- rights <$> mapM waitCatch runningJobs
+        results <- mapM waitCatch runningJobs
+        let
+            successfulResults =  rights results
+            unsuccessfulResults = lefts results
+        unless (null unsuccessfulResults) $ putStrLn ("ERR: " <> show (length unsuccessfulResults) <> " failed deliveries!")
         putStrLn $ "successfully relayed " <> show (length successfulResults)
         pure ()
 
@@ -829,7 +834,7 @@ evaluateStatsThread serv statsAcc = getPOSIXTime >>= loop
           -- evaluate stats rate and replace server stats
           -- persistently store in a TVar so it can be retrieved later by the DHT
           let timePassed = (now - previousTs) * fromIntegral (confSpeedupFactor $ serviceConf serv)
-          let rateStats = evaluateStats timePassed summedStats
+              rateStats = evaluateStats timePassed summedStats
           atomically $ writeTVar (loadStats serv) rateStats
           -- and now what? write a log to file
           -- format: total relayReceiveRates;total relayDeliveryRates;postFetchRate;postPublishRate; subscriberSum

From d8b21860166d4b6e894c32f92a2df94e2fb289f8 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 21 Sep 2020 22:14:33 +0200
Subject: [PATCH 108/112] make inclusion of HIE overlay conditional as well

---
 default.nix | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/default.nix b/default.nix
index cea4aa3..126975a 100644
--- a/default.nix
+++ b/default.nix
@@ -14,13 +14,13 @@ let
       name = "nixpkgs-pinned";
       url = https://github.com/NixOS/nixpkgs/;
       ref = "refs/heads/release-20.03";
-      rev = "de3780b937d2984f9b5e20d191f23be4f857b3aa";
+      rev = "faf5bdea5d9f0f9de26deaa7e864cdcd3b15b4e8";
     }) {
       # Pass no config for purity
           config = {};
-              overlays = [
+              overlays = if withHIE then [
                       (import all-hies {}).overlay
-                          ];
+                          ] else [];
     };
   hp = pkgs.haskell.packages."${compiler}";
   src = pkgs.nix-gitignore.gitignoreSource [] ./.;

From d7355aa04d1cd307a83e92ddf4689b4dda5f0627 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Tue, 22 Sep 2020 19:47:39 +0200
Subject: [PATCH 109/112] increase HTTP timeout for initial post publication to
 60 seconds

After a while, experiments made some publication events time-out.
Increasing the timeout just in case, although it i likely to be a mere symptom but the core fault.
---
 app/Experiment.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/app/Experiment.hs b/app/Experiment.hs
index a999dea..f2fa586 100644
--- a/app/Experiment.hs
+++ b/app/Experiment.hs
@@ -40,7 +40,7 @@ executeSchedule :: Int  -- ^ speedup factor
                 -> IO ()
 executeSchedule speedup events = do
     -- initialise HTTP manager
-    httpMan <- HTTP.newManager HTTP.defaultManagerSettings
+    httpMan <- HTTP.newManager $ HTTP.defaultManagerSettings { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro 60000000 }
     forM_ events $ \(delay, tag, (pubHost, pubPort)) -> do
         _ <- forkIO $
             clientPublishPost httpMan pubHost pubPort ("foobar #" <> tag)

From 9d8df6d3d8b82bd78565088bf01593250d7bdcc2 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 2 Oct 2020 02:36:02 +0200
Subject: [PATCH 110/112] make the multithread-runtime use all cores by default

---
 Hash2Pub.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index b343df3..1d3ac7f 100644
--- a/Hash2Pub.cabal
+++ b/Hash2Pub.cabal
@@ -91,7 +91,7 @@ executable Hash2Pub
   -- Base language which the package is written in.
   default-language:    Haskell2010
 
-  ghc-options:         -threaded
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
 
 executable Experiment
   -- experiment runner

From ea14ff9b09032a68814ccfa59c24d8f104975ae9 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 1 Jan 2021 14:30:33 +0100
Subject: [PATCH 111/112] update ghc to 8.6.4, nixpkgs base to 20.09

- relaxes some version constraints as dirty update quickfix
- removes hie integration as that project is abandoned, todo: switch to
  haskell-languageserver instead
---
 Hash2Pub.cabal |  2 +-
 default.nix    | 19 +++++--------------
 shell.nix      |  2 +-
 3 files changed, 7 insertions(+), 16 deletions(-)

diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal
index 1d3ac7f..376d675 100644
--- a/Hash2Pub.cabal
+++ b/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, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays, dlist, formatting
+  build-depends:       base >=4, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=3.1, time, cmdargs ^>= 0.10, cryptonite, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays, dlist, formatting
   ghc-options:         -Wall -Wpartial-fields -O2
 
 
diff --git a/default.nix b/default.nix
index 126975a..a3f7640 100644
--- a/default.nix
+++ b/default.nix
@@ -1,26 +1,18 @@
 {
-  compiler ? "ghc865",
-  withHIE ? false
+  compiler ? "ghc884"
 }:
 
 let
-  # pin all-hies for getting the language server
-  all-hies = fetchTarball {
-    url = "https://github.com/infinisil/all-hies/tarball/b8fb659620b99b4a393922abaa03a1695e2ca64d";
-    sha256 = "sha256:0br6wsqpfk1lzz90f7zw439w1ir2p54268qilw9l2pk6yz7ganfx";
-  };
   pkgs = import (
     builtins.fetchGit {
       name = "nixpkgs-pinned";
       url = https://github.com/NixOS/nixpkgs/;
-      ref = "refs/heads/release-20.03";
-      rev = "faf5bdea5d9f0f9de26deaa7e864cdcd3b15b4e8";
+      ref = "refs/heads/release-20.09";
+      rev = "e065200fc90175a8f6e50e76ef10a48786126e1c";
     }) {
       # Pass no config for purity
           config = {};
-              overlays = if withHIE then [
-                      (import all-hies {}).overlay
-                          ] else [];
+              overlays = [];
     };
   hp = pkgs.haskell.packages."${compiler}";
   src = pkgs.nix-gitignore.gitignoreSource [] ./.;
@@ -38,7 +30,6 @@ in
         hlint
         stylish-haskell
         pkgs.python3Packages.asn1ate
-      ]
-      ++ (if withHIE then [ hie ] else []);
+      ];
   };
 }
diff --git a/shell.nix b/shell.nix
index dafd212..82fb296 100644
--- a/shell.nix
+++ b/shell.nix
@@ -1 +1 @@
-(import ./default.nix {withHIE = true;}).shell
+(import ./default.nix {}).shell

From b46f66e2c0dff72cda7723f2344a0fc68f27c411 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Mon, 16 Aug 2021 20:12:53 +0200
Subject: [PATCH 112/112] update Readme with latest branch name and pointer to
 SocialHub

---
 Readme.md | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/Readme.md b/Readme.md
index daf9e38..e3cff3d 100644
--- a/Readme.md
+++ b/Readme.md
@@ -1,7 +1,7 @@
 # Hash2Pub
 
 ***This is heavily WIP and does not provide any useful functionality yet***.  
-I aim for always having the master branch at a state where it builds and tests pass.
+I aim for always having the `mainline` branch in a state where it builds and tests pass.
 
 A fully-decentralised relay for global hashtag federation in [ActivityPub](https://activitypub.rocks) based on a distributed hash table.
 It allows querying and subscribing to all posts of a certain hashtag and is implemented in Haskell.
@@ -10,6 +10,8 @@ This is the practical implementation of the concept presented in the paper [Dece
 
 The ASN.1 module schema used for DHT messages can be found in `FediChord.asn1`.
 
+For further questions and discussins, please refer to the **Hash2Pub topic in [SocialHub](https://socialhub.activitypub.rocks/c/software/hash2pub/48)**.
+
 ## Building
 
 The project and its developent environment are built with [Nix](https://nixos.org/nix/).