ae8a3ab31e
Hooked up everything that needs to notify on pushes. Note that syncNewRemote does not notify. This is probably ok, and I'd need to thread more state through to make it do so. This is only set up to support a single push notification method; I didn't use a NotificationBroadcaster. Partly because I don't yet know what info about pushes needs to be communicated, so my data types are only preliminary.
59 lines
1.8 KiB
Haskell
59 lines
1.8 KiB
Haskell
{- git-annex assistant push tracking
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.Pushes where
|
|
|
|
import Common.Annex
|
|
|
|
import Control.Concurrent.STM
|
|
import Control.Concurrent.MSampleVar
|
|
import Data.Time.Clock
|
|
import qualified Data.Map as M
|
|
|
|
{- Track the most recent push failure for each remote. -}
|
|
type PushMap = M.Map Remote UTCTime
|
|
type FailedPushMap = TMVar PushMap
|
|
|
|
{- Used to notify about successful pushes. -}
|
|
newtype PushNotifier = PushNotifier (MSampleVar ())
|
|
|
|
{- The TMVar starts empty, and is left empty when there are no
|
|
- failed pushes. This way we can block until there are some failed pushes.
|
|
-}
|
|
newFailedPushMap :: IO FailedPushMap
|
|
newFailedPushMap = atomically newEmptyTMVar
|
|
|
|
{- Blocks until there are failed pushes.
|
|
- Returns Remotes whose pushes failed a given time duration or more ago.
|
|
- (This may be an empty list.) -}
|
|
getFailedPushesBefore :: FailedPushMap -> NominalDiffTime -> IO [Remote]
|
|
getFailedPushesBefore v duration = do
|
|
m <- atomically $ readTMVar v
|
|
now <- getCurrentTime
|
|
return $ M.keys $ M.filter (not . toorecent now) m
|
|
where
|
|
toorecent now time = now `diffUTCTime` time < duration
|
|
|
|
{- Modifies the map. -}
|
|
changeFailedPushMap :: FailedPushMap -> (PushMap -> PushMap) -> IO ()
|
|
changeFailedPushMap v a = atomically $
|
|
store . a . fromMaybe M.empty =<< tryTakeTMVar v
|
|
where
|
|
{- tryTakeTMVar empties the TMVar; refill it only if
|
|
- the modified map is not itself empty -}
|
|
store m
|
|
| m == M.empty = noop
|
|
| otherwise = putTMVar v $! m
|
|
|
|
newPushNotifier :: IO PushNotifier
|
|
newPushNotifier = PushNotifier <$> newEmptySV
|
|
|
|
notifyPush :: PushNotifier -> IO ()
|
|
notifyPush (PushNotifier sv) = writeSV sv ()
|
|
|
|
waitPush :: PushNotifier -> IO ()
|
|
waitPush (PushNotifier sv) = readSV sv
|