diff options
Diffstat (limited to 'Assistant')
-rw-r--r-- | Assistant/Changes.hs | 25 | ||||
-rw-r--r-- | Assistant/Commits.hs | 32 | ||||
-rw-r--r-- | Assistant/Committer.hs | 6 | ||||
-rw-r--r-- | Assistant/Syncer.hs | 29 | ||||
-rw-r--r-- | Assistant/ThreadedMonad.hs | 3 | ||||
-rw-r--r-- | Assistant/Watcher.hs | 4 |
6 files changed, 77 insertions, 22 deletions
diff --git a/Assistant/Changes.hs b/Assistant/Changes.hs index 173ba1922..47eae83ef 100644 --- a/Assistant/Changes.hs +++ b/Assistant/Changes.hs @@ -8,14 +8,14 @@ module Assistant.Changes where import Common.Annex import qualified Annex.Queue import Types.KeySource +import Utility.TSet -import Control.Concurrent.STM import Data.Time.Clock data ChangeType = AddChange | LinkChange | RmChange | RmDirChange deriving (Show, Eq) -type ChangeChan = TChan Change +type ChangeChan = TSet Change data Change = Change @@ -29,11 +29,8 @@ data Change } deriving (Show) -runChangeChan :: STM a -> IO a -runChangeChan = atomically - newChangeChan :: IO ChangeChan -newChangeChan = atomically newTChan +newChangeChan = newTSet {- Handlers call this when they made a change that needs to get committed. -} madeChange :: FilePath -> ChangeType -> Annex (Maybe Change) @@ -65,17 +62,13 @@ finishedChange c = c {- Gets all unhandled changes. - Blocks until at least one change is made. -} getChanges :: ChangeChan -> IO [Change] -getChanges chan = runChangeChan $ do - c <- readTChan chan - go [c] - where - go l = do - v <- tryReadTChan chan - case v of - Nothing -> return l - Just c -> go (c:l) +getChanges = getTSet {- Puts unhandled changes back into the channel. - Note: Original order is not preserved. -} refillChanges :: ChangeChan -> [Change] -> IO () -refillChanges chan cs = runChangeChan $ mapM_ (writeTChan chan) cs +refillChanges = putTSet + +{- Records a change in the channel. -} +recordChange :: ChangeChan -> Change -> IO () +recordChange = putTSet1 diff --git a/Assistant/Commits.hs b/Assistant/Commits.hs new file mode 100644 index 000000000..152544e7c --- /dev/null +++ b/Assistant/Commits.hs @@ -0,0 +1,32 @@ +{- git-annex assistant commit tracking + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + -} + +module Assistant.Commits where + +import Utility.TSet + +import Data.Time.Clock + +type CommitChan = TSet Commit + +data Commit = Commit UTCTime + deriving (Show) + +newCommitChan :: IO CommitChan +newCommitChan = newTSet + +{- Gets all unhandled commits. + - Blocks until at least one commit is made. -} +getCommits :: CommitChan -> IO [Commit] +getCommits = getTSet + +{- Puts unhandled commits back into the channel. + - Note: Original order is not preserved. -} +refillCommits :: CommitChan -> [Commit] -> IO () +refillCommits = putTSet + +{- Records a commit in the channel. -} +recordCommit :: CommitChan -> Commit -> IO () +recordCommit = putTSet1 diff --git a/Assistant/Committer.hs b/Assistant/Committer.hs index 63df8cafc..acdee1408 100644 --- a/Assistant/Committer.hs +++ b/Assistant/Committer.hs @@ -7,6 +7,7 @@ module Assistant.Committer where import Common.Annex import Assistant.Changes +import Assistant.Commits import Assistant.ThreadedMonad import Assistant.Watcher import qualified Annex @@ -26,8 +27,8 @@ import qualified Data.Set as S import Data.Either {- This thread makes git commits at appropriate times. -} -commitThread :: ThreadState -> ChangeChan -> IO () -commitThread st changechan = runEvery (Seconds 1) $ do +commitThread :: ThreadState -> ChangeChan -> CommitChan -> IO () +commitThread st changechan commitchan = runEvery (Seconds 1) $ do -- We already waited one second as a simple rate limiter. -- Next, wait until at least one change is available for -- processing. @@ -40,6 +41,7 @@ commitThread st changechan = runEvery (Seconds 1) $ do if shouldCommit time readychanges then do void $ tryIO $ runThreadState st commitStaged + recordCommit commitchan (Commit time) else refillChanges changechan readychanges else refillChanges changechan changes diff --git a/Assistant/Syncer.hs b/Assistant/Syncer.hs new file mode 100644 index 000000000..059859c07 --- /dev/null +++ b/Assistant/Syncer.hs @@ -0,0 +1,29 @@ +{- git-annex assistant git syncing thread + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + -} + +module Assistant.Syncer where + +import Assistant.Commits +import Assistant.ThreadedMonad +import qualified Command.Sync +import Utility.ThreadScheduler + +{- This thread syncs git commits out to remotes. -} +syncThread :: ThreadState -> CommitChan -> IO () +syncThread st commitchan = 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 commitchan + -- Now see if now's a good time to sync. + if shouldSync commits + then syncToRemotes + else refillCommits commitchan commits + +{- Decide if now is a good time to sync commits to remotes. -} +shouldSync :: [Commit] -> Bool +shouldSync commits = not (null commits) + +syncToRemotes :: IO () +syncToRemotes = return () -- TOOD diff --git a/Assistant/ThreadedMonad.hs b/Assistant/ThreadedMonad.hs index 51f579d07..91a311dee 100644 --- a/Assistant/ThreadedMonad.hs +++ b/Assistant/ThreadedMonad.hs @@ -32,7 +32,8 @@ withThreadState a = do {- Runs an Annex action, using the state from the MVar. - - - This serializes calls by threads. -} + - This serializes calls by threads; only one thread can run in Annex at a + - time. -} runThreadState :: ThreadState -> Annex a -> IO a runThreadState mvar a = do startstate <- takeMVar mvar diff --git a/Assistant/Watcher.hs b/Assistant/Watcher.hs index db58f01e8..78330c8d0 100644 --- a/Assistant/Watcher.hs +++ b/Assistant/Watcher.hs @@ -27,7 +27,6 @@ import Annex.Content import Annex.CatFile import Git.Types -import Control.Concurrent.STM import Data.Bits.Utils import qualified Data.ByteString.Lazy as L @@ -96,8 +95,7 @@ runHandler st dstatus changechan handler file filestatus = void $ do case r of Left e -> print e Right Nothing -> noop - Right (Just change) -> void $ - runChangeChan $ writeTChan changechan change + Right (Just change) -> recordChange changechan change where go = runThreadState st $ handler file filestatus dstatus |