summaryrefslogtreecommitdiff
path: root/Assistant/Changes.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-06-19 02:40:21 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-06-19 02:40:21 -0400
commit57cf65eb6d811ba7fd19eb62a54e3b83a0c2dfa7 (patch)
tree7711cef2d303fc485185f636c0e364e4f9cee0c5 /Assistant/Changes.hs
parent4ab9449cee0cb1377a768b44fe832282ac1f88b9 (diff)
fix kevent symlink creation
Diffstat (limited to 'Assistant/Changes.hs')
-rw-r--r--Assistant/Changes.hs59
1 files changed, 59 insertions, 0 deletions
diff --git a/Assistant/Changes.hs b/Assistant/Changes.hs
new file mode 100644
index 000000000..1cad42326
--- /dev/null
+++ b/Assistant/Changes.hs
@@ -0,0 +1,59 @@
+{- git-annex assistant change tracking
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -}
+
+module Assistant.Changes where
+
+import Common.Annex
+import qualified Annex.Queue
+
+import Control.Concurrent.STM
+import Data.Time.Clock
+
+data ChangeType = PendingAddChange | LinkChange | RmChange | RmDirChange
+ deriving (Show, Eq)
+
+type ChangeChan = TChan Change
+
+data Change = Change
+ { changeTime :: UTCTime
+ , changeFile :: FilePath
+ , changeType :: ChangeType
+ }
+ deriving (Show)
+
+runChangeChan :: STM a -> IO a
+runChangeChan = atomically
+
+newChangeChan :: IO ChangeChan
+newChangeChan = atomically newTChan
+
+{- Handlers call this when they made a change that needs to get committed. -}
+madeChange :: FilePath -> ChangeType -> Annex (Maybe Change)
+madeChange f t = do
+ -- Just in case the commit thread is not flushing the queue fast enough.
+ when (t /= PendingAddChange) $
+ Annex.Queue.flushWhenFull
+ liftIO $ Just <$> (Change <$> getCurrentTime <*> pure f <*> pure t)
+
+noChange :: Annex (Maybe Change)
+noChange = return Nothing
+
+{- 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)
+
+{- 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