diff options
| -rw-r--r-- | Assistant/Commits.hs | 11 | ||||
| -rw-r--r-- | Assistant/Threads/Pusher.hs | 19 | ||||
| -rw-r--r-- | Assistant/Types/Commits.hs | 6 | ||||
| -rw-r--r-- | Utility/TSet.hs | 41 |
4 files changed, 8 insertions, 69 deletions
diff --git a/Assistant/Commits.hs b/Assistant/Commits.hs index f4e908e0d..7d1d3780f 100644 --- a/Assistant/Commits.hs +++ b/Assistant/Commits.hs @@ -9,20 +9,15 @@ module Assistant.Commits where import Assistant.Common import Assistant.Types.Commits -import Utility.TSet +import Utility.TList import Control.Concurrent.STM {- Gets all unhandled commits. - Blocks until at least one commit is made. -} getCommits :: Assistant [Commit] -getCommits = (atomically . getTSet) <<~ commitChan - -{- Puts unhandled commits back into the channel. - - Note: Original order is not preserved. -} -refillCommits :: [Commit] -> Assistant () -refillCommits cs = (atomically . flip putTSet cs) <<~ commitChan +getCommits = (atomically . getTList) <<~ commitChan {- Records a commit in the channel. -} recordCommit :: Assistant () -recordCommit = (atomically . flip putTSet1 Commit) <<~ commitChan +recordCommit = (atomically . flip consTList Commit) <<~ commitChan diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index e90cca1ec..57595b8c1 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -33,13 +33,9 @@ pushThread :: NamedThread pushThread = namedThread "Pusher" $ runEvery (Seconds 2) <~> do -- We already waited two seconds as a simple rate limiter. -- Next, wait until at least one commit has been made - commits <- getCommits + void getCommits -- Now see if now's a good time to push. - if shouldPush commits - then void $ pushToRemotes True =<< pushTargets - else do - debug ["delaying push of", show (length commits), "commits"] - refillCommits commits + void $ pushToRemotes True =<< pushTargets {- We want to avoid pushing to remotes that are marked readonly. - @@ -51,14 +47,3 @@ pushTargets = liftIO . filterM available =<< candidates <$> getDaemonStatus where candidates = filter (not . Remote.readonly) . syncGitRemotes available = maybe (return True) doesDirectoryExist . Remote.localpath - -{- Decide if now is a good time to push to remotes. - - - - Current strategy: Immediately push all commits. The commit machinery - - already determines batches of changes, so we can't easily determine - - batches better. - -} -shouldPush :: [Commit] -> Bool -shouldPush commits - | not (null commits) = True - | otherwise = False diff --git a/Assistant/Types/Commits.hs b/Assistant/Types/Commits.hs index 12dab8da8..500faa901 100644 --- a/Assistant/Types/Commits.hs +++ b/Assistant/Types/Commits.hs @@ -7,13 +7,13 @@ module Assistant.Types.Commits where -import Utility.TSet +import Utility.TList import Control.Concurrent.STM -type CommitChan = TSet Commit +type CommitChan = TList Commit data Commit = Commit newCommitChan :: IO CommitChan -newCommitChan = atomically newTSet +newCommitChan = atomically newTList diff --git a/Utility/TSet.hs b/Utility/TSet.hs deleted file mode 100644 index c5ee22c89..000000000 --- a/Utility/TSet.hs +++ /dev/null @@ -1,41 +0,0 @@ -{- Transactional sets - - - - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> - -} - -module Utility.TSet where - -import Common - -import Control.Concurrent.STM - -type TSet = TChan - -newTSet :: STM (TSet a) -newTSet = newTChan - -{- Gets the contents of the TSet. Blocks until at least one item is - - present. -} -getTSet :: TSet a -> STM [a] -getTSet tset = do - c <- readTChan tset - l <- readTSet tset - return $ c:l - -{- Gets anything currently in the TSet, without blocking. -} -readTSet :: TSet a -> STM [a] -readTSet tset = go [] - where - go l = do - v <- tryReadTChan tset - case v of - Nothing -> return l - Just c -> go (c:l) - -{- Puts items into a TSet. -} -putTSet :: TSet a -> [a] -> STM () -putTSet tset vs = mapM_ (writeTChan tset) vs - -{- Put a single item into a TSet. -} -putTSet1 :: TSet a -> a -> STM () -putTSet1 tset v = void $ writeTChan tset v |