From 04826ca938b2a785403bb8590385dadf0cdbf0b1 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Tue, 6 May 2014 15:25:48 -0300
Subject: reorg and add a start of a design for requests and ad-hoc routing
 with TTL in git-annex branch

---
 doc/design/requests_routing/simroutes.hs | 387 +++++++++++++++++++++++++++++++
 1 file changed, 387 insertions(+)
 create mode 100644 doc/design/requests_routing/simroutes.hs

(limited to 'doc/design/requests_routing')

diff --git a/doc/design/requests_routing/simroutes.hs b/doc/design/requests_routing/simroutes.hs
new file mode 100644
index 000000000..90ab03d40
--- /dev/null
+++ b/doc/design/requests_routing/simroutes.hs
@@ -0,0 +1,387 @@
+-- Simulation of non-flood syncing of content, across a network of nodes.
+
+module Main where
+
+import System.Random
+import Control.Monad.Random
+import Control.Monad
+import Control.Applicative
+import Data.Ratio
+import Data.Ord
+import Data.List
+import Data.Maybe
+import qualified Data.Set as S
+import qualified Data.Map.Strict as M
+
+{-
+ - Tunable values
+ -}
+
+totalFiles :: Int
+totalFiles = 100
+
+-- How likely is a given file to be wanted by any particular node?
+probabilityFilesWanted :: Probability
+probabilityFilesWanted = 0.10
+
+-- How many different locations can each transfer node move between?
+-- (Min, Max)
+transferDestinationsRange :: (Int, Int)
+transferDestinationsRange = (2, 3)
+
+-- Controls how likely transfer nodes are to move around in a given step
+-- of the simulation.
+-- (They actually move slightly less because they may start to move and
+-- pick the same location they are at.)
+-- (Min, Max)
+transferMoveFrequencyRange :: (Probability, Probability)
+transferMoveFrequencyRange = (0.10, 1.00)
+
+-- counts both immobile and transfer nodes as hops, so double Vince's
+-- theoretical TTL of 3.
+-- (30% loss on mocambos network w/o ttl of 4!)
+maxTTL :: TTL
+maxTTL = TTL (4 * 2)
+
+numImmobileNodes :: Int
+numImmobileNodes = 10
+
+numTransferNodes :: Int
+numTransferNodes = 20
+
+numSteps :: Int
+numSteps = 100
+
+-- IO code
+main :: IO ()
+main = do
+--	initialnetwork <- evalRandIO (seedFiles totalFiles =<< genNetwork)
+	initialnetwork <- evalRandIO (seedFiles totalFiles =<< mocambosNetwork)
+	networks <- evalRandIO (simulate numSteps initialnetwork)
+	let finalnetwork = last networks
+	putStrLn $ summarize initialnetwork finalnetwork
+	putStrLn "location history of file 1:"
+	print $ trace (traceHaveFile (File 1)) networks
+	putStrLn "request history of file 1:"
+	print $ trace (traceWantFile (File 1)) networks
+-- Only pure code below :)
+
+data Network = Network (M.Map NodeName ImmobileNode) [TransferNode]
+	deriving (Show, Eq)
+
+data ImmobileNode = ImmobileNode NodeRepo
+	deriving (Show, Eq)
+
+type NodeName = String
+
+type Route = [NodeName]
+
+data TransferNode = TransferNode
+	{ currentlocation :: NodeName
+	, possiblelocations :: [NodeName]
+	, movefrequency :: Probability
+	, transferrepo :: NodeRepo
+	}
+	deriving (Show, Eq)
+
+data NodeRepo = NodeRepo
+	{ wantFiles :: [Request]
+	, haveFiles :: S.Set File
+	}
+	deriving (Show, Eq)
+
+data File = File Int
+	deriving (Show, Eq, Ord)
+
+randomFile :: (RandomGen g) => Rand g File
+randomFile = File <$> getRandomR (0, totalFiles)
+
+data Request = Request File TTL
+	deriving (Show)
+
+-- compare ignoring TTL
+instance Eq Request where
+	(Request f1 _) == (Request f2 _) = f1 == f2
+
+requestedFile :: Request -> File
+requestedFile (Request f _) = f
+
+requestTTL :: Request -> TTL
+requestTTL (Request _ ttl) = ttl
+
+data TTL = TTL Int
+	deriving (Show, Eq, Ord)
+
+incTTL :: TTL -> TTL
+incTTL (TTL t) = TTL (t + 1)
+
+decTTL :: TTL -> TTL
+decTTL (TTL t) = TTL (t - 1)
+
+staleTTL :: TTL -> Bool
+staleTTL (TTL t) = t < 1
+
+-- Origin of a request starts one higher than max, since the TTL
+-- will decrement the first time the Request is transferred to another node.
+originTTL :: TTL
+originTTL = incTTL maxTTL
+
+randomRequest :: (RandomGen g) => Rand g Request
+randomRequest = Request
+	<$> randomFile
+	<*> pure originTTL
+
+type Probability = Float
+
+randomProbability :: (RandomGen g) => Rand g Probability
+randomProbability = getRandomR (0, 1)
+
+-- Returns the state of the network at each step of the simulation.
+simulate :: (RandomGen g) => Int -> Network -> Rand g [Network]
+simulate n net = go n [net]
+  where
+	go 0 nets = return (reverse nets)
+	go c (prev:nets) = do
+		new <- step prev
+		go (c - 1) (new:prev:nets)
+
+-- Each step of the simulation, check if each TransferNode wants to move,
+-- and if so:
+--   1. It and its current location exchange their Requests.
+--   2. And they exchange any requested files.
+--   3. Move it to a new random location.
+--
+-- Note: This implementation does not exchange requests between two
+-- TransferNodes that both arrive at the same location at the same step,
+-- and then move away in the next step.
+step :: (RandomGen g) => Network -> Rand g Network
+step (Network immobiles transfers) = go immobiles [] transfers
+  where
+	go is c [] = return (Network is c)
+	go is c (t:ts) = do
+		r <- randomProbability
+		if movefrequency t <= r
+			then case M.lookup (currentlocation t) is of
+				Nothing -> go is (c ++ [t]) ts
+				Just currentloc -> do
+					let (currentloc', t') = exchangeRequestsFiles currentloc t
+					t'' <- move t'
+					go (M.insert (currentlocation t) currentloc' is) (c ++ [t'']) ts
+			else go is (c ++ [t]) ts
+
+type Exchanger = ImmobileNode -> TransferNode -> (ImmobileNode, TransferNode)
+
+exchangeRequestsFiles :: Exchanger
+exchangeRequestsFiles (ImmobileNode ir) t@(TransferNode { transferrepo = tr }) =
+	( ImmobileNode (go ir tr)
+	, t { transferrepo = go tr ir }
+	)
+  where
+	go r1 r2 = r1
+		{ wantFiles = foldr addRequest (wantFiles r1) (wantFiles r2)
+		, haveFiles = S.foldr (addFile (wantFiles r1)) (haveFiles r1) (haveFiles r2)
+		}
+
+-- Adds a file to the set, when there's a request for it.
+addFile :: [Request] -> File -> S.Set File -> S.Set File
+addFile rs f fs
+	| any (\r -> f == requestedFile r) rs = S.insert f fs
+	| otherwise = fs
+
+-- Decrements TTL, and avoids adding request with a stale TTL, or a
+-- request for an already added file with the same or a lower TTL.
+addRequest :: Request -> [Request] -> [Request]
+addRequest (Request f ttl) rs
+	| staleTTL ttl' = rs
+	| any (\r -> requestTTL r >= ttl) similar = rs
+	| otherwise = r' : other
+  where
+	ttl' = decTTL ttl
+	r' = Request f ttl'
+	(other, similar) = partition (/= r') rs
+
+move :: (RandomGen g) => TransferNode -> Rand g TransferNode
+move t = do
+	newloc <- randomfrom (possiblelocations t)
+	return $ t { currentlocation = newloc }
+
+genNetwork :: (RandomGen g) => Rand g Network
+genNetwork = do
+	let immobiles = M.fromList (zip (map show [1..]) (replicate numImmobileNodes emptyImmobile))
+	transfers <- sequence (replicate numTransferNodes (mkTransfer $ M.keys immobiles))
+	return $ Network immobiles transfers
+
+emptyImmobile :: ImmobileNode
+emptyImmobile = ImmobileNode (NodeRepo [] S.empty)
+
+mkTransfer :: (RandomGen g) => [NodeName] -> Rand g TransferNode
+mkTransfer immobiles = do
+  	-- Transfer nodes are given random routes. May be simplistic.
+	-- Also, some immobile nodes will not be serviced by any transfer nodes.
+	numpossiblelocs <- getRandomR transferDestinationsRange
+	possiblelocs <- sequence (replicate numpossiblelocs (randomfrom immobiles))
+	mkTransferBetween possiblelocs
+
+mkTransferBetween :: (RandomGen g) => [NodeName] -> Rand g TransferNode
+mkTransferBetween possiblelocs = do
+	currentloc <- randomfrom possiblelocs
+	movefreq <- getRandomR transferMoveFrequencyRange
+	-- transfer nodes start out with no files or requests in their repo
+	let repo = (NodeRepo [] S.empty)
+	return $ TransferNode currentloc possiblelocs movefreq repo
+
+randomfrom :: (RandomGen g) => [a] -> Rand g a
+randomfrom l = do
+	i <- getRandomR (1, length l)
+	return $ l !! (i - 1)
+
+-- Seeds the network with the given number of files. Each file is added to
+-- one of the immobile nodes of the network at random. And, one other node,
+-- at random, is selected which wants to get the file.
+seedFiles :: (RandomGen g) => Int -> Network -> Rand g Network
+seedFiles 0 network = return network
+seedFiles n network@(Network m t) = do
+	(origink, ImmobileNode originr) <- randnode
+	(destinationk, ImmobileNode destinationr) <- randnode
+	let file = File n
+	let origin = ImmobileNode $ originr
+		{ haveFiles = S.insert file (haveFiles originr) }
+	let destination = ImmobileNode $ destinationr
+		{ wantFiles = Request file originTTL : wantFiles destinationr }
+	let m' = M.insert origink origin $
+		M.insert destinationk destination m
+	seedFiles (n - 1) (Network m' t)
+  where
+	randnode = do
+		k <- randomfrom (M.keys m)
+		return (k, fromJust $ M.lookup k m)
+
+summarize :: Network -> Network -> String
+summarize _initial@(Network origis _) _final@(Network is _ts) = format
+	[ ("Total wanted files",
+		show (sum (overis (length . findoriginreqs . wantFiles . repo))))
+	, ("Wanted files that were not transferred to requesting node",
+		show (sum (overis (S.size . findunsatisfied . repo))))
+	, ("Nodes that failed to get files",
+		show (map withinitiallocs $ filter (not . S.null . snd)
+			(M.toList $ M.map (findunsatisfied . repo) is)))
+	--, ("Immobile nodes at end", show is)
+	]
+  where
+  	findoriginreqs = filter (\r -> requestTTL r == originTTL)
+	findunsatisfied r = 
+		let wantedfs = S.fromList $ map requestedFile (findoriginreqs (wantFiles r))
+		in S.difference wantedfs (haveFiles r)
+	repo (ImmobileNode r) = r
+	overis f = map f $ M.elems is
+	format = unlines . map (\(d, s) -> d ++ ": " ++ s)
+
+	withinitiallocs (name, missingfiles) = (name, S.map addinitialloc missingfiles)
+	addinitialloc f = (f, M.lookup f initiallocs)
+
+	initiallocs = M.fromList $ 
+		concatMap (\(k, v) -> map (\f -> (f, k)) (S.toList $ haveFiles $ repo v)) $
+			M.toList origis
+
+trace :: (Network -> S.Set NodeName) -> [Network] -> String
+trace tracer networks = show $ go [] S.empty $ map tracer networks
+  where
+	go c old [] = reverse c
+	go c old (new:l) = go ((S.toList $ new `S.difference` old):c) new l
+
+traceHaveFile :: File -> Network -> S.Set NodeName
+traceHaveFile f (Network m _) = S.fromList $ M.keys $
+	M.filter (\(ImmobileNode r) -> f `S.member` haveFiles r) m 
+
+traceWantFile :: File -> Network -> S.Set NodeName
+traceWantFile f (Network m _) = S.fromList $ M.keys $
+	M.filter (\(ImmobileNode r) -> any wantf (wantFiles r)) m 
+  where
+	wantf (Request rf _ttl) = rf == f
+
+mocambosNetwork :: (RandomGen g) => Rand g Network
+mocambosNetwork = do
+	let major = map (immobilenamed . fst) communities
+	let minor = map immobilenamed (concatMap snd communities)
+	majortransfer <- mapM mkTransferBetween majorroutes
+	minortransfer <- mapM mkTransferBetween (concatMap minorroutes (concat (replicate 5 communities)))
+	return $ Network
+		(M.fromList (major++minor))
+		(majortransfer ++ minortransfer)
+  where
+	immobilenamed name = (name, emptyImmobile)
+
+	-- As a simplification, this only makes 2 hop routes, between minor
+	-- and major communities; no 3-legged routes.
+	minorroutes :: (NodeName, [NodeName]) -> [Route]
+	minorroutes (major, minors) = map (\n -> [major, n]) minors
+
+communities :: [(NodeName, [NodeName])]
+communities =
+	[ ("Tainá/SP",
+		[ "badtas"
+		, "vauedo ribera"
+		, "cofundo"
+		, "jao"
+		, "fazenda"
+		]
+	  )
+	, ("Odomode/RS",
+		[ "moradadapaz"
+		, "pelotas" 
+		]
+	  )
+	, ("MercadoSul/DF",
+		[ "mesquito"
+		, "kalungos"
+		]
+	  )
+	, ("Coco/PE",
+		[ "xambá"
+		, "alafin"
+		, "terreiaos"
+		]
+	  )
+	, ("Linharinho/ES",
+		[ "monte alegne"
+		]
+	  )
+	, ("Boneco/BA",
+		[ "barroso"
+		, "lagoa santa"
+		, "terravista"
+		]
+	  )
+	, ("Zumbidospalmanes/NA",
+		[ "allantana"
+		]
+	  )
+	, ("Casa Pneta/PA",
+		[ "marajó"
+		]
+	  )
+	, ("Purarue/PA",
+		[ "oriaminá"
+		]
+	  )
+	, ("Madiba/NET", [])
+	]
+
+majorroutes :: [Route]
+majorroutes =
+	-- person's routes
+	[ ["Tainá/SP", "Odomode/RS"]
+	, ["Tainá/SP", "MercadoSul/DF"]
+	, ["MercadoSul/DF", "Boneco/BA"]
+	, ["MercadoSul/DF", "Zumbidospalmanes/NA"]
+	, ["Zumbidospalmanes/NA", "Casa Pneta/PA"]
+	, ["Casa Pneta/PA", "Purarue/PA"]
+	, ["Casa Pneta/PA", "Linharinho/ES"]
+	, ["Boneco/BA", "Coco/PE"]
+	-- internet connections
+	, ["Tainá/SP", "MercadoSul/DF", "Coco/PE", "Purarue/PA", "Odomode/RS", "Madiba/NET"]
+	, ["Tainá/SP", "MercadoSul/DF", "Coco/PE", "Purarue/PA", "Odomode/RS", "Madiba/NET"]
+	, ["Tainá/SP", "MercadoSul/DF", "Coco/PE", "Purarue/PA", "Odomode/RS", "Madiba/NET"]
+	, ["Tainá/SP", "MercadoSul/DF", "Coco/PE", "Purarue/PA", "Odomode/RS", "Madiba/NET"]
+	, ["Tainá/SP", "MercadoSul/DF", "Coco/PE", "Purarue/PA", "Odomode/RS", "Madiba/NET"]
+	]
-- 
cgit v1.2.3