keep track of satisfied requests, and summarize

This commit is contained in:
Joey Hess 2014-05-09 16:41:05 -03:00
parent 4a99d835ba
commit 6abc6fe9d6
2 changed files with 33 additions and 13 deletions

View file

@ -90,6 +90,11 @@ For a node that only transfers files between the immobile nodes:
requestedby=1 requestedby=1
For an immobile node that only accumulates files it requests, but never
stores files requested by other nodes:
present or requested
TODO: Would be nice to be able to prioritize files that more nodes are TODO: Would be nice to be able to prioritize files that more nodes are
requesting, or that have some urgent flag set. But currently there is no requesting, or that have some urgent flag set. But currently there is no
way to do that; content is either preferred or not preferred. way to do that; content is either preferred or not preferred.

View file

@ -87,6 +87,7 @@ data TransferNode = TransferNode
data NodeRepo = NodeRepo data NodeRepo = NodeRepo
{ wantFiles :: [Request] { wantFiles :: [Request]
, haveFiles :: S.Set File , haveFiles :: S.Set File
, satisfiedRequests :: S.Set Request
} }
deriving (Show, Eq) deriving (Show, Eq)
@ -97,7 +98,7 @@ randomFile :: (RandomGen g) => Rand g File
randomFile = File <$> getRandomR (0, totalFiles) randomFile = File <$> getRandomR (0, totalFiles)
data Request = Request File TTL data Request = Request File TTL
deriving (Show) deriving (Show, Ord)
-- compare ignoring TTL -- compare ignoring TTL
instance Eq Request where instance Eq Request where
@ -164,30 +165,42 @@ step (Network immobiles transfers) = go immobiles [] transfers
then case M.lookup (currentlocation t) is of then case M.lookup (currentlocation t) is of
Nothing -> go is (c ++ [t]) ts Nothing -> go is (c ++ [t]) ts
Just currentloc -> do Just currentloc -> do
let (currentloc', t') = exchangeRequestsFiles currentloc t let (currentloc', t') = merge currentloc t
t'' <- move t' t'' <- move t'
go (M.insert (currentlocation t) currentloc' is) (c ++ [t'']) ts go (M.insert (currentlocation t) currentloc' is) (c ++ [t'']) ts
else go is (c ++ [t]) ts else go is (c ++ [t]) ts
type Exchanger = ImmobileNode -> TransferNode -> (ImmobileNode, TransferNode) merge :: ImmobileNode -> TransferNode -> (ImmobileNode, TransferNode)
merge (ImmobileNode ir) t@(TransferNode { transferrepo = tr }) =
exchangeRequestsFiles :: Exchanger
exchangeRequestsFiles (ImmobileNode ir) t@(TransferNode { transferrepo = tr }) =
( ImmobileNode (go ir tr) ( ImmobileNode (go ir tr)
, t { transferrepo = go tr ir } , t { transferrepo = go tr ir }
) )
where where
go r1 r2 = r1 go r1 r2 = r1
{ wantFiles = foldr addRequest (wantFiles r1) (wantFiles r2) { wantFiles = wantFiles'
, haveFiles = S.foldr (addFile (wantFiles r1)) (haveFiles r1) (haveFiles r2) , haveFiles = haveFiles'
, satisfiedRequests = satisfiedRequests' `S.union` checkSatisfied wantFiles' haveFiles'
} }
where
wantFiles' = foldr addRequest (wantFiles r1) (wantFiles r2)
haveFiles' = S.foldr (addFile wantFiles' satisfiedRequests') (haveFiles r1) (haveFiles r2)
satisfiedRequests' = satisfiedRequests r1 `S.union` satisfiedRequests r2
-- Adds a file to the set, when there's a request for it. -- Adds a file to the set, when there's a request for it, and the request
addFile :: [Request] -> File -> S.Set File -> S.Set File -- has not already been satisfied.
addFile rs f fs addFile :: [Request] -> S.Set Request -> File -> S.Set File -> S.Set File
addFile rs srs f fs
| any (\sr -> f == requestedFile sr) (S.toList srs) = fs
| any (\r -> f == requestedFile r) rs = S.insert f fs | any (\r -> f == requestedFile r) rs = S.insert f fs
| otherwise = fs | otherwise = fs
-- Checks if any requests have been satisfied, and returns them,
-- to be added to satisfidRequests
checkSatisfied :: [Request] -> S.Set File -> S.Set Request
checkSatisfied want have = S.fromList (filter satisfied want)
where
satisfied r = requestTTL r == originTTL && S.member (requestedFile r) have
-- Decrements TTL, and avoids adding request with a stale TTL, or a -- 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. -- request for an already added file with the same or a lower TTL.
addRequest :: Request -> [Request] -> [Request] addRequest :: Request -> [Request] -> [Request]
@ -212,7 +225,7 @@ genNetwork = do
return $ Network immobiles transfers return $ Network immobiles transfers
emptyImmobile :: ImmobileNode emptyImmobile :: ImmobileNode
emptyImmobile = ImmobileNode (NodeRepo [] S.empty) emptyImmobile = ImmobileNode (NodeRepo [] S.empty S.empty)
mkTransfer :: (RandomGen g) => [NodeName] -> Rand g TransferNode mkTransfer :: (RandomGen g) => [NodeName] -> Rand g TransferNode
mkTransfer immobiles = do mkTransfer immobiles = do
@ -227,7 +240,7 @@ mkTransferBetween possiblelocs = do
currentloc <- randomfrom possiblelocs currentloc <- randomfrom possiblelocs
movefreq <- getRandomR transferMoveFrequencyRange movefreq <- getRandomR transferMoveFrequencyRange
-- transfer nodes start out with no files or requests in their repo -- transfer nodes start out with no files or requests in their repo
let repo = (NodeRepo [] S.empty) let repo = (NodeRepo [] S.empty S.empty)
return $ TransferNode currentloc possiblelocs movefreq repo return $ TransferNode currentloc possiblelocs movefreq repo
randomfrom :: (RandomGen g) => [a] -> Rand g a randomfrom :: (RandomGen g) => [a] -> Rand g a
@ -265,6 +278,8 @@ summarize _initial@(Network origis _) _final@(Network is _ts) = format
, ("Nodes that failed to get files", , ("Nodes that failed to get files",
show (map withinitiallocs $ filter (not . S.null . snd) show (map withinitiallocs $ filter (not . S.null . snd)
(M.toList $ M.map (findunsatisfied . repo) is))) (M.toList $ M.map (findunsatisfied . repo) is)))
, ("Total number of files on immobile nodes at end",
show (overis (S.size . haveFiles . repo)))
--, ("Immobile nodes at end", show is) --, ("Immobile nodes at end", show is)
] ]
where where