diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -11,7 +11,7 @@ *.tix .hpc Utility/Touch.hs -Utility/libdiskfree.o +Utility/*.o dist # Sandboxed builds cabal-dev diff --git a/.make-sdist.sh.swo b/.make-sdist.sh.swo deleted file mode 100644 Binary files a/.make-sdist.sh.swo and /dev/null differ diff --git a/.make-sdist.sh.swp b/.make-sdist.sh.swp deleted file mode 100644 Binary files a/.make-sdist.sh.swp and /dev/null differ diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -14,6 +14,7 @@ newState, run, eval, + exec, getState, changeState, setFlag, @@ -134,6 +135,8 @@ run s a = runStateT (runAnnex a) s eval :: AnnexState -> Annex a -> IO a eval s a = evalStateT (runAnnex a) s +exec :: AnnexState -> Annex a -> IO AnnexState +exec s a = execStateT (runAnnex a) s {- Sets a flag to True -} setFlag :: String -> Annex () diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -35,6 +35,8 @@ import qualified Git.UnionMerge import qualified Git.UpdateIndex import Git.HashObject +import Git.Types +import Git.FilePath import qualified Git.Index import Annex.CatFile import Annex.Perms @@ -66,7 +68,7 @@ {- Creates the branch, if it does not already exist. -} create :: Annex () -create = void $ getBranch +create = void getBranch {- Returns the ref of the branch, creating it first if necessary. -} getBranch :: Annex Git.Ref @@ -259,15 +261,15 @@ - in changes from other branches. -} genIndex :: Git.Repo -> IO () -genIndex g = Git.UpdateIndex.stream_update_index g - [Git.UpdateIndex.ls_tree fullname g] +genIndex g = Git.UpdateIndex.streamUpdateIndex g + [Git.UpdateIndex.lsTree fullname g] {- Merges the specified refs into the index. - Any changes staged in the index will be preserved. -} mergeIndex :: [Git.Ref] -> Annex () mergeIndex branches = do h <- catFileHandle - inRepo $ \g -> Git.UnionMerge.merge_index h g branches + inRepo $ \g -> Git.UnionMerge.mergeIndex h g branches {- Runs an action using the branch's index file. -} withIndex :: Annex a -> Annex a @@ -336,13 +338,13 @@ g <- gitRepo withIndex $ liftIO $ do h <- hashObjectStart g - Git.UpdateIndex.stream_update_index g + Git.UpdateIndex.streamUpdateIndex g [genstream (gitAnnexJournalDir g) h fs] hashObjectStop h where genstream dir h fs streamer = forM_ fs $ \file -> do let path = dir file sha <- hashFile h path - _ <- streamer $ Git.UpdateIndex.update_index_line - sha (fileJournal file) + _ <- streamer $ Git.UpdateIndex.updateIndexLine + sha FileBlob (asTopFilePath $ fileJournal file) removeFile path diff --git a/Annex/CatFile.hs b/Annex/CatFile.hs --- a/Annex/CatFile.hs +++ b/Annex/CatFile.hs @@ -8,15 +8,17 @@ module Annex.CatFile ( catFile, catObject, + catObjectDetails, catFileHandle ) where -import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString.Lazy as L import Common.Annex import qualified Git import qualified Git.CatFile import qualified Annex +import Git.Types catFile :: Git.Branch -> FilePath -> Annex L.ByteString catFile branch file = do @@ -27,6 +29,11 @@ catObject ref = do h <- catFileHandle liftIO $ Git.CatFile.catObject h ref + +catObjectDetails :: Git.Ref -> Annex (Maybe (L.ByteString, Sha)) +catObjectDetails ref = do + h <- catFileHandle + liftIO $ Git.CatFile.catObjectDetails h ref catFileHandle :: Annex Git.CatFile.CatFileHandle catFileHandle = maybe startup return =<< Annex.getState Annex.catfilehandle diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -87,7 +87,7 @@ - to fiddle with permissions to open for an exclusive lock. -} openforlock f = catchMaybeIO $ ifM (doesFileExist f) ( withModifiedFileMode f - (\cur -> cur `unionFileModes` ownerWriteMode) + (`unionFileModes` ownerWriteMode) open , open ) @@ -168,7 +168,7 @@ withTmp key action = do tmp <- prepTmp key res <- action tmp - liftIO $ whenM (doesFileExist tmp) $ liftIO $ removeFile tmp + liftIO $ nukeFile tmp return res {- Checks that there is disk space available to store a given key, @@ -242,7 +242,7 @@ removeparents file n = do let dir = parentDir file maybe noop (const $ removeparents dir (n-1)) - =<< catchMaybeIO (removeDirectory dir) + <=< catchMaybeIO $ removeDirectory dir {- Removes a key's file from .git/annex/objects/ -} removeAnnex :: Key -> Annex () diff --git a/Annex/Queue.hs b/Annex/Queue.hs --- a/Annex/Queue.hs +++ b/Annex/Queue.hs @@ -1,27 +1,36 @@ {- git-annex command queue - - - Copyright 2011 Joey Hess + - Copyright 2011, 2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Annex.Queue ( - add, + addCommand, + addUpdateIndex, flush, - flushWhenFull + flushWhenFull, + size ) where import Common.Annex import Annex hiding (new) import qualified Git.Queue +import qualified Git.UpdateIndex import Config {- Adds a git command to the queue. -} -add :: String -> [CommandParam] -> [FilePath] -> Annex () -add command params files = do +addCommand :: String -> [CommandParam] -> [FilePath] -> Annex () +addCommand command params files = do q <- get - store $ Git.Queue.add q command params files + store <=< inRepo $ Git.Queue.addCommand command params files q +{- Adds an update-index stream to the queue. -} +addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex () +addUpdateIndex streamer = do + q <- get + store <=< inRepo $ Git.Queue.addUpdateIndex streamer q + {- Runs the queue if it is full. Should be called periodically. -} flushWhenFull :: Annex () flushWhenFull = do @@ -36,6 +45,10 @@ showStoringStateAction q' <- inRepo $ Git.Queue.flush q store q' + +{- Gets the size of the queue. -} +size :: Annex Int +size = Git.Queue.size <$> get get :: Annex Git.Queue.Queue get = maybe new return =<< getState repoqueue diff --git a/Assistant.hs b/Assistant.hs new file mode 100644 --- /dev/null +++ b/Assistant.hs @@ -0,0 +1,85 @@ +{- git-annex assistant daemon + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + - + - Overview of threads and MVars, etc: + - + - Thread 1: parent + - The initial thread run, double forks to background, starts other + - threads, and then stops, waiting for them to terminate, + - or for a ctrl-c. + - Thread 2: watcher + - Notices new files, and calls handlers for events, queuing changes. + - Thread 3: inotify internal + - Used by haskell inotify library to ensure inotify event buffer is + - kept drained. + - Thread 4: inotify startup scanner + - Scans the tree and registers inotify watches for each directory. + - A MVar lock is used to prevent other inotify handlers from running + - until this is complete. + - Thread 5: committer + - Waits for changes to occur, and runs the git queue to update its + - index, then commits. + - Thread 6: status logger + - Wakes up periodically and records the daemon's status to disk. + - Thread 7: sanity checker + - Wakes up periodically (rarely) and does sanity checks. + - + - ThreadState: (MVar) + - The Annex state is stored here, which allows resuscitating the + - Annex monad in IO actions run by the inotify and committer + - threads. Thus, a single state is shared amoung the threads, and + - only one at a time can access it. + - DaemonStatusHandle: (MVar) + - The daemon's current status. This MVar should only be manipulated + - from inside the Annex monad, which ensures it's accessed only + - after the ThreadState MVar. + - ChangeChan: (STM TChan) + - Changes are indicated by writing to this channel. The committer + - reads from it. + -} + +module Assistant where + +import Common.Annex +import Assistant.ThreadedMonad +import Assistant.DaemonStatus +import Assistant.Changes +import Assistant.Watcher +import Assistant.Committer +import Assistant.SanityChecker +import qualified Utility.Daemon +import Utility.LogFile + +import Control.Concurrent + +startDaemon :: Bool -> Annex () +startDaemon foreground + | foreground = do + showStart "watch" "." + go id + | otherwise = do + logfd <- liftIO . openLog =<< fromRepo gitAnnexLogFile + pidfile <- fromRepo gitAnnexPidFile + go $ Utility.Daemon.daemonize logfd (Just pidfile) False + where + go a = withThreadState $ \st -> do + checkCanWatch + dstatus <- startDaemonStatus + liftIO $ a $ do + changechan <- newChangeChan + -- The commit thread is started early, + -- so that the user can immediately + -- begin adding files and having them + -- committed, even while the startup scan + -- is taking place. + _ <- forkIO $ commitThread st changechan + _ <- forkIO $ daemonStatusThread st dstatus + _ <- forkIO $ sanityCheckerThread st dstatus changechan + -- Does not return. + watchThread st dstatus changechan + +stopDaemon :: Annex () +stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile diff --git a/Assistant/Changes.hs b/Assistant/Changes.hs new file mode 100644 --- /dev/null +++ b/Assistant/Changes.hs @@ -0,0 +1,81 @@ +{- git-annex assistant change tracking + - + - Copyright 2012 Joey Hess + -} + +module Assistant.Changes where + +import Common.Annex +import qualified Annex.Queue +import Types.KeySource + +import Control.Concurrent.STM +import Data.Time.Clock + +data ChangeType = AddChange | LinkChange | RmChange | RmDirChange + deriving (Show, Eq) + +type ChangeChan = TChan Change + +data Change + = Change + { changeTime :: UTCTime + , changeFile :: FilePath + , changeType :: ChangeType + } + | PendingAddChange + { changeTime ::UTCTime + , keySource :: KeySource + } + 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. + Annex.Queue.flushWhenFull + liftIO $ Just <$> (Change <$> getCurrentTime <*> pure f <*> pure t) + +noChange :: Annex (Maybe Change) +noChange = return Nothing + +{- Indicates an add is in progress. -} +pendingAddChange :: KeySource -> Annex (Maybe Change) +pendingAddChange ks = + liftIO $ Just <$> (PendingAddChange <$> getCurrentTime <*> pure ks) + +isPendingAddChange :: Change -> Bool +isPendingAddChange (PendingAddChange {}) = True +isPendingAddChange _ = False + +finishedChange :: Change -> Change +finishedChange c@(PendingAddChange { keySource = ks }) = Change + { changeTime = changeTime c + , changeFile = keyFilename ks + , changeType = AddChange + } +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) + +{- 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 diff --git a/Assistant/Committer.hs b/Assistant/Committer.hs new file mode 100644 --- /dev/null +++ b/Assistant/Committer.hs @@ -0,0 +1,195 @@ +{- git-annex assistant commit thread + - + - Copyright 2012 Joey Hess + -} + +module Assistant.Committer where + +import Common.Annex +import Assistant.Changes +import Assistant.ThreadedMonad +import Assistant.Watcher +import qualified Annex +import qualified Annex.Queue +import qualified Git.Command +import qualified Git.HashObject +import Git.Types +import qualified Command.Add +import Utility.ThreadScheduler +import qualified Utility.Lsof as Lsof +import qualified Utility.DirWatcher as DirWatcher +import Types.KeySource + +import Data.Time.Clock +import Data.Tuple.Utils +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 + -- We already waited one second as a simple rate limiter. + -- Next, wait until at least one change is available for + -- processing. + changes <- getChanges changechan + -- Now see if now's a good time to commit. + time <- getCurrentTime + if shouldCommit time changes + then do + readychanges <- handleAdds st changechan changes + if shouldCommit time readychanges + then do + void $ tryIO $ runThreadState st commitStaged + else refillChanges changechan readychanges + else refillChanges changechan changes + +commitStaged :: Annex () +commitStaged = do + Annex.Queue.flush + inRepo $ Git.Command.run "commit" + [ Param "--allow-empty-message" + , Param "-m", Param "" + -- Empty commits may be made if tree changes cancel + -- each other out, etc + , Param "--allow-empty" + -- Avoid running the usual git-annex pre-commit hook; + -- watch does the same symlink fixing, and we don't want + -- to deal with unlocked files in these commits. + , Param "--quiet" + ] + +{- Decide if now is a good time to make a commit. + - Note that the list of change times has an undefined order. + - + - Current strategy: If there have been 10 changes within the past second, + - a batch activity is taking place, so wait for later. + -} +shouldCommit :: UTCTime -> [Change] -> Bool +shouldCommit now changes + | len == 0 = False + | len > 10000 = True -- avoid bloating queue too much + | length (filter thisSecond changes) < 10 = True + | otherwise = False -- batch activity + where + len = length changes + thisSecond c = now `diffUTCTime` changeTime c <= 1 + +{- If there are PendingAddChanges, the files have not yet actually been + - added to the annex (probably), and that has to be done now, before + - committing. + - + - Deferring the adds to this point causes batches to be bundled together, + - which allows faster checking with lsof that the files are not still open + - for write by some other process. + - + - When a file is added, Inotify will notice the new symlink. So this waits + - for additional Changes to arrive, so that the symlink has hopefully been + - staged before returning, and will be committed immediately. + - + - OTOH, for kqueue, eventsCoalesce, so instead the symlink is directly + - created and staged. + - + - Returns a list of all changes that are ready to be committed. + - Any pending adds that are not ready yet are put back into the ChangeChan, + - where they will be retried later. + -} +handleAdds :: ThreadState -> ChangeChan -> [Change] -> IO [Change] +handleAdds st changechan cs = returnWhen (null pendingadds) $ do + (postponed, toadd) <- partitionEithers <$> + safeToAdd st pendingadds + + unless (null postponed) $ + refillChanges changechan postponed + + returnWhen (null toadd) $ do + added <- catMaybes <$> forM toadd add + if (DirWatcher.eventsCoalesce || null added) + then return $ added ++ otherchanges + else do + r <- handleAdds st changechan + =<< getChanges changechan + return $ r ++ added ++ otherchanges + where + (pendingadds, otherchanges) = partition isPendingAddChange cs + + returnWhen c a + | c = return otherchanges + | otherwise = a + + add :: Change -> IO (Maybe Change) + add change@(PendingAddChange { keySource = ks }) = do + r <- catchMaybeIO $ sanitycheck ks $ runThreadState st $ do + showStart "add" $ keyFilename ks + handle (finishedChange change) (keyFilename ks) + =<< Command.Add.ingest ks + return $ maybeMaybe r + add _ = return Nothing + + maybeMaybe (Just j@(Just _)) = j + maybeMaybe _ = Nothing + + handle _ _ Nothing = do + showEndFail + return Nothing + handle change file (Just key) = do + link <- Command.Add.link file key True + when DirWatcher.eventsCoalesce $ do + sha <- inRepo $ + Git.HashObject.hashObject BlobObject link + stageSymlink file sha + showEndOk + return $ Just change + + {- Check that the keysource's keyFilename still exists, + - and is still a hard link to its contentLocation, + - before ingesting it. -} + sanitycheck keysource a = do + fs <- getSymbolicLinkStatus $ keyFilename keysource + ks <- getSymbolicLinkStatus $ contentLocation keysource + if deviceID ks == deviceID fs && fileID ks == fileID fs + then a + else return Nothing + +{- PendingAddChanges can Either be Right to be added now, + - or are unsafe, and must be Left for later. + - + - Check by running lsof on the temp directory, which + - the KeySources are locked down in. + -} +safeToAdd :: ThreadState -> [Change] -> IO [Either Change Change] +safeToAdd st changes = runThreadState st $ + ifM (Annex.getState Annex.force) + ( allRight changes -- force bypasses lsof check + , do + tmpdir <- fromRepo gitAnnexTmpDir + openfiles <- S.fromList . map fst3 . filter openwrite <$> + liftIO (Lsof.queryDir tmpdir) + + let checked = map (check openfiles) changes + + {- If new events are received when files are closed, + - there's no need to retry any changes that cannot + - be done now. -} + if DirWatcher.closingTracked + then do + mapM_ canceladd $ lefts checked + allRight $ rights checked + else return checked + ) + where + check openfiles change@(PendingAddChange { keySource = ks }) + | S.member (contentLocation ks) openfiles = Left change + check _ change = Right change + + canceladd (PendingAddChange { keySource = ks }) = do + warning $ keyFilename ks + ++ " still has writers, not adding" + -- remove the hard link + void $ liftIO $ tryIO $ + removeFile $ contentLocation ks + canceladd _ = noop + + openwrite (_file, mode, _pid) = + mode == Lsof.OpenWriteOnly || mode == Lsof.OpenReadWrite + + allRight = return . map Right diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs new file mode 100644 --- /dev/null +++ b/Assistant/DaemonStatus.hs @@ -0,0 +1,119 @@ +{- git-annex assistant daemon status + - + - Copyright 2012 Joey Hess + -} + +module Assistant.DaemonStatus where + +import Common.Annex +import Assistant.ThreadedMonad +import Utility.ThreadScheduler +import Utility.TempFile + +import Control.Concurrent +import System.Posix.Types +import Data.Time.Clock.POSIX +import Data.Time +import System.Locale + +data DaemonStatus = DaemonStatus + -- False when the daemon is performing its startup scan + { scanComplete :: Bool + -- Time when a previous process of the daemon was running ok + , lastRunning :: Maybe POSIXTime + -- True when the sanity checker is running + , sanityCheckRunning :: Bool + -- Last time the sanity checker ran + , lastSanityCheck :: Maybe POSIXTime + } + deriving (Show) + +type DaemonStatusHandle = MVar DaemonStatus + +newDaemonStatus :: DaemonStatus +newDaemonStatus = DaemonStatus + { scanComplete = False + , lastRunning = Nothing + , sanityCheckRunning = False + , lastSanityCheck = Nothing + } + +getDaemonStatus :: DaemonStatusHandle -> Annex DaemonStatus +getDaemonStatus = liftIO . readMVar + +modifyDaemonStatus :: DaemonStatusHandle -> (DaemonStatus -> DaemonStatus) -> Annex () +modifyDaemonStatus handle a = liftIO $ modifyMVar_ handle (return . a) + +{- Load any previous daemon status file, and store it in the MVar for this + - process to use as its DaemonStatus. -} +startDaemonStatus :: Annex DaemonStatusHandle +startDaemonStatus = do + file <- fromRepo gitAnnexDaemonStatusFile + status <- liftIO $ + catchDefaultIO (readDaemonStatusFile file) newDaemonStatus + liftIO $ newMVar status + { scanComplete = False + , sanityCheckRunning = False + } + +{- This thread wakes up periodically and writes the daemon status to disk. -} +daemonStatusThread :: ThreadState -> DaemonStatusHandle -> IO () +daemonStatusThread st handle = do + checkpoint + runEvery (Seconds tenMinutes) checkpoint + where + checkpoint = runThreadState st $ do + file <- fromRepo gitAnnexDaemonStatusFile + status <- getDaemonStatus handle + liftIO $ writeDaemonStatusFile file status + +{- Don't just dump out the structure, because it will change over time, + - and parts of it are not relevant. -} +writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO () +writeDaemonStatusFile file status = + viaTmp writeFile file =<< serialized <$> getPOSIXTime + where + serialized now = unlines + [ "lastRunning:" ++ show now + , "scanComplete:" ++ show (scanComplete status) + , "sanityCheckRunning:" ++ show (sanityCheckRunning status) + , "lastSanityCheck:" ++ maybe "" show (lastSanityCheck status) + ] + +readDaemonStatusFile :: FilePath -> IO DaemonStatus +readDaemonStatusFile file = parse <$> readFile file + where + parse = foldr parseline newDaemonStatus . lines + parseline line status + | key == "lastRunning" = parseval readtime $ \v -> + status { lastRunning = Just v } + | key == "scanComplete" = parseval readish $ \v -> + status { scanComplete = v } + | key == "sanityCheckRunning" = parseval readish $ \v -> + status { sanityCheckRunning = v } + | key == "lastSanityCheck" = parseval readtime $ \v -> + status { lastSanityCheck = Just v } + | otherwise = status -- unparsable line + where + (key, value) = separate (== ':') line + parseval parser a = maybe status a (parser value) + readtime s = do + d <- parseTime defaultTimeLocale "%s%Qs" s + Just $ utcTimeToPOSIXSeconds d + +{- Checks if a time stamp was made after the daemon was lastRunning. + - + - Some slop is built in; this really checks if the time stamp was made + - at least ten minutes after the daemon was lastRunning. This is to + - ensure the daemon shut down cleanly, and deal with minor clock skew. + - + - If the daemon has never ran before, this always returns False. + -} +afterLastDaemonRun :: EpochTime -> DaemonStatus -> Bool +afterLastDaemonRun timestamp status = maybe False (< t) (lastRunning status) + where + t = realToFrac (timestamp + slop) :: POSIXTime + slop = fromIntegral tenMinutes + +tenMinutes :: Int +tenMinutes = 10 * 60 diff --git a/Assistant/SanityChecker.hs b/Assistant/SanityChecker.hs new file mode 100644 --- /dev/null +++ b/Assistant/SanityChecker.hs @@ -0,0 +1,81 @@ +{- git-annex assistant sanity checker + - + - Copyright 2012 Joey Hess + -} + +module Assistant.SanityChecker ( + sanityCheckerThread +) where + +import Common.Annex +import qualified Git.LsFiles +import Assistant.DaemonStatus +import Assistant.ThreadedMonad +import Assistant.Changes +import Utility.ThreadScheduler +import qualified Assistant.Watcher + +import Data.Time.Clock.POSIX + +{- This thread wakes up occasionally to make sure the tree is in good shape. -} +sanityCheckerThread :: ThreadState -> DaemonStatusHandle -> ChangeChan -> IO () +sanityCheckerThread st status changechan = forever $ do + waitForNextCheck st status + + runThreadState st $ + modifyDaemonStatus status $ \s -> s + { sanityCheckRunning = True } + + now <- getPOSIXTime -- before check started + catchIO (check st status changechan) + (runThreadState st . warning . show) + + runThreadState st $ do + modifyDaemonStatus status $ \s -> s + { sanityCheckRunning = False + , lastSanityCheck = Just now + } + +{- Only run one check per day, from the time of the last check. -} +waitForNextCheck :: ThreadState -> DaemonStatusHandle -> IO () +waitForNextCheck st status = do + v <- runThreadState st $ + lastSanityCheck <$> getDaemonStatus status + now <- getPOSIXTime + threadDelaySeconds $ Seconds $ calcdelay now v + where + calcdelay _ Nothing = oneDay + calcdelay now (Just lastcheck) + | lastcheck < now = max oneDay $ + oneDay - truncate (now - lastcheck) + | otherwise = oneDay + +oneDay :: Int +oneDay = 24 * 60 * 60 + +{- It's important to stay out of the Annex monad as much as possible while + - running potentially expensive parts of this check, since remaining in it + - will block the watcher. -} +check :: ThreadState -> DaemonStatusHandle -> ChangeChan -> IO () +check st status changechan = do + g <- runThreadState st $ do + showSideAction "Running daily check" + fromRepo id + -- Find old unstaged symlinks, and add them to git. + unstaged <- Git.LsFiles.notInRepo False ["."] g + now <- getPOSIXTime + forM_ unstaged $ \file -> do + ms <- catchMaybeIO $ getSymbolicLinkStatus file + case ms of + Just s | toonew (statusChangeTime s) now -> noop + | isSymbolicLink s -> + addsymlink file ms + _ -> noop + where + toonew timestamp now = now < (realToFrac (timestamp + slop) :: POSIXTime) + slop = fromIntegral tenMinutes + insanity m = runThreadState st $ warning m + addsymlink file s = do + insanity $ "found unstaged symlink: " ++ file + Assistant.Watcher.runHandler st status changechan + Assistant.Watcher.onAddSymlink file s diff --git a/Assistant/ThreadedMonad.hs b/Assistant/ThreadedMonad.hs new file mode 100644 --- /dev/null +++ b/Assistant/ThreadedMonad.hs @@ -0,0 +1,44 @@ +{- making the Annex monad available across threads + - + - Copyright 2012 Joey Hess + -} + +{-# LANGUAGE BangPatterns #-} + +module Assistant.ThreadedMonad where + +import Common.Annex +import qualified Annex + +import Control.Concurrent +import Control.Exception (throw) + +{- The Annex state is stored in a MVar, so that threaded actions can access + - it. -} +type ThreadState = MVar Annex.AnnexState + +{- Stores the Annex state in a MVar. + - + - Once the action is finished, retrieves the state from the MVar. + -} +withThreadState :: (ThreadState -> Annex a) -> Annex a +withThreadState a = do + state <- Annex.getState id + mvar <- liftIO $ newMVar state + r <- a mvar + newstate <- liftIO $ takeMVar mvar + Annex.changeState (const newstate) + return r + +{- Runs an Annex action, using the state from the MVar. + - + - This serializes calls by threads. -} +runThreadState :: ThreadState -> Annex a -> IO a +runThreadState mvar a = do + startstate <- takeMVar mvar + -- catch IO errors and rethrow after restoring the MVar + !(r, newstate) <- catchIO (Annex.run startstate a) $ \e -> do + putMVar mvar startstate + throw e + putMVar mvar newstate + return r diff --git a/Assistant/Watcher.hs b/Assistant/Watcher.hs new file mode 100644 --- /dev/null +++ b/Assistant/Watcher.hs @@ -0,0 +1,220 @@ +{- git-annex assistant tree watcher + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Assistant.Watcher where + +import Common.Annex +import Assistant.ThreadedMonad +import Assistant.DaemonStatus +import Assistant.Changes +import Utility.DirWatcher +import Utility.Types.DirWatcher +import qualified Annex +import qualified Annex.Queue +import qualified Git.Command +import qualified Git.UpdateIndex +import qualified Git.HashObject +import qualified Git.LsFiles +import qualified Backend +import qualified Command.Add +import Annex.Content +import Annex.CatFile +import Git.Types + +import Control.Concurrent.STM +import Data.Bits.Utils +import qualified Data.ByteString.Lazy as L + +checkCanWatch :: Annex () +checkCanWatch + | canWatch = + unlessM (liftIO (inPath "lsof") <||> Annex.getState Annex.force) $ + needLsof + | otherwise = error "watch mode is not available on this system" + +needLsof :: Annex () +needLsof = error $ unlines + [ "The lsof command is needed for watch mode to be safe, and is not in PATH." + , "To override lsof checks to ensure that files are not open for writing" + , "when added to the annex, you can use --force" + , "Be warned: This can corrupt data in the annex, and make fsck complain." + ] + +watchThread :: ThreadState -> DaemonStatusHandle -> ChangeChan -> IO () +watchThread st dstatus changechan = watchDir "." ignored hooks startup + where + startup = statupScan st dstatus + hook a = Just $ runHandler st dstatus changechan a + hooks = WatchHooks + { addHook = hook onAdd + , delHook = hook onDel + , addSymlinkHook = hook onAddSymlink + , delDirHook = hook onDelDir + , errHook = hook onErr + } + +{- Initial scartup scan. The action should return once the scan is complete. -} +statupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a +statupScan st dstatus scanner = do + runThreadState st $ + showAction "scanning" + r <- scanner + runThreadState st $ + modifyDaemonStatus dstatus $ \s -> s { scanComplete = True } + + -- Notice any files that were deleted before watching was started. + runThreadState st $ do + inRepo $ Git.Command.run "add" [Param "--update"] + showAction "started" + + return r + +ignored :: FilePath -> Bool +ignored = ig . takeFileName + where + ig ".git" = True + ig ".gitignore" = True + ig ".gitattributes" = True + ig _ = False + +type Handler = FilePath -> Maybe FileStatus -> DaemonStatusHandle -> Annex (Maybe Change) + +{- Runs an action handler, inside the Annex monad, and if there was a + - change, adds it to the ChangeChan. + - + - Exceptions are ignored, otherwise a whole watcher thread could be crashed. + -} +runHandler :: ThreadState -> DaemonStatusHandle -> ChangeChan -> Handler -> FilePath -> Maybe FileStatus -> IO () +runHandler st dstatus changechan handler file filestatus = void $ do + r <- tryIO go + case r of + Left e -> print e + Right Nothing -> noop + Right (Just change) -> void $ + runChangeChan $ writeTChan changechan change + where + go = runThreadState st $ handler file filestatus dstatus + +{- During initial directory scan, this will be run for any regular files + - that are already checked into git. We don't want to turn those into + - symlinks, so do a check. This is rather expensive, but only happens + - during startup. + - + - It's possible for the file to still be open for write by some process. + - This can happen in a few ways; one is if two processes had the file open + - and only one has just closed it. We want to avoid adding a file to the + - annex that is open for write, to avoid anything being able to change it. + - + - We could run lsof on the file here to check for other writers. + - But, that's slow, and even if there is currently a writer, we will want + - to add the file *eventually*. Instead, the file is locked down as a hard + - link in a temp directory, with its write bits disabled, for later + - checking with lsof, and a Change is returned containing a KeySource + - using that hard link. The committer handles running lsof and finishing + - the add. + -} +onAdd :: Handler +onAdd file filestatus dstatus + | maybe False isRegularFile filestatus = do + ifM (scanComplete <$> getDaemonStatus dstatus) + ( go + , ifM (null <$> inRepo (Git.LsFiles.notInRepo False [file])) + ( noChange + , go + ) + ) + | otherwise = noChange + where + go = pendingAddChange =<< Command.Add.lockDown file + +{- A symlink might be an arbitrary symlink, which is just added. + - Or, if it is a git-annex symlink, ensure it points to the content + - before adding it. + -} +onAddSymlink :: Handler +onAddSymlink file filestatus dstatus = go =<< Backend.lookupFile file + where + go (Just (key, _)) = do + link <- calcGitLink file key + ifM ((==) link <$> liftIO (readSymbolicLink file)) + ( ensurestaged link =<< getDaemonStatus dstatus + , do + liftIO $ removeFile file + liftIO $ createSymbolicLink link file + addlink link + ) + go Nothing = do -- other symlink + link <- liftIO (readSymbolicLink file) + ensurestaged link =<< getDaemonStatus dstatus + + {- This is often called on symlinks that are already + - staged correctly. A symlink may have been deleted + - and being re-added, or added when the watcher was + - not running. So they're normally restaged to make sure. + - + - As an optimisation, during the status scan, avoid + - restaging everything. Only links that were created since + - the last time the daemon was running are staged. + - (If the daemon has never ran before, avoid staging + - links too.) + -} + ensurestaged link daemonstatus + | scanComplete daemonstatus = addlink link + | otherwise = case filestatus of + Just s + | not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange + _ -> addlink link + + {- For speed, tries to reuse the existing blob for + - the symlink target. -} + addlink link = do + v <- catObjectDetails $ Ref $ ':':file + case v of + Just (currlink, sha) + | s2w8 link == L.unpack currlink -> + stageSymlink file sha + _ -> do + sha <- inRepo $ + Git.HashObject.hashObject BlobObject link + stageSymlink file sha + madeChange file LinkChange + +onDel :: Handler +onDel file _ _dstatus = do + Annex.Queue.addUpdateIndex =<< + inRepo (Git.UpdateIndex.unstageFile file) + madeChange file RmChange + +{- A directory has been deleted, or moved, so tell git to remove anything + - that was inside it from its cache. Since it could reappear at any time, + - use --cached to only delete it from the index. + - + - Note: This could use unstageFile, but would need to run another git + - command to get the recursive list of files in the directory, so rm is + - just as good. -} +onDelDir :: Handler +onDelDir dir _ _dstatus = do + Annex.Queue.addCommand "rm" + [Params "--quiet -r --cached --ignore-unmatch --"] [dir] + madeChange dir RmDirChange + +{- Called when there's an error with inotify. -} +onErr :: Handler +onErr msg _ _dstatus = do + warning msg + return Nothing + +{- Adds a symlink to the index, without ever accessing the actual symlink + - on disk. This avoids a race if git add is used, where the symlink is + - changed to something else immediately after creation. + -} +stageSymlink :: FilePath -> Sha -> Annex () +stageSymlink file sha = + Annex.Queue.addUpdateIndex =<< + inRepo (Git.UpdateIndex.stageSymlink file sha) diff --git a/Backend.hs b/Backend.hs --- a/Backend.hs +++ b/Backend.hs @@ -6,7 +6,6 @@ -} module Backend ( - B.KeySource(..), list, orderedList, genKey, @@ -23,6 +22,7 @@ import qualified Annex import Annex.CheckAttr import Types.Key +import Types.KeySource import qualified Types.Backend as B -- When adding a new backend, import it here and add it to the list. @@ -54,12 +54,12 @@ {- Generates a key for a file, trying each backend in turn until one - accepts it. -} -genKey :: B.KeySource -> Maybe Backend -> Annex (Maybe (Key, Backend)) +genKey :: KeySource -> Maybe Backend -> Annex (Maybe (Key, Backend)) genKey source trybackend = do bs <- orderedList let bs' = maybe bs (: bs) trybackend genKey' bs' source -genKey' :: [Backend] -> B.KeySource -> Annex (Maybe (Key, Backend)) +genKey' :: [Backend] -> KeySource -> Annex (Maybe (Key, Backend)) genKey' [] _ = return Nothing genKey' (b:bs) source = do r <- B.getKey b source diff --git a/Backend/SHA.hs b/Backend/SHA.hs --- a/Backend/SHA.hs +++ b/Backend/SHA.hs @@ -11,6 +11,7 @@ import qualified Annex import Types.Backend import Types.Key +import Types.KeySource import qualified Build.SysConfig as SysConfig type SHASize = Int diff --git a/Backend/WORM.hs b/Backend/WORM.hs --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -10,6 +10,7 @@ import Common.Annex import Types.Backend import Types.Key +import Types.KeySource backends :: [Backend] backends = [backend] diff --git a/Build/Configure.hs b/Build/Configure.hs --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -26,6 +26,7 @@ , TestCase "wget" $ testCmd "wget" "wget --version >/dev/null" , TestCase "bup" $ testCmd "bup" "bup --version >/dev/null" , TestCase "gpg" $ testCmd "gpg" "gpg --version >/dev/null" + , TestCase "lsof" $ testCmd "lsof" "lsof -v >/dev/null 2>&1" , TestCase "ssh connection caching" getSshConnectionCaching ] ++ shaTestCases False [1, 512, 224, 384] ++ shaTestCases True [256] diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,4 +1,16 @@ -git-annex (3.20120615) unstable; urgency=medium +git-annex (3.20120624) unstable; urgency=low + + * watch: New subcommand, a daemon which notices changes to + files and automatically annexes new files, etc, so you don't + need to manually run git commands when manipulating files. + Available on Linux, BSDs, and OSX! + * Enable diskfree on kfreebsd, using kqueue. + * unused: Fix crash when key names contain invalid utf8. + * sync: Avoid recent git's interactive merge. + + -- Joey Hess Sun, 24 Jun 2012 12:36:50 -0400 + +git-annex (3.20120614) unstable; urgency=medium * addurl: Was broken by a typo introduced 2 released ago, now fixed. Closes: #677576 diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -12,6 +12,7 @@ import Command import qualified Annex import qualified Annex.Queue +import Types.KeySource import Backend import Logs.Location import Annex.Content @@ -50,34 +51,43 @@ - to prevent it from being modified in between. It's hard linked into a - temporary location, and its writable bits are removed. It could still be - written to by a process that already has it open for writing. -} -perform :: FilePath -> CommandPerform -perform file = do +lockDown :: FilePath -> Annex KeySource +lockDown file = do liftIO $ preventWrite file tmp <- fromRepo gitAnnexTmpDir createAnnexDirectory tmp - pid <- liftIO getProcessID - let tmpfile = tmp "add" ++ show pid ++ "." ++ takeFileName file - nuke tmpfile - liftIO $ createLink file tmpfile - let source = KeySource { keyFilename = file, contentLocation = tmpfile } - backend <- chooseBackend file - genKey source backend >>= go tmpfile + liftIO $ do + (tmpfile, _handle) <- openTempFile tmp (takeFileName file) + nukeFile tmpfile + createLink file tmpfile + return $ KeySource { keyFilename = file , contentLocation = tmpfile } + +{- Moves a locked down file into the annex. -} +ingest :: KeySource -> Annex (Maybe Key) +ingest source = do + backend <- chooseBackend $ keyFilename source + genKey source backend >>= go where - go _ Nothing = stop - go tmpfile (Just (key, _)) = do - handle (undo file key) $ moveAnnex key tmpfile - nuke file - next $ cleanup file key True + go Nothing = do + liftIO $ nukeFile $ contentLocation source + return Nothing + go (Just (key, _)) = do + handle (undo (keyFilename source) key) $ + moveAnnex key $ contentLocation source + liftIO $ nukeFile $ keyFilename source + return $ Just key -nuke :: FilePath -> Annex () -nuke file = liftIO $ whenM (doesFileExist file) $ removeFile file +perform :: FilePath -> CommandPerform +perform file = + maybe stop (\key -> next $ cleanup file key True) + =<< ingest =<< lockDown file {- On error, put the file back so it doesn't seem to have vanished. - This can be called before or after the symlink is in place. -} undo :: FilePath -> Key -> IOException -> Annex a undo file key e = do whenM (inAnnex key) $ do - nuke file + liftIO $ nukeFile file handle tryharder $ fromAnnex key file logStatus key InfoMissing throw e @@ -88,24 +98,31 @@ src <- inRepo $ gitAnnexLocation key liftIO $ moveFile src file -cleanup :: FilePath -> Key -> Bool -> CommandCleanup -cleanup file key hascontent = do - handle (undo file key) $ do - link <- calcGitLink file key - liftIO $ createSymbolicLink link file +{- Creates the symlink to the annexed content, returns the link target. -} +link :: FilePath -> Key -> Bool -> Annex String +link file key hascontent = handle (undo file key) $ do + l <- calcGitLink file key + liftIO $ createSymbolicLink l file - when hascontent $ do - logStatus key InfoPresent + when hascontent $ do + logStatus key InfoPresent - -- touch the symlink to have the same mtime as the - -- file it points to - liftIO $ do - mtime <- modificationTime <$> getFileStatus file - touch file (TimeSpec mtime) False + -- touch the symlink to have the same mtime as the + -- file it points to + liftIO $ do + mtime <- modificationTime <$> getFileStatus file + touch file (TimeSpec mtime) False + return l + +{- Note: Several other commands call this, and expect it to + - create the symlink and add it. -} +cleanup :: FilePath -> Key -> Bool -> CommandCleanup +cleanup file key hascontent = do + _ <- link file key hascontent params <- ifM (Annex.getState Annex.force) ( return [Param "-f"] , return [] ) - Annex.Queue.add "add" (params++[Param "--"]) [file] + Annex.Queue.addCommand "add" (params++[Param "--"]) [file] return True diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -20,6 +20,7 @@ import Logs.Web import qualified Option import Types.Key +import Types.KeySource import Config def :: [Command] diff --git a/Command/Commit.hs b/Command/Commit.hs --- a/Command/Commit.hs +++ b/Command/Commit.hs @@ -22,7 +22,7 @@ start :: CommandStart start = next $ next $ do Annex.Branch.commit "update" - _ <- runhook =<< (inRepo $ Git.hookPath "annex-content") + _ <- runhook <=< inRepo $ Git.hookPath "annex-content" return True where runhook (Just hook) = liftIO $ boolSystem hook [] diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -40,5 +40,5 @@ performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform performOther filespec key = do f <- fromRepo $ filespec key - liftIO $ whenM (doesFileExist f) $ removeFile f + liftIO $ nukeFile f next $ return True diff --git a/Command/Fix.hs b/Command/Fix.hs --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -36,5 +36,5 @@ cleanup :: FilePath -> CommandCleanup cleanup file = do - Annex.Queue.add "add" [Param "--force", Param "--"] [file] + Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file] return True diff --git a/Command/FromKey.hs b/Command/FromKey.hs --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -39,5 +39,5 @@ cleanup :: FilePath -> CommandCleanup cleanup file = do - Annex.Queue.add "add" [Param "--"] [file] + Annex.Queue.addCommand "add" [Param "--"] [file] return True diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -145,17 +145,17 @@ -} whenM (liftIO $ doesFileExist file) $ unlessM (inAnnex key) $ do - showNote $ "fixing content location" + showNote "fixing content location" dir <- liftIO $ parentDir <$> absPath file let content = absPathFrom dir have liftIO $ allowWrite (parentDir content) moveAnnex key content - showNote $ "fixing link" + showNote "fixing link" liftIO $ createDirectoryIfMissing True (parentDir file) liftIO $ removeFile file liftIO $ createSymbolicLink want file - Annex.Queue.add "add" [Param "--force", Param "--"] [file] + Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file] return True {- Checks that the location log reflects the current status of the key, @@ -220,7 +220,7 @@ Nothing -> return True Just size -> do size' <- fromIntegral . fileSize - <$> (liftIO $ getFileStatus file) + <$> liftIO (getFileStatus file) comparesizes size size' where comparesizes a b = do diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -26,7 +26,7 @@ autoCopies file key (<) $ \_numcopies -> case from of Nothing -> go $ perform key - Just src -> do + Just src -> -- get --from = copy --from stopUnless (Command.Move.fromOk src key) $ go $ Command.Move.fromPerform src False key diff --git a/Command/Lock.hs b/Command/Lock.hs --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -24,5 +24,5 @@ perform :: FilePath -> CommandPerform perform file = do - Annex.Queue.add "checkout" [Param "--"] [file] + Annex.Queue.addCommand "checkout" [Param "--"] [file] next $ return True -- no cleanup needed diff --git a/Command/Migrate.hs b/Command/Migrate.hs --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -11,6 +11,7 @@ import Command import Backend import qualified Types.Key +import Types.KeySource import Annex.Content import qualified Command.ReKey diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -128,9 +128,9 @@ expensive = do u <- getUUID remotes <- Remote.keyPossibilities key - return $ u /= Remote.uuid src && any (== src) remotes + return $ u /= Remote.uuid src && elem src remotes fromPerform :: Remote -> Bool -> Key -> CommandPerform -fromPerform src move key = moveLock move key $ do +fromPerform src move key = moveLock move key $ ifM (inAnnex key) ( handle move True , do diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -16,6 +16,7 @@ import qualified Annex import qualified Annex.Branch import qualified Git.Command +import qualified Git.Merge import qualified Git.Branch import qualified Git.Ref import qualified Git @@ -157,7 +158,7 @@ mergeFrom :: Git.Ref -> CommandCleanup mergeFrom branch = do showOutput - inRepo $ Git.Command.runBool "merge" [Param $ show branch] + inRepo $ Git.Merge.mergeNonInteractive branch changed :: Remote -> Git.Ref -> Annex Bool changed remote b = do diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -28,8 +28,8 @@ "cannot uninit when the " ++ show b ++ " branch is checked out" top <- fromRepo Git.repoPath cwd <- liftIO getCurrentDirectory - whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $ error $ - "can only run uninit from the top of the git repository" + whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $ + error "can only run uninit from the top of the git repository" where current_branch = Git.Ref . Prelude.head . lines <$> revhead revhead = inRepo $ Git.Command.pipeRead diff --git a/Command/Unused.hs b/Command/Unused.hs --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -10,8 +10,7 @@ module Command.Unused where import qualified Data.Set as S -import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.Encoding as L +import qualified Data.ByteString.Lazy as L import Data.BloomFilter import Data.BloomFilter.Easy import Data.BloomFilter.Hash @@ -84,7 +83,7 @@ _ <- check "" (remoteUnusedMsg r) (remoteunused r) 0 next $ return True remoteunused r = - excludeReferenced =<< loggedKeysFor (Remote.uuid r) + excludeReferenced <=< loggedKeysFor $ Remote.uuid r check :: FilePath -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int check file msg a c = do @@ -260,13 +259,14 @@ withKeysReferencedInGitRef :: (Key -> Annex ()) -> Git.Ref -> Annex () withKeysReferencedInGitRef a ref = do showAction $ "checking " ++ Git.Ref.describe ref - go =<< inRepo (LsTree.lsTree ref) + go <=< inRepo $ LsTree.lsTree ref where go [] = noop go (l:ls) | isSymLink (LsTree.mode l) = do - content <- L.decodeUtf8 <$> catFile ref (LsTree.file l) - case fileKey (takeFileName $ L.unpack content) of + content <- encodeW8 . L.unpack + <$> catFile ref (LsTree.file l) + case fileKey (takeFileName content) of Nothing -> go ls Just k -> do a k diff --git a/Command/Watch.hs b/Command/Watch.hs new file mode 100644 --- /dev/null +++ b/Command/Watch.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} + +{- git-annex watch command + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Watch where + +import Common.Annex +import Assistant +import Command +import Option + +def :: [Command] +def = [withOptions [foregroundOption, stopOption] $ + command "watch" paramNothing seek "watch for changes"] + +seek :: [CommandSeek] +seek = [withFlag stopOption $ \stopdaemon -> + withFlag foregroundOption $ \foreground -> + withNothing $ start foreground stopdaemon] + +foregroundOption :: Option +foregroundOption = Option.flag [] "foreground" "do not daemonize" + +stopOption :: Option +stopOption = Option.flag [] "stop" "stop daemon" + +start :: Bool -> Bool -> CommandStart +start foreground stopdaemon = notBareRepo $ do + if stopdaemon + then stopDaemon + else startDaemon foreground -- does not return + stop diff --git a/Command/Whereis.hs b/Command/Whereis.hs --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -37,7 +37,7 @@ unless (null safelocations) $ showLongNote pp pp' <- prettyPrintUUIDs "untrusted" untrustedlocations unless (null untrustedlocations) $ showLongNote $ untrustedheader ++ pp' - forM_ (catMaybes $ map (`M.lookup` remotemap) locations) $ + forM_ (mapMaybe (`M.lookup` remotemap) locations) $ performRemote key if null safelocations then stop else next $ return True where diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -114,6 +114,6 @@ getHttpHeaders :: Annex [String] getHttpHeaders = do cmd <- getConfig (annexConfig "http-headers-command") "" - if (null cmd) + if null cmd then fromRepo $ Git.Config.getList "annex.http-headers" else lines . snd <$> liftIO (pipeFrom "sh" ["-c", cmd]) diff --git a/Crypto.hs b/Crypto.hs --- a/Crypto.hs +++ b/Crypto.hs @@ -26,7 +26,7 @@ prop_hmacWithCipher_sane ) where -import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.UTF8 (fromString) import Data.Digest.Pure.SHA import Control.Applicative @@ -138,7 +138,7 @@ pass :: (Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a) -> Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a -pass to n s a = to n s $ \h -> a =<< L.hGetContents h +pass to n s a = to n s $ a <=< L.hGetContents hmacWithCipher :: Cipher -> String -> String hmacWithCipher c = hmacWithCipher' (cipherHmac c) diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -10,12 +10,13 @@ catFileStart, catFileStop, catFile, - catObject + catObject, + catObjectDetails, ) where import System.IO -import qualified Data.ByteString.Char8 as S -import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L import Common import Git @@ -42,7 +43,11 @@ {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} catObject :: CatFileHandle -> Ref -> IO L.ByteString -catObject h object = CoProcess.query h send receive +catObject h object = maybe L.empty fst <$> catObjectDetails h object + +{- Gets both the content of an object, and its Sha. -} +catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha)) +catObjectDetails h object = CoProcess.query h send receive where send to = do fileEncoding to @@ -55,16 +60,16 @@ | length sha == shaSize && isJust (readObjectType objtype) -> case reads size of - [(bytes, "")] -> readcontent bytes from + [(bytes, "")] -> readcontent bytes from sha _ -> dne | otherwise -> dne _ | header == show object ++ " missing" -> dne | otherwise -> error $ "unknown response from git cat-file " ++ show (header, object) - readcontent bytes from = do + readcontent bytes from sha = do content <- S.hGet from bytes c <- hGetChar from when (c /= '\n') $ error "missing newline from git cat-file" - return $ L.fromChunks [content] - dne = return L.empty + return $ Just (L.fromChunks [content], Ref sha) + dne = return Nothing diff --git a/Git/FilePath.hs b/Git/FilePath.hs new file mode 100644 --- /dev/null +++ b/Git/FilePath.hs @@ -0,0 +1,34 @@ +{- git FilePath library + - + - Different git commands use different types of FilePaths to refer to + - files in the repository. Some commands use paths relative to the + - top of the repository even when run in a subdirectory. Adding some + - types helps keep that straight. + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.FilePath ( + TopFilePath, + getTopFilePath, + toTopFilePath, + asTopFilePath, +) where + +import Common +import Git + +{- A FilePath, relative to the top of the git repository. -} +newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } + +{- The input FilePath can be absolute, or relative to the CWD. -} +toTopFilePath :: FilePath -> Git.Repo -> IO TopFilePath +toTopFilePath file repo = TopFilePath <$> + relPathDirToFile (repoPath repo) <$> absPath file + +{- The input FilePath must already be relative to the top of the git + - repository -} +asTopFilePath :: FilePath -> TopFilePath +asTopFilePath file = TopFilePath file diff --git a/Git/HashObject.hs b/Git/HashObject.hs --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -36,8 +36,8 @@ receive from = getSha "hash-object" $ hGetLine from {- Injects some content into git, returning its Sha. -} -hashObject :: Repo -> ObjectType -> String -> IO Sha -hashObject repo objtype content = getSha subcmd $ do +hashObject :: ObjectType -> String -> Repo -> IO Sha +hashObject objtype content repo = getSha subcmd $ do (h, s) <- pipeWriteRead (map Param params) content repo length s `seq` do forceSuccess h diff --git a/Git/Merge.hs b/Git/Merge.hs new file mode 100644 --- /dev/null +++ b/Git/Merge.hs @@ -0,0 +1,17 @@ +{- git merging + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Merge where + +import Common +import Git +import Git.Command + +{- Avoids recent git's interactive merge. -} +mergeNonInteractive :: Ref -> Repo -> IO Bool +mergeNonInteractive branch = runBool "merge" + [Param "--no-edit", Param $ show branch] diff --git a/Git/Queue.hs b/Git/Queue.hs --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -1,6 +1,6 @@ {- git repository command queue - - - Copyright 2010 Joey Hess + - Copyright 2010,2012 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -10,7 +10,8 @@ module Git.Queue ( Queue, new, - add, + addCommand, + addUpdateIndex, size, full, flush, @@ -25,23 +26,40 @@ import Common import Git import Git.Command +import qualified Git.UpdateIndex + +{- Queable actions that can be performed in a git repository. + -} +data Action + {- Updating the index file, using a list of streamers that can + - be added to as the queue grows. -} + = UpdateIndexAction + { getStreamers :: [Git.UpdateIndex.Streamer] -- in reverse order + } + {- A git command to run, on a list of files that can be added to + - as the queue grows. -} + | CommandAction + { getSubcommand :: String + , getParams :: [CommandParam] + , getFiles :: [FilePath] + } -{- An action to perform in a git repository. The file to act on - - is not included, and must be able to be appended after the params. -} -data Action = Action - { getSubcommand :: String - , getParams :: [CommandParam] - } deriving (Show, Eq, Ord) +{- A key that can uniquely represent an action in a Map. -} +data ActionKey = UpdateIndexActionKey | CommandActionKey String + deriving (Eq, Ord) +actionKey :: Action -> ActionKey +actionKey (UpdateIndexAction _) = UpdateIndexActionKey +actionKey CommandAction { getSubcommand = s } = CommandActionKey s + {- A queue of actions to perform (in any order) on a git repository, - with lists of files to perform them on. This allows coalescing - similar git commands. -} data Queue = Queue { size :: Int , _limit :: Int - , _items :: M.Map Action [FilePath] + , items :: M.Map ActionKey Action } - deriving (Show, Eq) {- A recommended maximum size for the queue, after which it should be - run. @@ -59,17 +77,57 @@ new :: Maybe Int -> Queue new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty -{- Adds an action to a queue. -} -add :: Queue -> String -> [CommandParam] -> [FilePath] -> Queue -add (Queue cur lim m) subcommand params files = Queue (cur + 1) lim m' +{- Adds an git command to the queue. + - + - Git commands with the same subcommand but different parameters are + - assumed to be equivilant enough to perform in any order with the same + - result. + -} +addCommand :: String -> [CommandParam] -> [FilePath] -> Queue -> Repo -> IO Queue +addCommand subcommand params files q repo = + updateQueue action different (length newfiles) q repo where - action = Action subcommand params - -- There are probably few items in the map, but there - -- can be a lot of files per item. So, optimise adding - -- files. - m' = M.insertWith' const action fs m - !fs = files ++ M.findWithDefault [] action m + key = actionKey action + action = CommandAction + { getSubcommand = subcommand + , getParams = params + , getFiles = newfiles + } + newfiles = files ++ maybe [] getFiles (M.lookup key $ items q) + + different (CommandAction { getSubcommand = s }) = s /= subcommand + different _ = True +{- Adds an update-index streamer to the queue. -} +addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue +addUpdateIndex streamer q repo = + updateQueue action different 1 q repo + where + key = actionKey action + -- the list is built in reverse order + action = UpdateIndexAction $ streamer : streamers + streamers = maybe [] getStreamers $ M.lookup key $ items q + + different (UpdateIndexAction _) = False + different _ = True + +{- Updates or adds an action in the queue. If the queue already contains a + - different action, it will be flushed; this is to ensure that conflicting + - actions, like add and rm, are run in the right order.-} +updateQueue :: Action -> (Action -> Bool) -> Int -> Queue -> Repo -> IO Queue +updateQueue !action different sizeincrease q repo + | null (filter different (M.elems (items q))) = return $ go q + | otherwise = go <$> flush q repo + where + go q' = newq + where + !newq = q' + { size = newsize + , items = newitems + } + !newsize = size q' + sizeincrease + !newitems = M.insertWith' const (actionKey action) action (items q') + {- Is a queue large enough that it should be flushed? -} full :: Queue -> Bool full (Queue cur lim _) = cur > lim @@ -77,7 +135,7 @@ {- Runs a queue on a git repository. -} flush :: Queue -> Repo -> IO Queue flush (Queue _ lim m) repo = do - forM_ (M.toList m) $ uncurry $ runAction repo + forM_ (M.elems m) $ runAction repo return $ Queue 0 lim M.empty {- Runs an Action on a list of files in a git repository. @@ -86,12 +144,15 @@ - - Intentionally runs the command even if the list of files is empty; - this allows queueing commands that do not need a list of files. -} -runAction :: Repo -> Action -> [FilePath] -> IO () -runAction repo action files = +runAction :: Repo -> Action -> IO () +runAction repo (UpdateIndexAction streamers) = + -- list is stored in reverse order + Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers +runAction repo action@(CommandAction {}) = pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs where params = toCommand $ gitCommandLine (Param (getSubcommand action):getParams action) repo feedxargs h = do fileEncoding h - hPutStr h $ join "\0" files + hPutStr h $ join "\0" $ getFiles action diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -63,3 +63,11 @@ readObjectType "tree" = Just TreeObject readObjectType _ = Nothing +{- Types of blobs. -} +data BlobType = FileBlob | ExecutableBlob | SymlinkBlob + +{- Git uses magic numbers to denote the type of a blob. -} +instance Show BlobType where + show FileBlob = "100644" + show ExecutableBlob = "100755" + show SymlinkBlob = "120000" diff --git a/Git/UnionMerge.hs b/Git/UnionMerge.hs --- a/Git/UnionMerge.hs +++ b/Git/UnionMerge.hs @@ -7,7 +7,7 @@ module Git.UnionMerge ( merge, - merge_index + mergeIndex ) where import qualified Data.Text.Lazy as L @@ -22,6 +22,7 @@ import Git.UpdateIndex import Git.HashObject import Git.Types +import Git.FilePath {- Performs a union merge between two branches, staging it in the index. - Any previously staged changes in the index will be lost. @@ -31,40 +32,40 @@ merge :: Ref -> Ref -> Repo -> IO () merge x y repo = do h <- catFileStart repo - stream_update_index repo - [ ls_tree x repo - , merge_trees x y h repo + streamUpdateIndex repo + [ lsTree x repo + , mergeTrees x y h repo ] catFileStop h -{- Merges a list of branches into the index. Previously staged changed in +{- Merges a list of branches into the index. Previously staged changes in - the index are preserved (and participate in the merge). -} -merge_index :: CatFileHandle -> Repo -> [Ref] -> IO () -merge_index h repo bs = - stream_update_index repo $ map (\b -> merge_tree_index b h repo) bs +mergeIndex :: CatFileHandle -> Repo -> [Ref] -> IO () +mergeIndex h repo bs = + streamUpdateIndex repo $ map (\b -> mergeTreeIndex b h repo) bs {- For merging two trees. -} -merge_trees :: Ref -> Ref -> CatFileHandle -> Repo -> Streamer -merge_trees (Ref x) (Ref y) h = calc_merge h $ "diff-tree":diff_opts ++ [x, y] +mergeTrees :: Ref -> Ref -> CatFileHandle -> Repo -> Streamer +mergeTrees (Ref x) (Ref y) h = doMerge h $ "diff-tree":diffOpts ++ [x, y] {- For merging a single tree into the index. -} -merge_tree_index :: Ref -> CatFileHandle -> Repo -> Streamer -merge_tree_index (Ref x) h = calc_merge h $ - "diff-index" : diff_opts ++ ["--cached", x] +mergeTreeIndex :: Ref -> CatFileHandle -> Repo -> Streamer +mergeTreeIndex (Ref x) h = doMerge h $ + "diff-index" : diffOpts ++ ["--cached", x] -diff_opts :: [String] -diff_opts = ["--raw", "-z", "-r", "--no-renames", "-l0"] +diffOpts :: [String] +diffOpts = ["--raw", "-z", "-r", "--no-renames", "-l0"] -{- Calculates how to perform a merge, using git to get a raw diff, - - and generating update-index input. -} -calc_merge :: CatFileHandle -> [String] -> Repo -> Streamer -calc_merge ch differ repo streamer = gendiff >>= go +{- Streams update-index changes to perform a merge, + - using git to get a raw diff. -} +doMerge :: CatFileHandle -> [String] -> Repo -> Streamer +doMerge ch differ repo streamer = gendiff >>= go where gendiff = pipeNullSplit (map Param differ) repo go [] = noop go (info:file:rest) = mergeFile info file ch repo >>= maybe (go rest) (\l -> streamer l >> go rest) - go (_:[]) = error "calc_merge parse error" + go (_:[]) = error $ "parse error " ++ show differ {- Given an info line from a git raw diff, and the filename, generates - a line suitable for update-index that union merges the two sides of the @@ -73,13 +74,15 @@ mergeFile info file h repo = case filter (/= nullSha) [Ref asha, Ref bsha] of [] -> return Nothing (sha:[]) -> use sha - shas -> use =<< either return (hashObject repo BlobObject . unlines) =<< - calcMerge . zip shas <$> mapM getcontents shas + shas -> use + =<< either return (\s -> hashObject BlobObject (unlines s) repo) + =<< calcMerge . zip shas <$> mapM getcontents shas where [_colonmode, _bmode, asha, bsha, _status] = words info getcontents s = map L.unpack . L.lines . L.decodeUtf8 <$> catObject h s - use sha = return $ Just $ update_index_line sha file + use sha = return $ Just $ + updateIndexLine sha FileBlob $ asTopFilePath file {- Calculates a union merge between a list of refs, with contents. - diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -5,26 +5,38 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-} + module Git.UpdateIndex ( Streamer, - stream_update_index, - update_index_line, - ls_tree + pureStreamer, + streamUpdateIndex, + lsTree, + updateIndexLine, + unstageFile, + stageSymlink ) where import System.Cmd.Utils import Common import Git +import Git.Types import Git.Command +import Git.FilePath +import Git.Sha {- Streamers are passed a callback and should feed it lines in the form - read by update-index, and generated by ls-tree. -} type Streamer = (String -> IO ()) -> IO () +{- A streamer with a precalculated value. -} +pureStreamer :: String -> Streamer +pureStreamer !s = \streamer -> streamer s + {- Streams content into update-index from a list of Streamers. -} -stream_update_index :: Repo -> [Streamer] -> IO () -stream_update_index repo as = do +streamUpdateIndex :: Repo -> [Streamer] -> IO () +streamUpdateIndex repo as = do (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo) fileEncoding h forM_ as (stream h) @@ -37,13 +49,30 @@ hPutStr h s hPutStr h "\0" +{- A streamer that adds the current tree for a ref. Useful for eg, copying + - and modifying branches. -} +lsTree :: Ref -> Repo -> Streamer +lsTree (Ref x) repo streamer = mapM_ streamer =<< pipeNullSplit params repo + where + params = map Param ["ls-tree", "-z", "-r", "--full-tree", x] + {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -} -update_index_line :: Sha -> FilePath -> String -update_index_line sha file = "100644 blob " ++ show sha ++ "\t" ++ file +updateIndexLine :: Sha -> BlobType -> TopFilePath -> String +updateIndexLine sha filetype file = + show filetype ++ " blob " ++ show sha ++ "\t" ++ getTopFilePath file -{- Gets the current tree for a ref. -} -ls_tree :: Ref -> Repo -> Streamer -ls_tree (Ref x) repo streamer = mapM_ streamer =<< pipeNullSplit params repo - where - params = map Param ["ls-tree", "-z", "-r", "--full-tree", x] +{- A streamer that removes a file from the index. -} +unstageFile :: FilePath -> Repo -> IO Streamer +unstageFile file repo = do + p <- toTopFilePath file repo + return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ getTopFilePath p + +{- A streamer that adds a symlink to the index. -} +stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer +stageSymlink file sha repo = do + !line <- updateIndexLine + <$> pure sha + <*> pure SymlinkBlob + <*> toTopFilePath file repo + return $ pureStreamer line diff --git a/GitAnnex.hs b/GitAnnex.hs --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -58,6 +58,7 @@ import qualified Command.Map import qualified Command.Upgrade import qualified Command.Version +import qualified Command.Watch cmds :: [Command] cmds = concat @@ -99,6 +100,7 @@ , Command.Map.def , Command.Upgrade.def , Command.Version.def + , Command.Watch.def ] options :: [Option] diff --git a/INSTALL b/INSTALL --- a/INSTALL +++ b/INSTALL @@ -10,6 +10,7 @@ * [[NixOS]] * [[Gentoo]] * Windows: [[sorry, not possible yet|todo/windows_support]] +* [[ScientificLinux5]] - This should cover RHEL5 clones such as CentOS5 and so on ## Using cabal @@ -41,6 +42,9 @@ * [IfElse](http://hackage.haskell.org/package/IfElse) * [bloomfilter](http://hackage.haskell.org/package/bloomfilter) * [edit-distance](http://hackage.haskell.org/package/edit-distance) + * [stm](http://hackage.haskell.org/package/stm) + * [hinotify](http://hackage.haskell.org/package/hinotify) + (optional; Linux only) * Shell commands * [git](http://git-scm.com/) * [uuid](http://www.ossp.org/pkg/lib/uuid/) @@ -51,6 +55,8 @@ * [sha1sum](ftp://ftp.gnu.org/gnu/coreutils/) (optional, but recommended; a sha1 command will also do) * [gpg](http://gnupg.org/) (optional; needed for encryption) + * [lsof](ftp://lsof.itap.purdue.edu/pub/tools/unix/lsof/) + (optional; recommended for watch mode) * [ikiwiki](http://ikiwiki.info) (optional; used to build the docs) Then just [[download]] git-annex and run: `make; make install` diff --git a/Locations.hs b/Locations.hs --- a/Locations.hs +++ b/Locations.hs @@ -23,6 +23,9 @@ gitAnnexIndex, gitAnnexIndexLock, gitAnnexIndexDirty, + gitAnnexPidFile, + gitAnnexDaemonStatusFile, + gitAnnexLogFile, gitAnnexSshDir, gitAnnexRemotesDir, isLinkToAnnex, @@ -145,6 +148,18 @@ gitAnnexIndexDirty :: Git.Repo -> FilePath gitAnnexIndexDirty r = gitAnnexDir r "index.dirty" +{- Pid file for daemon mode. -} +gitAnnexPidFile :: Git.Repo -> FilePath +gitAnnexPidFile r = gitAnnexDir r "daemon.pid" + +{- Status file for daemon mode. -} +gitAnnexDaemonStatusFile :: Git.Repo -> FilePath +gitAnnexDaemonStatusFile r = gitAnnexDir r "daemon.status" + +{- Log file for daemon mode. -} +gitAnnexLogFile :: Git.Repo -> FilePath +gitAnnexLogFile r = gitAnnexDir r "daemon.log" + {- .git/annex/ssh/ is used for ssh connection caching -} gitAnnexSshDir :: Git.Repo -> FilePath gitAnnexSshDir r = addTrailingPathSeparator $ gitAnnexDir r "ssh" @@ -155,7 +170,7 @@ {- Checks a symlink target to see if it appears to point to annexed content. -} isLinkToAnnex :: FilePath -> Bool -isLinkToAnnex s = ("/" ++ d) `isInfixOf` s || d `isPrefixOf` s +isLinkToAnnex s = ('/':d) `isInfixOf` s || d `isPrefixOf` s where d = ".git" objectDir diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,20 +1,28 @@ +bins=git-annex +mans=git-annex.1 git-annex-shell.1 +sources=Build/SysConfig.hs Utility/Touch.hs +all=$(bins) $(mans) docs + +OS:=$(shell uname | sed 's/[-_].*//') +ifeq ($(OS),Linux) +BASEFLAGS_OPTS+=-DWITH_INOTIFY +clibs=Utility/libdiskfree.o +else +BASEFLAGS_OPTS+=-DWITH_KQUEUE +clibs=Utility/libdiskfree.o Utility/libkqueue.o +endif + PREFIX=/usr IGNORE=-ignore-package monads-fd -ignore-package monads-tf -BASEFLAGS=-Wall $(IGNORE) -outputdir tmp -IUtility -DWITH_S3 +BASEFLAGS=-Wall $(IGNORE) -outputdir tmp -IUtility -DWITH_S3 $(BASEFLAGS_OPTS) GHCFLAGS=-O2 $(BASEFLAGS) +CFLAGS=-Wall ifdef PROFILE GHCFLAGS=-prof -auto-all -rtsopts -caf-all -fforce-recomp $(BASEFLAGS) endif GHCMAKE=ghc $(GHCFLAGS) --make - -bins=git-annex -mans=git-annex.1 git-annex-shell.1 -sources=Build/SysConfig.hs Utility/Touch.hs -clibs=Utility/libdiskfree.o - -all=$(bins) $(mans) docs # Am I typing :make in vim? Do a fast build. ifdef VIM diff --git a/Messages.hs b/Messages.hs --- a/Messages.hs +++ b/Messages.hs @@ -183,7 +183,7 @@ fileEncoding stderr handle :: IO () -> IO () -> Annex () -handle json normal = withOutputType $ go +handle json normal = withOutputType go where go NormalOutput = liftIO normal go QuietOutput = q diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -7,7 +7,7 @@ module Remote.Bup (remote) where -import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString.Lazy as L import qualified Data.Map as M import System.Process diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -7,8 +7,8 @@ module Remote.Directory (remote) where -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S import qualified Data.Map as M import qualified Control.Exception as E diff --git a/Remote/Hook.hs b/Remote/Hook.hs --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -7,7 +7,7 @@ module Remote.Hook (remote) where -import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString.Lazy as L import qualified Data.Map as M import System.Exit import System.Environment diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -7,7 +7,7 @@ module Remote.Rsync (remote) where -import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString.Lazy as L import qualified Data.Map as M import Common.Annex @@ -100,7 +100,7 @@ f = keyFile k store :: RsyncOpts -> Key -> Annex Bool -store o k = rsyncSend o k =<< inRepo (gitAnnexLocation k) +store o k = rsyncSend o k <=< inRepo $ gitAnnexLocation k storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do diff --git a/Seek.hs b/Seek.hs --- a/Seek.hs +++ b/Seek.hs @@ -95,7 +95,7 @@ -} withField :: Option -> (Maybe String -> Annex a) -> (a -> CommandSeek) -> CommandSeek withField option converter = withValue $ - converter =<< Annex.getField (Option.name option) + converter <=< Annex.getField $ Option.name option withFlag :: Option -> (Bool -> CommandSeek) -> CommandSeek withFlag option = withValue $ Annex.getFlag (Option.name option) diff --git a/Types/Backend.hs b/Types/Backend.hs --- a/Types/Backend.hs +++ b/Types/Backend.hs @@ -10,13 +10,7 @@ module Types.Backend where import Types.Key - -{- The source used to generate a key. The location of the content - - may be different from the filename associated with the key. -} -data KeySource = KeySource - { keyFilename :: FilePath - , contentLocation :: FilePath - } +import Types.KeySource data BackendA a = Backend { name :: String diff --git a/Types/KeySource.hs b/Types/KeySource.hs new file mode 100644 --- /dev/null +++ b/Types/KeySource.hs @@ -0,0 +1,22 @@ +{- KeySource data type + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Types.KeySource where + +{- When content is in the process of being added to the annex, + - and a Key generated from it, this data type is used. + - + - The contentLocation may be different from the filename + - associated with the key. For example, the add command + - temporarily puts the content into a lockdown directory + - for checking. The migrate command uses the content + - of a different Key. -} +data KeySource = KeySource + { keyFilename :: FilePath + , contentLocation :: FilePath + } + deriving (Show) diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -94,7 +94,7 @@ link <- calcGitLink f k liftIO $ removeFile f liftIO $ createSymbolicLink link f - Annex.Queue.add "add" [Param "--"] [f] + Annex.Queue.addCommand "add" [Param "--"] [f] moveLocationLogs :: Annex () moveLocationLogs = do @@ -121,9 +121,9 @@ old <- liftIO $ readLog1 f new <- liftIO $ readLog1 dest liftIO $ writeLog1 dest (old++new) - Annex.Queue.add "add" [Param "--"] [dest] - Annex.Queue.add "add" [Param "--"] [f] - Annex.Queue.add "rm" [Param "--quiet", Param "-f", Param "--"] [f] + Annex.Queue.addCommand "add" [Param "--"] [dest] + Annex.Queue.addCommand "add" [Param "--"] [f] + Annex.Queue.addCommand "rm" [Param "--quiet", Param "-f", Param "--"] [f] oldlog2key :: FilePath -> Maybe (FilePath, Key) oldlog2key l diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -84,7 +84,7 @@ logFiles :: FilePath -> Annex [FilePath] logFiles dir = return . filter (".log" `isSuffixOf`) - =<< liftIO (getDirectoryContents dir) + <=< liftIO $ getDirectoryContents dir push :: Annex () push = do diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs new file mode 100644 --- /dev/null +++ b/Utility/Daemon.hs @@ -0,0 +1,72 @@ +{- daemon support + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Daemon where + +import Common + +import System.Posix + +{- Run an action as a daemon, with all output sent to a file descriptor. + - + - Can write its pid to a file, to guard against multiple instances + - running and allow easy termination. + - + - When successful, does not return. -} +daemonize :: Fd -> Maybe FilePath -> Bool -> IO () -> IO () +daemonize logfd pidfile changedirectory a = do + _ <- forkProcess child1 + out + where + child1 = do + _ <- createSession + _ <- forkProcess child2 + out + child2 = do + maybe noop (lockPidFile True alreadyrunning) pidfile + when changedirectory $ + setCurrentDirectory "/" + nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags + _ <- redir nullfd stdInput + mapM_ (redir logfd) [stdOutput, stdError] + closeFd logfd + a + out + redir newh h = do + closeFd h + dupTo newh h + alreadyrunning = error "Daemon is already running." + out = exitImmediately ExitSuccess + +lockPidFile :: Bool -> IO () -> FilePath -> IO () +lockPidFile write onfailure file = do + fd <- openFd file ReadWrite (Just stdFileMode) + defaultFileFlags { trunc = write } + locked <- catchMaybeIO $ setLock fd (locktype, AbsoluteSeek, 0, 0) + case locked of + Nothing -> onfailure + _ -> when write $ void $ + fdWrite fd =<< show <$> getProcessID + where + locktype + | write = WriteLock + | otherwise = ReadLock + +{- Stops the daemon. + - + - The pid file is used to get the daemon's pid. + - + - To guard against a stale pid, try to take a nonblocking shared lock + - of the pid file. If this *fails*, the daemon must be running, + - and have the exclusive lock, so the pid file is trustworthy. + -} +stopDaemon :: FilePath -> IO () +stopDaemon pidfile = lockPidFile False go pidfile + where + go = do + pid <- readish <$> readFile pidfile + maybe noop (signalProcess sigTERM) pid diff --git a/Utility/DirWatcher.hs b/Utility/DirWatcher.hs new file mode 100644 --- /dev/null +++ b/Utility/DirWatcher.hs @@ -0,0 +1,90 @@ +{- generic directory watching interface + - + - Uses either inotify or kqueue to watch a directory (and subdirectories) + - for changes, and runs hooks for different sorts of events as they occur. + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Utility.DirWatcher where + +import Utility.Types.DirWatcher + +#if WITH_INOTIFY +import qualified Utility.INotify as INotify +import qualified System.INotify as INotify +import Utility.ThreadScheduler +#endif +#if WITH_KQUEUE +import qualified Utility.Kqueue as Kqueue +#endif + +type Pruner = FilePath -> Bool + +canWatch :: Bool +#if (WITH_INOTIFY || WITH_KQUEUE) +canWatch = True +#else +#if defined linux_HOST_OS +#warning "Building without inotify support" +#endif +canWatch = False +#endif + +/* With inotify, discrete events will be received when making multiple changes + * to the same filename. For example, adding it, deleting it, and adding it + * again will be three events. + * + * OTOH, with kqueue, often only one event is received, indicating the most + * recent state of the file. + */ +eventsCoalesce :: Bool +#if WITH_INOTIFY +eventsCoalesce = False +#else +#if WITH_KQUEUE +eventsCoalesce = True +#else +eventsCoalesce = undefined +#endif +#endif + +/* With inotify, file closing is tracked to some extent, so an add event + * will always be received for a file once its writer closes it, and + * (typically) not before. This may mean multiple add events for the same file. + * + * OTOH, with kqueue, add events will often be received while a file is + * still being written to, and then no add event will be received once the + * writer closes it. + */ +closingTracked :: Bool +#if WITH_INOTIFY +closingTracked = True +#else +#if WITH_KQUEUE +closingTracked = False +#else +closingTracked = undefined +#endif +#endif + +#if WITH_INOTIFY +watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO () +watchDir dir prune hooks runstartup = INotify.withINotify $ \i -> do + runstartup $ INotify.watchDir i dir prune hooks + waitForTermination -- Let the inotify thread run. +#else +#if WITH_KQUEUE +watchDir :: FilePath -> Pruner -> WatchHooks -> (IO Kqueue.Kqueue -> IO Kqueue.Kqueue) -> IO () +watchDir dir ignored hooks runstartup = do + kq <- runstartup $ Kqueue.initKqueue dir ignored + Kqueue.runHooks kq hooks +#else +watchDir :: FilePath -> Pruner -> WatchHooks -> (IO () -> IO ()) -> IO () +watchDir = undefined +#endif +#endif diff --git a/Utility/Directory.hs b/Utility/Directory.hs --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -10,12 +10,11 @@ import System.IO.Error import System.Posix.Files import System.Directory -import Control.Exception (throw) +import Control.Exception (throw, bracket_) import Control.Monad import Control.Monad.IfElse import System.FilePath import Control.Applicative -import Control.Exception (bracket_) import System.Posix.Directory import System.IO.Unsafe (unsafeInterleaveIO) @@ -35,7 +34,7 @@ dirContents :: FilePath -> IO [FilePath] dirContents d = map (d ) . filter (not . dirCruft) <$> getDirectoryContents d -{- Gets contents of directory, and then its subdirectories, recursively, +{- Gets files in a directory, and then its subdirectories, recursively, - and lazily. -} dirContentsRecursive :: FilePath -> IO [FilePath] dirContentsRecursive topdir = dirContentsRecursive' topdir [""] @@ -87,6 +86,13 @@ case r of (Left _) -> return False (Right s) -> return $ isDirectory s + +{- Removes a file, which may or may not exist. + - + - Note that an exception is thrown if the file exists but + - cannot be removed. -} +nukeFile :: FilePath -> IO () +nukeFile file = whenM (doesFileExist file) $ removeFile file {- Runs an action in another directory. -} bracketCd :: FilePath -> IO a -> IO a diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -13,6 +13,8 @@ import System.IO import System.IO.Unsafe import qualified Data.Hash.MD5 as MD5 +import Data.Word +import Data.Bits.Utils {- Sets a Handle to use the filesystem encoding. This causes data - written or read from it to be encoded/decoded the same @@ -29,7 +31,7 @@ withFilePath fp f = Encoding.getFileSystemEncoding >>= \enc -> GHC.withCString enc fp f -{- Encodes a FilePath into a Str, applying the filesystem encoding. +{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. - - This use of unsafePerformIO is belived to be safe; GHC's interface - only allows doing this conversion with CStrings, and the CString buffer @@ -41,3 +43,15 @@ encodeFilePath fp = MD5.Str $ unsafePerformIO $ do enc <- Encoding.getFileSystemEncoding GHC.withCString enc fp $ GHC.peekCString Encoding.char8 + +{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. + - + - w82c produces a String, which may contain Chars that are invalid + - unicode. From there, this is really a simple matter of applying the + - file system encoding, only complicated by GHC's interface to doing so. + -} +{-# NOINLINE encodeW8 #-} +encodeW8 :: [Word8] -> FilePath +encodeW8 w8 = unsafePerformIO $ do + enc <- Encoding.getFileSystemEncoding + GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -7,7 +7,7 @@ module Utility.Gpg where -import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString.Lazy as L import System.Posix.Types import Control.Applicative import Control.Concurrent diff --git a/Utility/INotify.hs b/Utility/INotify.hs new file mode 100644 --- /dev/null +++ b/Utility/INotify.hs @@ -0,0 +1,171 @@ +{- higher-level inotify interface + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.INotify where + +import Common hiding (isDirectory) +import Utility.ThreadLock +import Utility.Types.DirWatcher + +import System.INotify +import qualified System.Posix.Files as Files +import System.IO.Error +import Control.Exception (throw) + +{- Watches for changes to files in a directory, and all its subdirectories + - that are not ignored, using inotify. This function returns after + - its initial scan is complete, leaving a thread running. Callbacks are + - made for different events. + - + - Inotify is weak at recursive directory watching; the whole directory + - tree must be scanned and watches set explicitly for each subdirectory. + - + - To notice newly created subdirectories, inotify is used, and + - watches are registered for those directories. There is a race there; + - things can be added to a directory before the watch gets registered. + - + - To close the inotify race, each time a new directory is found, it also + - recursively scans it, assuming all files in it were just added, + - and registering each subdirectory. + - + - Note: Due to the race amelioration, multiple add events may occur + - for the same file. + - + - Note: Moving a file will cause events deleting it from its old location + - and adding it to the new location. + - + - Note: Modification of files is not detected, and it's assumed that when + - a file that was open for write is closed, it's finished being written + - to, and can be added. + - + - Note: inotify has a limit to the number of watches allowed, + - /proc/sys/fs/inotify/max_user_watches (default 8192). + - So this will fail if there are too many subdirectories. The + - errHook is called when this happens. + -} +watchDir :: INotify -> FilePath -> (FilePath -> Bool) -> WatchHooks -> IO () +watchDir i dir ignored hooks + | ignored dir = noop + | otherwise = do + -- Use a lock to make sure events generated during initial + -- scan come before real inotify events. + lock <- newLock + let handler event = withLock lock (void $ go event) + void (addWatch i watchevents dir handler) + `catchIO` failedaddwatch + withLock lock $ + mapM_ scan =<< filter (not . dirCruft) <$> + getDirectoryContents dir + where + recurse d = watchDir i d ignored hooks + + -- Select only inotify events required by the enabled + -- hooks, but always include Create so new directories can + -- be scanned. + watchevents = Create : addevents ++ delevents + addevents + | hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite] + | otherwise = [] + delevents + | hashook delHook || hashook delDirHook = [MoveOut, Delete] + | otherwise = [] + + scan f = unless (ignored f) $ do + ms <- getstatus f + case ms of + Nothing -> return () + Just s + | Files.isDirectory s -> + recurse $ indir f + | Files.isSymbolicLink s -> + runhook addSymlinkHook f ms + | Files.isRegularFile s -> + runhook addHook f ms + | otherwise -> + noop + + -- Ignore creation events for regular files, which won't be + -- done being written when initially created, but handle for + -- directories and symlinks. + go (Created { isDirectory = isd, filePath = f }) + | isd = recurse $ indir f + | hashook addSymlinkHook = + checkfiletype Files.isSymbolicLink addSymlinkHook f + | otherwise = noop + -- Closing a file is assumed to mean it's done being written. + go (Closed { isDirectory = False, maybeFilePath = Just f }) = + checkfiletype Files.isRegularFile addHook f + -- When a file or directory is moved in, scan it to add new + -- stuff. + go (MovedIn { filePath = f }) = scan f + go (MovedOut { isDirectory = isd, filePath = f }) + | isd = runhook delDirHook f Nothing + | otherwise = runhook delHook f Nothing + -- Verify that the deleted item really doesn't exist, + -- since there can be spurious deletion events for items + -- in a directory that has been moved out, but is still + -- being watched. + go (Deleted { isDirectory = isd, filePath = f }) + | isd = guarded $ runhook delDirHook f Nothing + | otherwise = guarded $ runhook delHook f Nothing + where + guarded = unlessM (filetype (const True) f) + go _ = noop + + hashook h = isJust $ h hooks + + runhook h f s + | ignored f = noop + | otherwise = maybe noop (\a -> a (indir f) s) (h hooks) + + indir f = dir f + + getstatus f = catchMaybeIO $ getSymbolicLinkStatus $ indir f + checkfiletype check h f = do + ms <- getstatus f + case ms of + Just s + | check s -> runhook h f ms + _ -> noop + filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f) + + -- Inotify fails when there are too many watches with a + -- disk full error. + failedaddwatch e + | isFullError e = + case errHook hooks of + Nothing -> throw e + Just hook -> tooManyWatches hook dir + | otherwise = throw e + +tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO () +tooManyWatches hook dir = do + sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer) + hook (unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval) Nothing + where + maxwatches = "fs.inotify.max_user_watches" + basewarning = "Too many directories to watch! (Not watching " ++ dir ++")" + withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"] + withsysctl n = let new = n * 10 in + [ "Increase the limit permanently by running:" + , " echo " ++ maxwatches ++ "=" ++ show new ++ + " | sudo tee -a /etc/sysctl.conf; sudo sysctl -p" + , "Or temporarily by running:" + , " sudo sysctl -w " ++ maxwatches ++ "=" ++ show new + ] + +querySysctl :: Read a => [CommandParam] -> IO (Maybe a) +querySysctl ps = do + v <- catchMaybeIO $ hPipeFrom "sysctl" $ toCommand ps + case v of + Nothing -> return Nothing + Just (pid, h) -> do + val <- parsesysctl <$> hGetContentsStrict h + void $ getProcessStatus True False $ processID pid + return val + where + parsesysctl s = readish =<< lastMaybe (words s) diff --git a/Utility/Inotify.hs b/Utility/Inotify.hs deleted file mode 100644 --- a/Utility/Inotify.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Utility.Inotify where - -import Common hiding (isDirectory) -import System.INotify -import qualified System.Posix.Files as Files -import System.Posix.Terminal -import Control.Concurrent.MVar -import System.Posix.Signals - -demo :: IO () -demo = withINotify $ \i -> do - watchDir i (const True) (Just add) (Just del) "/home/joey/tmp/me" - putStrLn "started" - waitForTermination - where - add file = putStrLn $ "add " ++ file - del file = putStrLn $ "del " ++ file - -{- Watches for changes to files in a directory, and all its subdirectories - - that match a test, using inotify. This function returns after its initial - - setup is complete, leaving a thread running. Then callbacks are made for - - adding and deleting files. - - - - Inotify is weak at recursive directory watching; the whole directory - - tree must be walked and watches set explicitly for each subdirectory. - - - - To notice newly created subdirectories, inotify is used, and - - watches are registered for those directories. There is a race there; - - things can be added to a directory before the watch gets registered. - - - - To close the inotify race, each time a new directory is found, it also - - recursively scans it, assuming all files in it were just added, - - and registering each subdirectory. - - - - Note: Due to the race amelioration, multiple add events may occur - - for the same file. - - - - Note: Moving a file may involve deleting it from its old location and - - adding it to the new location. - - - - Note: Modification of files is not detected, and it's assumed that when - - a file that was open for write is closed, it's done being written - - to, and can be added. - - - - Note: inotify has a limit to the number of watches allowed, - - /proc/sys/fs/inotify/max_user_watches (default 8192). - - So This will fail if there are too many subdirectories. - -} -watchDir :: INotify -> (FilePath -> Bool) -> Maybe (FilePath -> IO ()) -> Maybe (FilePath -> IO ()) -> FilePath -> IO () -watchDir i test add del dir = watchDir' False i test add del dir -watchDir' :: Bool -> INotify -> (FilePath -> Bool) -> Maybe (FilePath -> IO ()) -> Maybe (FilePath -> IO ()) -> FilePath -> IO () -watchDir' scan i test add del dir = do - if test dir - then void $ do - _ <- addWatch i watchevents dir go - mapM walk =<< dirContents dir - else noop - where - watchevents - | isJust add && isJust del = - [Create, MoveIn, MoveOut, Delete, CloseWrite] - | isJust add = [Create, MoveIn, CloseWrite] - | isJust del = [Create, MoveOut, Delete] - | otherwise = [Create] - - recurse = watchDir' scan i test add del - walk f = ifM (catchBoolIO $ Files.isDirectory <$> getFileStatus f) - ( recurse f - , when (scan && isJust add) $ fromJust add f - ) - - go (Created { isDirectory = False }) = noop - go (Created { filePath = subdir }) = Just recurse <@> subdir - go (Closed { maybeFilePath = Just f }) = add <@> f - go (MovedIn { isDirectory = False, filePath = f }) = add <@> f - go (MovedOut { isDirectory = False, filePath = f }) = del <@> f - go (Deleted { isDirectory = False, filePath = f }) = del <@> f - go _ = noop - - Just a <@> f = a $ dir f - Nothing <@> _ = noop - -{- Pauses the main thread, letting children run until program termination. -} -waitForTermination :: IO () -waitForTermination = do - mv <- newEmptyMVar - check softwareTermination mv - whenM (queryTerminal stdInput) $ - check keyboardSignal mv - takeMVar mv - where - check sig mv = void $ - installHandler sig (CatchOnce $ putMVar mv ()) Nothing diff --git a/Utility/Kqueue.hs b/Utility/Kqueue.hs new file mode 100644 --- /dev/null +++ b/Utility/Kqueue.hs @@ -0,0 +1,248 @@ +{- BSD kqueue file modification notification interface + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE ForeignFunctionInterface #-} + +module Utility.Kqueue ( + Kqueue, + initKqueue, + stopKqueue, + waitChange, + Change(..), + changedFile, + isAdd, + isDelete, + runHooks, +) where + +import Common +import Utility.Types.DirWatcher + +import System.Posix.Types +import Foreign.C.Types +import Foreign.C.Error +import Foreign.Ptr +import Foreign.Marshal +import qualified Data.Map as M +import qualified Data.Set as S +import qualified System.Posix.Files as Files +import Control.Concurrent + +data Change + = Deleted FilePath + | Added FilePath + deriving (Show) + +isAdd :: Change -> Bool +isAdd (Added _) = True +isAdd (Deleted _) = False + +isDelete :: Change -> Bool +isDelete = not . isAdd + +changedFile :: Change -> FilePath +changedFile (Added f) = f +changedFile (Deleted f) = f + +data Kqueue = Kqueue + { kqueueFd :: Fd + , kqueueTop :: FilePath + , kqueueMap :: DirMap + , _kqueuePruner :: Pruner + } + +type Pruner = FilePath -> Bool + +type DirMap = M.Map Fd DirInfo + +{- A directory, and its last known contents (with filenames relative to it) -} +data DirInfo = DirInfo + { dirName :: FilePath + , dirCache :: S.Set FilePath + } + deriving (Show) + +getDirInfo :: FilePath -> IO DirInfo +getDirInfo dir = do + contents <- S.fromList . filter (not . dirCruft) + <$> getDirectoryContents dir + return $ DirInfo dir contents + +{- Difference between the dirCaches of two DirInfos. -} +(//) :: DirInfo -> DirInfo -> [Change] +oldc // newc = deleted ++ added + where + deleted = calc Deleted oldc newc + added = calc Added newc oldc + calc a x y = map a . map (dirName x ) $ + S.toList $ S.difference (dirCache x) (dirCache y) + +{- Builds a map of directories in a tree, possibly pruning some. + - Opens each directory in the tree, and records its current contents. -} +scanRecursive :: FilePath -> Pruner -> IO DirMap +scanRecursive topdir prune = M.fromList <$> walk [] [topdir] + where + walk c [] = return c + walk c (dir:rest) + | prune dir = walk c rest + | otherwise = do + minfo <- catchMaybeIO $ getDirInfo dir + case minfo of + Nothing -> walk c rest + Just info -> do + mfd <- catchMaybeIO $ + openFd dir ReadOnly Nothing defaultFileFlags + case mfd of + Nothing -> walk c rest + Just fd -> do + let subdirs = map (dir ) $ + S.toList $ dirCache info + walk ((fd, info):c) (subdirs ++ rest) + +{- Adds a list of subdirectories (and all their children), unless pruned to a + - directory map. Adding a subdirectory that's already in the map will + - cause its contents to be refreshed. -} +addSubDirs :: DirMap -> Pruner -> [FilePath] -> IO DirMap +addSubDirs dirmap prune dirs = do + newmap <- foldr M.union M.empty <$> + mapM (\d -> scanRecursive d prune) dirs + return $ M.union newmap dirmap -- prefer newmap + +{- Removes a subdirectory (and all its children) from a directory map. -} +removeSubDir :: DirMap -> FilePath -> IO DirMap +removeSubDir dirmap dir = do + mapM_ closeFd $ M.keys toremove + return rest + where + (toremove, rest) = M.partition (dirContains dir . dirName) dirmap + +findDirContents :: DirMap -> FilePath -> [FilePath] +findDirContents dirmap dir = concatMap absolutecontents $ search + where + absolutecontents i = map (dirName i ) (S.toList $ dirCache i) + search = map snd $ M.toList $ + M.filter (\i -> dirName i == dir) dirmap + +foreign import ccall unsafe "libkqueue.h init_kqueue" c_init_kqueue + :: IO Fd +foreign import ccall unsafe "libkqueue.h addfds_kqueue" c_addfds_kqueue + :: Fd -> CInt -> Ptr Fd -> IO () +foreign import ccall unsafe "libkqueue.h waitchange_kqueue" c_waitchange_kqueue + :: Fd -> IO Fd + +{- Initializes a Kqueue to watch a directory, and all its subdirectories. -} +initKqueue :: FilePath -> Pruner -> IO Kqueue +initKqueue dir pruned = do + dirmap <- scanRecursive dir pruned + h <- c_init_kqueue + let kq = Kqueue h dir dirmap pruned + updateKqueue kq + return kq + +{- Updates a Kqueue, adding watches for its map. -} +updateKqueue :: Kqueue -> IO () +updateKqueue (Kqueue h _ dirmap _) = + withArrayLen (M.keys dirmap) $ \fdcnt c_fds -> do + c_addfds_kqueue h (fromIntegral fdcnt) c_fds + +{- Stops a Kqueue. Note: Does not directly close the Fds in the dirmap, + - so it can be reused. -} +stopKqueue :: Kqueue -> IO () +stopKqueue = closeFd . kqueueFd + +{- Waits for a change on a Kqueue. + - May update the Kqueue. + -} +waitChange :: Kqueue -> IO (Kqueue, [Change]) +waitChange kq@(Kqueue h _ dirmap _) = do + changedfd <- c_waitchange_kqueue h + if changedfd == -1 + then ifM ((==) eINTR <$> getErrno) + (yield >> waitChange kq, nochange) + else case M.lookup changedfd dirmap of + Nothing -> nochange + Just info -> handleChange kq changedfd info + where + nochange = return (kq, []) + +{- The kqueue interface does not tell what type of change took place in + - the directory; it could be an added file, a deleted file, a renamed + - file, a new subdirectory, or a deleted subdirectory, or a moved + - subdirectory. + - + - So to determine this, the contents of the directory are compared + - with its last cached contents. The Kqueue is updated to watch new + - directories as necessary. + -} +handleChange :: Kqueue -> Fd -> DirInfo -> IO (Kqueue, [Change]) +handleChange kq@(Kqueue _ _ dirmap pruner) fd olddirinfo = + go =<< catchMaybeIO (getDirInfo $ dirName olddirinfo) + where + go (Just newdirinfo) = do + let changes = olddirinfo // newdirinfo + let (added, deleted) = partition isAdd changes + + -- Scan newly added directories to add to the map. + -- (Newly added files will fail getDirInfo.) + newdirinfos <- catMaybes <$> + mapM (catchMaybeIO . getDirInfo . changedFile) added + newmap <- addSubDirs dirmap pruner $ map dirName newdirinfos + + -- Remove deleted directories from the map. + newmap' <- foldM removeSubDir newmap (map changedFile deleted) + + -- Update the cached dirinfo just looked up. + let newmap'' = M.insertWith' const fd newdirinfo newmap' + + -- When new directories were added, need to update + -- the kqueue to watch them. + let kq' = kq { kqueueMap = newmap'' } + unless (null newdirinfos) $ + updateKqueue kq' + + return (kq', changes) + go Nothing = do + -- The directory has been moved or deleted, so + -- remove it from our map. + newmap <- removeSubDir dirmap (dirName olddirinfo) + return (kq { kqueueMap = newmap }, []) + +{- Processes changes on the Kqueue, calling the hooks as appropriate. + - Never returns. -} +runHooks :: Kqueue -> WatchHooks -> IO () +runHooks kq hooks = do + -- First, synthetic add events for the whole directory tree contents, + -- to catch any files created beforehand. + recursiveadd (kqueueMap kq) (Added $ kqueueTop kq) + loop kq + where + loop q = do + (q', changes) <- waitChange q + forM_ changes $ dispatch (kqueueMap q') + loop q' + -- Kqueue returns changes for both whole directories + -- being added and deleted, and individual files being + -- added and deleted. + dispatch dirmap change + | isAdd change = withstatus change $ dispatchadd dirmap + | otherwise = callhook delDirHook Nothing change + dispatchadd dirmap change s + | Files.isSymbolicLink s = + callhook addSymlinkHook (Just s) change + | Files.isDirectory s = recursiveadd dirmap change + | Files.isRegularFile s = + callhook addHook (Just s) change + | otherwise = noop + recursiveadd dirmap change = do + let contents = findDirContents dirmap $ changedFile change + forM_ contents $ \f -> + withstatus (Added f) $ dispatchadd dirmap + callhook h s change = case h hooks of + Nothing -> noop + Just a -> a (changedFile change) s + withstatus change a = maybe noop (a change) =<< + (catchMaybeIO (getSymbolicLinkStatus (changedFile change))) diff --git a/Utility/LogFile.hs b/Utility/LogFile.hs new file mode 100644 --- /dev/null +++ b/Utility/LogFile.hs @@ -0,0 +1,31 @@ +{- log files + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.LogFile where + +import Common + +import System.Posix + +openLog :: FilePath -> IO Fd +openLog logfile = do + rotateLog logfile 0 + openFd logfile WriteOnly (Just stdFileMode) + defaultFileFlags { append = True } + +rotateLog :: FilePath -> Int -> IO () +rotateLog logfile num + | num >= 10 = return () + | otherwise = whenM (doesFileExist currfile) $ do + rotateLog logfile (num + 1) + renameFile currfile nextfile + where + currfile = filename num + nextfile = filename (num + 1) + filename n + | n == 0 = logfile + | otherwise = logfile ++ "." ++ show n diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs new file mode 100644 --- /dev/null +++ b/Utility/Lsof.hs @@ -0,0 +1,88 @@ +{- lsof interface + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module Utility.Lsof where + +import Common + +import System.Posix.Types + +data LsofOpenMode = OpenReadWrite | OpenReadOnly | OpenWriteOnly | OpenUnknown + deriving (Show, Eq) + +type CmdLine = String + +data ProcessInfo = ProcessInfo ProcessID CmdLine + deriving (Show) + +{- Checks each of the files in a directory to find open files. + - Note that this will find hard links to files elsewhere that are open. -} +queryDir :: FilePath -> IO [(FilePath, LsofOpenMode, ProcessInfo)] +queryDir path = query ["+d", path] + +{- Runs lsof with some parameters. + - + - Ignores nonzero exit code; lsof returns that when no files are open. + - + - Note: If lsof is not available, this always returns [] ! + -} +query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)] +query opts = do + (pid, s) <- pipeFrom "lsof" ("-F0can" : opts) + let !r = parse s + void $ getProcessStatus True False $ processID pid + return r + +{- Parsing null-delimited output like: + - + - pPID\0cCMDLINE\0 + - aMODE\0nFILE\0 + - aMODE\0nFILE\0 + - pPID\0[...] + - + - Where each new process block is started by a pid, and a process can + - have multiple files open. + -} +parse :: String -> [(FilePath, LsofOpenMode, ProcessInfo)] +parse s = bundle $ go [] $ lines s + where + bundle = concatMap (\(fs, p) -> map (\(f, m) -> (f, m, p)) fs) + + go c [] = c + go c ((t:r):ls) + | t == 'p' = + let (fs, ls') = parsefiles [] ls + in go ((fs, parseprocess r):c) ls' + | otherwise = parsefail + go _ _ = parsefail + + parseprocess l = + case splitnull l of + [pid, 'c':cmdline, ""] -> + case readish pid of + (Just n) -> ProcessInfo n cmdline + Nothing -> parsefail + _ -> parsefail + + parsefiles c [] = (c, []) + parsefiles c (l:ls) = + case splitnull l of + ['a':mode, 'n':file, ""] -> + parsefiles ((file, parsemode mode):c) ls + (('p':_):_) -> (c, l:ls) + _ -> parsefail + + parsemode ('r':_) = OpenReadOnly + parsemode ('w':_) = OpenWriteOnly + parsemode ('u':_) = OpenReadWrite + parsemode _ = OpenUnknown + + splitnull = split "\0" + + parsefail = error $ "failed to parse lsof output: " ++ show s diff --git a/Utility/ThreadLock.hs b/Utility/ThreadLock.hs new file mode 100644 --- /dev/null +++ b/Utility/ThreadLock.hs @@ -0,0 +1,19 @@ +{- locking between threads + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.ThreadLock where + +import Control.Concurrent.MVar + +type Lock = MVar () + +newLock :: IO Lock +newLock = newMVar () + +{- Runs an action with a lock held, so only one thread at a time can run it. -} +withLock :: Lock -> IO a -> IO a +withLock lock = withMVar lock . const diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs new file mode 100644 --- /dev/null +++ b/Utility/ThreadScheduler.hs @@ -0,0 +1,57 @@ +{- thread scheduling + - + - Copyright 2012 Joey Hess + - Copyright 2011 Bas van Dijk & Roel van Dijk + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.ThreadScheduler where + +import Common + +import Control.Concurrent +import System.Posix.Terminal +import System.Posix.Signals + +newtype Seconds = Seconds { fromSeconds :: Int } + deriving (Eq, Ord, Show) + +{- Runs an action repeatedly forever, sleeping at least the specified number + - of seconds in between. -} +runEvery :: Seconds -> IO a -> IO a +runEvery n a = forever $ do + threadDelaySeconds n + a + +threadDelaySeconds :: Seconds -> IO () +threadDelaySeconds (Seconds n) = unboundDelay (fromIntegral n * oneSecond) + where + oneSecond = 1000000 -- microseconds + +{- Like threadDelay, but not bounded by an Int. + - + - There is no guarantee that the thread will be rescheduled promptly when the + - delay has expired, but the thread will never continue to run earlier than + - specified. + - + - Taken from the unbounded-delay package to avoid a dependency for 4 lines + - of code. + -} +unboundDelay :: Integer -> IO () +unboundDelay time = do + let maxWait = min time $ toInteger (maxBound :: Int) + threadDelay $ fromInteger maxWait + when (maxWait /= time) $ unboundDelay (time - maxWait) + +{- Pauses the main thread, letting children run until program termination. -} +waitForTermination :: IO () +waitForTermination = do + lock <- newEmptyMVar + check softwareTermination lock + whenM (queryTerminal stdInput) $ + check keyboardSignal lock + takeMVar lock + where + check sig lock = void $ + installHandler sig (CatchOnce $ putMVar lock ()) Nothing diff --git a/Utility/Types/DirWatcher.hs b/Utility/Types/DirWatcher.hs new file mode 100644 --- /dev/null +++ b/Utility/Types/DirWatcher.hs @@ -0,0 +1,22 @@ +{- generic directory watching types + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Utility.Types.DirWatcher where + +import Common + +type Hook a = Maybe (a -> Maybe FileStatus -> IO ()) + +data WatchHooks = WatchHooks + { addHook :: Hook FilePath + , addSymlinkHook :: Hook FilePath + , delHook :: Hook FilePath + , delDirHook :: Hook FilePath + , errHook :: Hook String -- error message + } diff --git a/Utility/libdiskfree.c b/Utility/libdiskfree.c --- a/Utility/libdiskfree.c +++ b/Utility/libdiskfree.c @@ -22,23 +22,15 @@ # define STATCALL statfs /* statfs64 not yet tested on a real FreeBSD machine */ # define STATSTRUCT statfs #else -#if defined (__FreeBSD_kernel__) /* Debian kFreeBSD */ -# include -# include -# define STATCALL statfs64 -# define STATSTRUCT statfs -# warning free space checking code temporarily disabled due to build failure -# define UNKNOWN -#else -#if defined (__linux__) -/* This is a POSIX standard, so might also work elsewhere. */ +#if defined (__linux__) || defined (__FreeBSD_kernel__) +/* Linux or Debian kFreeBSD */ +/* This is a POSIX standard, so might also work elsewhere too. */ # include # define STATCALL statvfs # define STATSTRUCT statvfs #else # warning free space checking code not available for this OS # define UNKNOWN -#endif #endif #endif #endif diff --git a/Utility/libkqueue.c b/Utility/libkqueue.c new file mode 100644 --- /dev/null +++ b/Utility/libkqueue.c @@ -0,0 +1,73 @@ +/* kqueue interface, C mini-library + * + * Copyright 2012 Joey Hess + * + * Licensed under the GNU GPL version 3 or higher. + */ + +#include +#include +#include +#include +#include +#include +#include +#include + +/* The specified fds are added to the set of fds being watched for changes. + * Fds passed to prior calls still take effect, so it's most efficient to + * not pass the same fds repeatedly. + * + * Returns the fd that changed, or -1 on error. + */ +signed int helper(const int kq, const int fdcnt, const int *fdlist, int nodelay) { + int i, nev; + struct kevent evlist[1]; + struct kevent chlist[fdcnt]; + struct timespec avoiddelay = {0, 0}; + struct timespec *timeout = nodelay ? &avoiddelay : NULL; + + for (i = 0; i < fdcnt; i++) { + EV_SET(&chlist[i], fdlist[i], EVFILT_VNODE, + EV_ADD | EV_ENABLE | EV_CLEAR, + NOTE_WRITE, + 0, 0); + } + + nev = kevent(kq, chlist, fdcnt, evlist, 1, timeout); + if (nev == 1) + return evlist[0].ident; + else + return -1; +} + +/* Initializes a new, empty kqueue. */ +int init_kqueue() { + int kq; + if ((kq = kqueue()) == -1) { + perror("kqueue"); + exit(1); + } + return kq; +} + +/* Adds fds to the set that should be watched. */ +void addfds_kqueue(const int kq, const int fdcnt, const int *fdlist) { + helper(kq, fdcnt, fdlist, 1); +} + +/* Waits for a change event on a kqueue. */ +signed int waitchange_kqueue(const int kq) { + return helper(kq, 0, NULL, 0); +} + +/* +main () { + int list[1]; + int kq; + list[0]=open(".", O_RDONLY); + kq = init_kqueue(); + addfds_kqueue(kq, 1, list) + printf("change: %i\n", waitchange_kqueue(kq)); +} +*/ diff --git a/Utility/libkqueue.h b/Utility/libkqueue.h new file mode 100644 --- /dev/null +++ b/Utility/libkqueue.h @@ -0,0 +1,3 @@ +int init_kqueue(); +void addfds_kqueue(const int kq, const int fdcnt, const int *fdlist); +signed int waitchange_kqueue(const int kq); diff --git a/Utility/libkqueue.o b/Utility/libkqueue.o new file mode 100644 Binary files /dev/null and b/Utility/libkqueue.o differ diff --git a/debian/.changelog.swp b/debian/.changelog.swp deleted file mode 100644 Binary files a/debian/.changelog.swp and /dev/null differ diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,4 +1,16 @@ -git-annex (3.20120615) unstable; urgency=medium +git-annex (3.20120624) unstable; urgency=low + + * watch: New subcommand, a daemon which notices changes to + files and automatically annexes new files, etc, so you don't + need to manually run git commands when manipulating files. + Available on Linux, BSDs, and OSX! + * Enable diskfree on kfreebsd, using kqueue. + * unused: Fix crash when key names contain invalid utf8. + * sync: Avoid recent git's interactive merge. + + -- Joey Hess Sun, 24 Jun 2012 12:36:50 -0400 + +git-annex (3.20120614) unstable; urgency=medium * addurl: Was broken by a typo introduced 2 released ago, now fixed. Closes: #677576 diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -20,6 +20,8 @@ libghc-ifelse-dev, libghc-bloomfilter-dev, libghc-edit-distance-dev, + libghc-hinotify-dev [linux-any], + libghc-stm-dev, ikiwiki, perlmagick, git, @@ -40,6 +42,7 @@ rsync, wget | curl, openssh-client (>= 1:5.6p1) +Recommends: lsof Suggests: graphviz, bup, gnupg Description: manage files with git, without checking their contents into git git-annex allows managing files with git, without checking the file diff --git a/doc/bugs/git_annex_unused_aborts_due_to_filename_encoding_problems.mdwn b/doc/bugs/git_annex_unused_aborts_due_to_filename_encoding_problems.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/git_annex_unused_aborts_due_to_filename_encoding_problems.mdwn @@ -0,0 +1,15 @@ +What steps will reproduce the problem? +I don't know exactly when it started + +What is the expected output? What do you see instead? +When I run git annex unused I get + + unused . (checking for unused data...) (checking master...) git-annex: Cannot decode byte '\xb4': Data.Text.Encoding.decodeUtf8: Invalid UTF-8 stream + +Most likely I have added some file with a strange encoding that git-annex can't decode. The problem is that the unused process aborts because of this. + +What version of git-annex are you using? On what operating system? + 3.20120522, Debian testing + +> I've just fixed this bug in git, will be in the next release. --[[Joey]] +> [[done]] diff --git a/doc/bugs/watch_command_on_OSX_10.7.mdwn b/doc/bugs/watch_command_on_OSX_10.7.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/watch_command_on_OSX_10.7.mdwn @@ -0,0 +1,37 @@ +Running the tip of the watch branch on OSX in an annex'ed directory. + +The watch command detects the changes, does _something_, see the output below. + +Output from watch command + +
+(Recording state in git...)
+Added "./KeePass2.18.dmg"
+Added "./KeePassX-0.4.3.dmg"
+add ./KeePass2.18.dmg (checksum...) ok
+add ./KeePassX-0.4.3.dmg (checksum...) ok
+
+ +State of the annex + +
+laplace:annex jtang$ git status
+# On branch master
+# Untracked files:
+#   (use "git add ..." to include in what will be committed)
+#
+#	KeePass2.18.dmg
+#	KeePassX-0.4.3.dmg
+nothing added to commit but untracked files present (use "git add" to track)
+
+ +It seems to not do a git add and commit after the creation of the symlinks, manually doing this makes it all happy again till more files are added. + +note: i had posted a comment in the blog post, but posting the issue here is probably more appropriate. + +> Yeah, this is the issue I was struggling with last night. +> I think it's fixed in 57cf65eb6d811ba7fd19eb62a54e3b83a0c2dfa7, +> but the kqueue watch still needs a lot of work. --[[Joey]] + +>> Confirmed this is fixed, but do note the known kqueue bugs in +>> [[design/assistant/inotify]]! [[done]] --[[Joey]] diff --git a/doc/design/assistant/blog/day_10__lsof.mdwn b/doc/design/assistant/blog/day_10__lsof.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_10__lsof.mdwn @@ -0,0 +1,54 @@ +A rather frustrating and long day coding went like this: + +## 1-3 pm + +Wrote a single function, of which all any Haskell programmer needs to know +is its type signature: + + Lsof.queryDir :: FilePath -> IO [(FilePath, LsofOpenMode, ProcessInfo)] + +When I'm spending another hour or two taking a unix utility like lsof and +parsing its output, which in this case is in a rather complicated +machine-parsable output format, I often wish unix streams were strongly +typed, which would avoid this bother. + +## 3-9 pm + +Six hours spent making it defer annexing files until the commit thread +wakes up and is about to make a commit. Why did it take so horribly long? +Well, there were a number of complications, and some really bad bugs +involving races that were hard to reproduce reliably enough to deal with. + +In other words, I was lost in the weeds for a lot of those hours... + +At one point, something glorious happened, and it was always making exactly +one commit for batch mode modifications of a lot of files (like untarring +them). Unfortunatly, I had to lose that gloriousness due to another +potential race, which, while unlikely, would have made the program deadlock +if it happened. + +So, it's back to making 2 or 3 commits per batch mode change. I also have a +buglet that causes sometimes a second empty commit after a file is added. +I know why (the inotify event for the symlink gets in late, +after the commit); will try to improve commit frequency later. + +## 9-11 pm + +Put the capstone on the day's work, by calling lsof on a directory full +of hardlinks to the files that are about to be annexed, to check if any +are still open for write. + +This works great! Starting up `git annex watch` when processes have files +open is no longer a problem, and even if you're evil enough to try having +muliple processes open the same file, it will complain and not annex it +until all the writers close it. + +(Well, someone really evil could turn the write bit back on after git annex +clears it, and open the file again, but then really evil people can do +that to files in `.git/annex/objects` too, and they'll get their just +deserts when `git annex fsck` runs. So, that's ok..) + +---- + +Anyway, will beat on it more tomorrow, and if all is well, this will finally +go out to the beta testers. diff --git a/doc/design/assistant/blog/day_11__freebsd.mdwn b/doc/design/assistant/blog/day_11__freebsd.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_11__freebsd.mdwn @@ -0,0 +1,50 @@ +I've been investigating how to make `git annex watch` work on +FreeBSD, and by extension, OSX. + +One option is kqueue, which works on both operating systems, and allows +very basic monitoring of file changes. There's also an OSX specific +hfsevents interface. + +Kqueue is far from optimal for `git annex watch`, because it provides even +less information than inotify (which didn't really provide everything I +needed, thus the lsof hack). Kqueue doesn't have events for files being +closed, only an event when a file is created. So it will be difficult for +`git annex watch` to know when a file is done being written to and can be +annexed. git annex will probably need to run lsof periodically to check when +recently added files are complete. (hsevents shares this limitation) + +Kqueue also doesn't provide specific events when a file or directory is +moved. Indeed, it doesn't provide specific events about what changed at +all. All you get with kqueue is a generic "oh hey, the directory you're +watching changed in some way", and it's up to you to scan it to work out +how. So git annex will probably need to run `git ls-tree --others` +to find changes in the directory tree. This could be expensive with large +trees. (hsevents has per-file events on current versions of OSX) + +Despite these warts, I want to try kqueue first, since it's more portable +than hfsevents, and will surely be easier for me to develop support for, +since I don't have direct access to OSX. + +So I went to a handy Debian kFreeBSD porter box, and tried some kqueue +stuff to get a feel for it. I got a python program that does basic +directory monitoring with kqueue to work, so I know it's usable there. + +Next step was getting kqueue working from Haskell. Should be easy, there's +a Haskell library already. I spent a while trying to get it to work on +Debian kFreeBSD, but ran into a +[problem](https://github.com/hesselink/kqueue/issues/1) that could be +caused by the Debian kFreeBSD being different, or just a bug in the Haskell +library. I didn't want to spend too long shaving this yak; I might install +"real" FreeBSD on a spare laptop and try to get it working there instead. + +But for now, I've dropped down to C instead, and have a simple C program +that can monitor a directory with kqueue. Next I'll turn it into a simple +library, which can easily be linked into my Haskell code. The Haskell code +will pass it a set of open directory descriptors, and it'll return the +one that it gets an event on. This is necessary because kqueue doesn't +recurse into subdirectories on its own. + +I've generally had good luck with this approach to adding stuff in Haskell; +rather than writing a bit-banging and structure packing low level interface +in Haskell, write it in C, with a simpler interface between C and +Haskell. diff --git a/doc/design/assistant/blog/day_12__freebsd_redux.mdwn b/doc/design/assistant/blog/day_12__freebsd_redux.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_12__freebsd_redux.mdwn @@ -0,0 +1,23 @@ +Followed my plan from yesterday, and wrote a simple C library to interface +to `kqueue`, and Haskell code to use that library. By now I think I +understand kqueue fairly well -- there are some very tricky parts to the +interface. + +But... it still did't work. After building all this, my code was +failing the same way that the +[haskell kqueue library failed](https://github.com/hesselink/kqueue/issues/1) +yesterday. I filed a [bug report with a testcase](). + +Then I thought to ask on #haskell. Got sorted out in quick order! The +problem turns out to be that haskell's runtime has a peridic SIGALARM, +that is interrupting my kevent call. It can be worked around with `+RTS -V0`, +but I put in a fix to retry to kevent when it's interrupted. + +And now `git-annex watch` can detect changes to directories on BSD and OSX! + +Note: I said "detect", not "do something useful in response to". Getting +from the limited kqueue events to actually staging changes in the git repo +is going to be another day's work. Still, brave FreeBSD or OSX users +might want to check out the `watch` branch from git and see if +`git annex watch` will at least *say* it sees changes you make to your +repository. diff --git a/doc/design/assistant/blog/day_13__kqueue_continued.mdwn b/doc/design/assistant/blog/day_13__kqueue_continued.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_13__kqueue_continued.mdwn @@ -0,0 +1,34 @@ +Good news! My beta testers report that the new kqueue code works on OSX. +At least "works" as well as it does on Debian kFreeBSD. My crazy +development strategy of developing on Debian kFreeBSD while targeting Mac +OSX is vindicated. ;-) + +So, I've been beating the kqueue code into shape for the last 12 hours, +minus a few hours sleep. + +First, I noticed it was seeming to starve the other threads. I'm using +Haskell's non-threaded runtime, which does cooperative multitasking between +threads, and my C code was never returning to let the other threads run. +Changed that around, so the C code runs until SIGALARMed, and then that +thread calls `yield` before looping back into the C code. Wow, cooperative +multitasking.. I last dealt with that when programming for Windows 3.1! +(Should try to use Haskell's -threaded runtime sometime, but git-annex +doesn't work under it, and I have not tried to figure out why not.) + +Then I made a [single commit](http://source.git-annex.branchable.com/?p=source.git;a=commitdiff;h=2bfcc0b09c5dd37c5e0ab65cb089232bfcc31934), +with no testing, in which I made the kqueue code maintain a cache of what +it expects in the directory tree, and use that to determine what files +changed how when a change is detected. Serious code. It worked on the +first go. If you were wondering why I'm writing in Haskell ... yeah, +that's why. + +And I've continued to hammer on the kqueue code, making lots of little +fixes, and at this point it seems *almost* able to handle the changes I +throw at it. It does have one big remaining problem; kqueue doesn't tell me +when a writer closes a file, so it will sometimes miss adding files. To fix +this, I'm going to need to make it maintain a queue of new files, and +periodically check them, with `lsof`, to see when they're done being +written to, and add them to the annex. So while a file is being written +to, `git annex watch` will have to wake up every second or so, and run +`lsof` ... and it'll take it at least 1 second to notice a file's complete. +Not ideal, but the best that can be managed with kqueue. diff --git a/doc/design/assistant/blog/day_14__kqueue_kqueue_kqueue.mdwn b/doc/design/assistant/blog/day_14__kqueue_kqueue_kqueue.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_14__kqueue_kqueue_kqueue.mdwn @@ -0,0 +1,23 @@ +... I'm getting tired of kqueue. + +But the end of the tunnel is in sight. Today I made git-annex handle files +that are still open for write after a kqueue creation event is received. +Unlike with inotify, which has a new event each time a file is closed, +kqueue only gets one event when a file is first created, and so git-annex +needs to retry adding files until there are no writers left. + +Eventually I found an elegant way to do that. The committer thread already +wakes up every second as long as there's a pending change to commit. So for +adds that need to be retried, it can just push them back onto the change +queue, and the committer thread will wait one second and retry the add. One +second might be too frequent to check, but it will do for now. + +This means that `git annex watch` should now be usable on OSX, FreeBSD, and +NetBSD! (It'll also work on Debian kFreeBSD once [lsof is ported to it](http://bugs.debian.org/589103).) +I've meged kqueue support to `master`. + +I also think I've squashed the empty commits that were sometimes made. + +Incidentally, I'm 50% through my first month, and finishing [[inotify]] +was the first half of my roadmap for this month. Seem to be right on +schedule.. Now I need to start thinking about [[syncing]]. diff --git a/doc/design/assistant/blog/day_14__thinking_about_syncing.mdwn b/doc/design/assistant/blog/day_14__thinking_about_syncing.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_14__thinking_about_syncing.mdwn @@ -0,0 +1,44 @@ +Pondering [[syncing]] today. I will be doing syncing of the git repository +first, and working on syncing of file data later. + +The former seems straightforward enough, since we just want to push all +changes to everywhere. Indeed, git-annex already has a [[sync]] command +that uses a smart technique to allow syncing between clones without a +central bare repository. (Props to Joachim Breitner for that.) + +But it's not all easy. Syncing should happen as fast as possible, so +changes show up without delay. Eventually it'll need to support syncing +between nodes that cannot directly contact one-another. Syncing needs to +deal with nodes coming and going; one example of that is a USB drive being +plugged in, which should immediatly be synced, but network can also come +and go, so it should periodically retry nodes it failed to sync with. To +start with, I'll be focusing on fast syncing between directly connected +nodes, but I have to keep this wider problem space in mind. + +One problem with `git annex sync` is that it has to be run in both clones +in order for changes to fully propigate. This is because git doesn't allow +pushing changes into a non-bare repository; so instead it drops off a new +branch in `.git/refs/remotes/$foo/synced/master`. Then when it's run locally +it merges that new branch into `master`. + +So, how to trigger a clone to run `git annex sync` when syncing to it? +Well, I just realized I have spent two weeks developing something that can +be repurposed to do that! [[Inotify]] can watch for changes to +`.git/refs/remotes`, and the instant a change is made, the local sync +process can be started. This avoids needing to make another ssh connection +to trigger the sync, so is faster and allows the data to be transferred +over another protocol than ssh, which may come in handy later. + +So, in summary, here's what will happen when a new file is created: + +1. inotify event causes the file to be added to the annex, and + immediately committed. +2. new branch is pushed to remotes (probably in parallel) +3. remotes notice new sync branch and merge it +4. (data sync, TBD later) +5. file is fully synced and available + +Steps 1, 2, and 3 should all be able to be accomplished in under a second. +The speed of `git push` making a ssh connection will be the main limit +to making it fast. (Perhaps I should also reuse git-annex's existing ssh +connection caching code?) diff --git a/doc/design/assistant/blog/day_15__its_aliiive.mdwn b/doc/design/assistant/blog/day_15__its_aliiive.mdwn new file mode 100644 --- /dev/null +++ b/doc/design/assistant/blog/day_15__its_aliiive.mdwn @@ -0,0 +1,33 @@ +Syncing works! I have two clones, and any file I create in the first +is immediately visible in the second. Delete that file from the second, and +it's immediately removed from the first. + +Most of my work today felt like stitching existing limbs onto a pre-existing +monster. Took the committer thread, that waits for changes and commits them, +and refashioned it into a pusher thread, that waits for commits and pushes +them. Took the watcher thread, that watches for files being made, +and refashioned it into a merger thread, that watches for git refs being +updated. Pulled in bits of the `git annex sync` command to reanimate this. + +It may be a shambling hulk, but it works. + +Actually, it's not much of a shambling hulk; I refactored my code after +copying it. ;) + +I think I'm up to 11 threads now in the new +`git annex assistant` command, each with its own job, and each needing +to avoid stepping on the other's toes. I did see one MVar deadlock error +today, which I have not managed to reproduce after some changes. I think +the committer thread was triggering the merger thread, which probably +then waited on the Annex state MVar the committer thread had held. + +Anyway, it even pushes to remotes in parallel, and keeps track of remotes +it failed to push to, although as of yet it doesn't do any attempt at +periodically retrying. + +One bug I need to deal with is that the push code assumes any change +made to the remote has already been pushed back to it. When it hasn't, +the push will fail due to not being a fast-forward. I need to make it +detect this case and pull before pushing. + +(I've pushed this work out in a new `assistant branch`.) diff --git a/doc/design/assistant/comment_8_22b818e1a2a825efb78139271a14f944._comment b/doc/design/assistant/comment_8_22b818e1a2a825efb78139271a14f944._comment new file mode 100644 --- /dev/null +++ b/doc/design/assistant/comment_8_22b818e1a2a825efb78139271a14f944._comment @@ -0,0 +1,10 @@ +[[!comment format=mdwn + username="https://www.google.com/accounts/o8/id?id=AItOawldKnauegZulM7X6JoHJs7Gd5PnDjcgx-E" + nickname="Matt" + subject="Homebrew instead of MacPorts" + date="2012-06-22T04:26:02Z" + content=""" +[Homebrew] is a much better package manager than MacPorts IMO. + +[Homebrew]: http://mxcl.github.com/homebrew/ +"""]] diff --git a/doc/design/assistant/inotify.mdwn b/doc/design/assistant/inotify.mdwn --- a/doc/design/assistant/inotify.mdwn +++ b/doc/design/assistant/inotify.mdwn @@ -1,58 +1,68 @@ -Finish "git annex watch" command, which runs, in the background, watching via -inotify for changes, and automatically annexing new files, etc. +"git annex watch" command, which runs, in the background, watching via +inotify for changes, and automatically annexing new files, etc. Now +available! -There is a `watch` branch in git that adds the command. +[[!toc]] ## known bugs -* A process has a file open for write, another one closes it, - and so it's added. Then the first process modifies it. +* If a file is checked into git as a normal file and gets modified + (or merged, etc), it will be converted into an annexed file. + See [[blog/day_7__bugfixes]] - Or, a process has a file open for write when `git annex watch` starts - up, it will be added to the annex. If the process later continues - writing, it will change content in the annex. +* When you `git annex unlock` a file, it will immediately be re-locked. - This changes content in the annex, and fsck will later catch - the inconsistency. +* Kqueue has to open every directory it watches, so too many directories + will run it out of the max number of open files (typically 1024), and fail. + I may need to fork off multiple watcher processes to handle this. - Possible fixes: +## beyond Linux - * Somehow track or detect if a file is open for write by any processes. - `lsof` could be used, although it would be a little slow. +I'd also like to support OSX and if possible the BSDs. - Here's one way to avoid the slowdown: When a file is being added, - set it read-only, and hard-link it into a quarantine directory, - remembering both filenames. - Then use the batch change mode code to detect batch adds and bundle - them together. - Just before committing, lsof the quarantine directory. Any files in - it that are still open for write can just have their write bit turned - back on and be deleted from quarantine, to be handled when their writer - closes. Files that pass quarantine get added as usual. This avoids - repeated lsof calls slowing down adds, but does add a constant factor - overhead (0.25 seconds lsof call) before any add gets committed. +* kqueue ([haskell bindings](http://hackage.haskell.org/package/kqueue)) + is supported by FreeBSD, OSX, and other BSDs. - * Or, when possible, making a copy on write copy before adding the file - would avoid this. - * Or, as a last resort, make an expensive copy of the file and add that. - * Tracking file opens and closes with inotify could tell if any other - processes have the file open. But there are problems.. It doesn't - seem to differentiate between files opened for read and for write. - And there would still be a race after the last close and before it's - injected into the annex, where it could be opened for write again. - Would need to detect that and undo the annex injection or something. + In kqueue, to watch for changes to a file, you have to have an open file + descriptor to the file. This wouldn't scale. -* If a file is checked into git as a normal file and gets modified - (or merged, etc), it will be converted into an annexed file. - See [[blog/day_7__bugfixes]] + Apparently, a directory can be watched, and events are generated when + files are added/removed from it. You then have to scan to find which + files changed. [example](https://developer.apple.com/library/mac/#samplecode/FileNotification/Listings/Main_c.html#//apple_ref/doc/uid/DTS10003143-Main_c-DontLinkElementID_3) -* When you `git annex unlock` a file, it will immediately be re-locked. + Gamin does the best it can with just kqueue, supplimented by polling. + The source file `server/gam_kqueue.c` makes for interesting reading. + Using gamin to do the heavy lifting is one option. + ([haskell bindings](http://hackage.haskell.org/package/hlibfam) for FAM; + gamin shares the API) + kqueue does not seem to provide a way to tell when a file gets closed, + only when it's initially created. Poses problems.. + + * [man page](http://www.freebsd.org/cgi/man.cgi?query=kqueue&apropos=0&sektion=0&format=html) + * (good example program) + +* hfsevents ([haskell bindings](http://hackage.haskell.org/package/hfsevents)) + is OSX specific. + + Originally it was only directory level, and you were only told a + directory had changed and not which file. Based on the haskell + binding's code, from OSX 10.7.0, file level events were added. + + This will be harder for me to develop for, since I don't have access to + OSX machines.. + + hfsevents does not seem to provide a way to tell when a file gets closed, + only when it's initially created. Poses problems.. + + * + * (good example program) + * (good example program) + +* Windows has a Win32 ReadDirectoryChangesW, and perhaps other things. + ## todo -- Support OSes other than Linux; it only uses inotify currently. - OSX and FreeBSD use the same mechanism, and there is a Haskell interface - for it, - Run niced and ioniced? Seems to make sense, this is a background job. - configurable option to only annex files meeting certian size or filename criteria @@ -140,3 +150,40 @@ - coleasce related add/rm events for speed and less disk IO **done** - don't annex `.gitignore` and `.gitattributes` files **done** - run as a daemon **done** +- A process has a file open for write, another one closes it, + and so it's added. Then the first process modifies it. + + Or, a process has a file open for write when `git annex watch` starts + up, it will be added to the annex. If the process later continues + writing, it will change content in the annex. + + This changes content in the annex, and fsck will later catch + the inconsistency. + + Possible fixes: + + * Somehow track or detect if a file is open for write by any processes. + `lsof` could be used, although it would be a little slow. + + Here's one way to avoid the slowdown: When a file is being added, + set it read-only, and hard-link it into a quarantine directory, + remembering both filenames. + Then use the batch change mode code to detect batch adds and bundle + them together. + Just before committing, lsof the quarantine directory. Any files in + it that are still open for write can just have their write bit turned + back on and be deleted from quarantine, to be handled when their writer + closes. Files that pass quarantine get added as usual. This avoids + repeated lsof calls slowing down adds, but does add a constant factor + overhead (0.25 seconds lsof call) before any add gets committed. **done** + + * Or, when possible, making a copy on write copy before adding the file + would avoid this. + * Or, as a last resort, make an expensive copy of the file and add that. + * Tracking file opens and closes with inotify could tell if any other + processes have the file open. But there are problems.. It doesn't + seem to differentiate between files opened for read and for write. + And there would still be a race after the last close and before it's + injected into the annex, where it could be opened for write again. + Would need to detect that and undo the annex injection or something. + diff --git a/doc/design/assistant/syncing.mdwn b/doc/design/assistant/syncing.mdwn --- a/doc/design/assistant/syncing.mdwn +++ b/doc/design/assistant/syncing.mdwn @@ -3,13 +3,24 @@ ## git syncing -1. At regular intervals, just run `git annex sync`, which already handles - bidirectional syncing. +1. Can use `git annex sync`, which already handles bidirectional syncing. + When a change is committed, launch the part of `git annex sync` that pushes + out changes. **done**; changes are pushed out to all remotes in parallel +1. Watch `.git/refs/remotes/` for changes (which would be pushed in from + another node via `git annex sync`), and run the part of `git annex sync` + that merges in received changes, and follow it by the part that pushes out + changes (sending them to any other remotes). + [The watching can be done with the existing inotify code! This avoids needing + any special mechanism to notify a remote that it's been synced to.] + **done** +1. Periodically retry pushes that failed. Also, detect if a push failed + due to not being up-to-date, pull, and repush. 2. Use a git merge driver that adds both conflicting files, so conflicts never break a sync. 3. Investigate the XMPP approach like dvcs-autosync does, or other ways of signaling a change out of band. -4. Add a hook, so when there's a change to sync, a program can be run. +4. Add a hook, so when there's a change to sync, a program can be run + and do its own signaling. ## data syncing diff --git a/doc/forum/Wishlist:_automatic_reinject.mdwn b/doc/forum/Wishlist:_automatic_reinject.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/Wishlist:_automatic_reinject.mdwn @@ -0,0 +1,14 @@ +I think it would be useful to supplement the `reinject` command with an automatic +mode which calculates the checksum of the source file and injects the file if it +is known to the repository (without the need to provide a destination filename). +In addition, this could be done recursively if the user provides a directory to +inject. All this can probably be done already with some plumbing, but a simple +`reinject --auto` (or `scour`, or `scavenge`, if you like) would be a nice addition. +Of course this would only work for the checksum backends. + +Example use cases would be: + +* Recovering data from lost+found easily +* Making use of old (pre-git-annex) archival volumes with useful files + scattered among non-useful files +* Sneaker-netting files between disconnected git-annex repositories diff --git a/doc/forum/autobuilders_for_git-annex_to_aid_development.mdwn b/doc/forum/autobuilders_for_git-annex_to_aid_development.mdwn --- a/doc/forum/autobuilders_for_git-annex_to_aid_development.mdwn +++ b/doc/forum/autobuilders_for_git-annex_to_aid_development.mdwn @@ -31,4 +31,4 @@ fi -It's also using the branches-local script for sorting and prioritising the branches to build, this branches-local script can be found at the [autobuild-ceph](https://github.com/ceph/autobuild-ceph/blob/master/branches-local) repository. If there are other people interested in setting up their own instances of gitbuilder for git-annex, please let me know and I will setup an aggregator page to collect status of the builds. The builder runs and updates the webpage every 30mins. +It's also using the branches-local script for sorting and prioritising the branches to build, this branches-local script can be found at the [autobuild-ceph](https://github.com/ceph/autobuild-ceph/blob/master/branches-local) repository. If there are other people interested in setting up their own instances of gitbuilder for git-annex, please let me know and I will setup an aggregator page to collect status of the builds. The builder runs and updates on a very regular basis. diff --git a/doc/forum/exporting_annexed_files.mdwn b/doc/forum/exporting_annexed_files.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/exporting_annexed_files.mdwn @@ -0,0 +1,4 @@ +Is there an easy way to export annexed files out of the repository? (e.g. to make a copy elsewhere, send a file by email...) + +Thanks, +Denis. diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -169,6 +169,17 @@ git annex import /media/camera/DCIM/ +* watch + + Watches for changes to files in the current directory and its subdirectories, + and takes care of automatically adding new files, as well as dealing with + deleted, copied, and moved files. With this running as a daemon in the + background, you no longer need to manually run git commands when + manipulating your files. + + To not daemonize, run with --foreground ; to stop a running daemon, + run with --stop + # REPOSITORY SETUP COMMANDS * init [description] diff --git a/doc/install.mdwn b/doc/install.mdwn --- a/doc/install.mdwn +++ b/doc/install.mdwn @@ -10,6 +10,7 @@ * [[NixOS]] * [[Gentoo]] * Windows: [[sorry, not possible yet|todo/windows_support]] +* [[ScientificLinux5]] - This should cover RHEL5 clones such as CentOS5 and so on ## Using cabal @@ -41,6 +42,9 @@ * [IfElse](http://hackage.haskell.org/package/IfElse) * [bloomfilter](http://hackage.haskell.org/package/bloomfilter) * [edit-distance](http://hackage.haskell.org/package/edit-distance) + * [stm](http://hackage.haskell.org/package/stm) + * [hinotify](http://hackage.haskell.org/package/hinotify) + (optional; Linux only) * Shell commands * [git](http://git-scm.com/) * [uuid](http://www.ossp.org/pkg/lib/uuid/) @@ -51,6 +55,8 @@ * [sha1sum](ftp://ftp.gnu.org/gnu/coreutils/) (optional, but recommended; a sha1 command will also do) * [gpg](http://gnupg.org/) (optional; needed for encryption) + * [lsof](ftp://lsof.itap.purdue.edu/pub/tools/unix/lsof/) + (optional; recommended for watch mode) * [ikiwiki](http://ikiwiki.info) (optional; used to build the docs) Then just [[download]] git-annex and run: `make; make install` diff --git a/doc/install/OSX/comment_7_2ce7acab15403d3f993cec94ec7f3bc6._comment b/doc/install/OSX/comment_7_2ce7acab15403d3f993cec94ec7f3bc6._comment new file mode 100644 --- /dev/null +++ b/doc/install/OSX/comment_7_2ce7acab15403d3f993cec94ec7f3bc6._comment @@ -0,0 +1,14 @@ +[[!comment format=mdwn + username="http://www.davidhaslem.com/" + nickname="David" + subject="comment 7" + date="2012-06-19T04:41:27Z" + content=""" +$(brew --prefix) should, in most cases, be /usr/local. That's the recommended install location for homebrew. + +I already had git installed and homebrew as my package manager - my install steps were as follows: + +1. brew install haskell-platform ossp-uuid md5sha1sum coreutils pcre +2. PATH=\"$(brew --prefix coreutils)/libexec/gnubin:$PATH\" cabal install git-annex + +"""]] diff --git a/doc/install/ScientificLinux5.mdwn b/doc/install/ScientificLinux5.mdwn new file mode 100644 --- /dev/null +++ b/doc/install/ScientificLinux5.mdwn @@ -0,0 +1,72 @@ +I was waiting for my backups to be done hence this article, as I was using +_git-annex_ to manage my files and I decided I needed to have +git-annex on a SL5 based machine. SL5 is just an opensource +clone/recompile of RHEL5. + +I haven't tried to install the newer versions of Haskell Platform and +GHC in a while on SL5 to install git-annex. But the last time I checked +when GHC7 was out, it was a pain to install GHC on SL5. + +However I have discovered that someone has gone through the trouble of +packaging up GHC and Haskell Platform for RHEL based distros. + +* - Packaged GHC and Haskell Platform + RPM's for RHEL based systems. + +I'm primarily interested in installing _git-annex_ on SL5 based +systems. The installation process goes as such... + +First install GHC and Haskell Platform (you need root for these +following steps) + + $ wget http://sherkin.justhub.org/el5/RPMS/x86_64/justhub-release-2.0-4.0.el5.x86_64.rpm + $ rpm -ivh justhub-release-2.0-4.0.el5.x86_64.rpm + $ yum install haskell + +The RPM's don't place the files in /usr/bin, so you must add the +following to your .bashrc (from here on you don't need root if you +don't want things to be system wide) + + $ export PATH=/usr/hs/bin:$PATH + +On SL5 pcre is at version 6.6 which is far too old for one of the +dependancies that git-annex requires. Therefore the user must install +an updated version of _pcre_ either from source or another method, I +chose to install it from source and by hand into /usr/local + + $ wget http://sourceforge.net/projects/pcre/files/pcre/8.30/pcre-8.30.tar.gz/download + $ tar zxvf pcre-8.30.tar.gz + $ cd pcre-8.30 + $ ./configure + $ make && make install + +Once the packages are installed and are in your execution path, using +cabal to configure and build git-annex just makes life easier, it +should install all the needed dependancies. + + $ cabal update + $ cabal install pcre-light --extra-include-dirs=/usr/local/include + $ git clone git://git.kitenet.net/git-annex + $ cd git-annex + $ make git-annex.1 + $ cabal configure + $ cabal build + $ cabal install + +Or if you want to install it globallly for everyone (otherwise it will +get installed into $HOME/.cabal/bin) + + $ cabal install --global + +The above will take a while to compile and install the needed +dependancies. I would suggest any user who does should run the tests +that comes with git-annex to make sure everything is functioning as +expected. + +I haven't had a chance or need to install git-annex on a SL6 based +system yet, but I would assume something similar to the above steps +would be required to do so. + +The above is almost a cut and paste of , the above could probably be refined, it was what worked for me on SL5. Please feel free to re-edit and chop out or add useless bits of text in the above! + +Note: from the minor testing, it appears the compiled binaries from SL5 will work on SL6. diff --git a/doc/news/version_3.20120511.mdwn b/doc/news/version_3.20120511.mdwn deleted file mode 100644 --- a/doc/news/version_3.20120511.mdwn +++ /dev/null @@ -1,13 +0,0 @@ -git-annex 3.20120511 released with [[!toggle text="these changes"]] -[[!toggleable text=""" - * Rsync special remotes can be configured with shellescape=no - to avoid shell quoting that is normally done when using rsync over ssh. - This is known to be needed for certian rsync hosting providers - (specificially hidrive.strato.com) that use rsync over ssh but do not - pass it through the shell. - * dropunused: Allow specifying ranges to drop. - * addunused: New command, the opposite of dropunused, it relinks unused - content into the git repository. - * Fix use of several config settings: annex.ssh-options, - annex.rsync-options, annex.bup-split-options. (And adjust types to avoid - the bugs that broke several config settings.)"""]] diff --git a/doc/news/version_3.20120522.mdwn b/doc/news/version_3.20120522.mdwn deleted file mode 100644 --- a/doc/news/version_3.20120522.mdwn +++ /dev/null @@ -1,7 +0,0 @@ -git-annex 3.20120522 released with [[!toggle text="these changes"]] -[[!toggleable text=""" - * Pass -a to cp even when it supports --reflink=auto, to preserve - permissions. - * Clean up handling of git directory and git worktree. - * Add support for core.worktree, and fix support for GIT\_WORK\_TREE and - GIT\_DIR."""]] diff --git a/doc/news/version_3.20120624.mdwn b/doc/news/version_3.20120624.mdwn new file mode 100644 --- /dev/null +++ b/doc/news/version_3.20120624.mdwn @@ -0,0 +1,9 @@ +git-annex 3.20120624 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * watch: New subcommand, a daemon which notices changes to + files and automatically annexes new files, etc, so you don't + need to manually run git commands when manipulating files. + Available on Linux, BSDs, and OSX! + * Enable diskfree on kfreebsd, using kqueue. + * unused: Fix crash when key names contain invalid utf8. + * sync: Avoid recent git's interactive merge."""]] diff --git a/git-annex.1 b/git-annex.1 --- a/git-annex.1 +++ b/git-annex.1 @@ -154,6 +154,16 @@ .IP git annex import /media/camera/DCIM/ .IP +.IP "watch" +Watches for changes to files in the current directory and its subdirectories, +and takes care of automatically adding new files, as well as dealing with +deleted, copied, and moved files. With this running as a daemon in the +background, you no longer need to manually run git commands when +manipulating your files. +.IP +To not daemonize, run with \-\-foreground ; to stop a running daemon, +run with \-\-stop +.IP .SH REPOSITORY SETUP COMMANDS .IP "init [description]" .IP diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 3.20120615 +Version: 3.20120624 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess @@ -28,13 +28,16 @@ Flag S3 Description: Enable S3 support +Flag Inotify + Description: Enable inotify support + Executable git-annex Main-Is: git-annex.hs Build-Depends: MissingH, hslogger, directory, filepath, unix, containers, utf8-string, network, mtl, bytestring, old-locale, time, pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP, base == 4.5.*, monad-control, transformers-base, lifted-base, - IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance + IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, stm -- Need to list this because it's generated from a .hsc file. Other-Modules: Utility.Touch C-Sources: Utility/libdiskfree.c @@ -44,6 +47,10 @@ Build-Depends: hS3 CPP-Options: -DWITH_S3 + if flag(Inotify) + Build-Depends: hinotify + CPP-Options: -DWITH_INOTIFY + Test-Suite test Type: exitcode-stdio-1.0 Main-Is: test.hs @@ -51,7 +58,7 @@ unix, containers, utf8-string, network, mtl, bytestring, old-locale, time, pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP, base == 4.5.*, monad-control, transformers-base, lifted-base, - IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance + IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, stm Other-Modules: Utility.Touch C-Sources: Utility/libdiskfree.c Extensions: CPP diff --git a/git-union-merge.hs b/git-union-merge.hs --- a/git-union-merge.hs +++ b/git-union-merge.hs @@ -28,7 +28,7 @@ setup = cleanup -- idempotency cleanup :: Git.Repo -> IO () -cleanup g = whenM (doesFileExist $ tmpIndex g) $ removeFile $ tmpIndex g +cleanup g = nukeFile $ tmpIndex g parseArgs :: IO [String] parseArgs = do diff --git a/make-sdist.sh b/make-sdist.sh --- a/make-sdist.sh +++ b/make-sdist.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/bin/sh # # Workaround for `cabal sdist` requiring all included files to be listed # in .cabal. diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -28,6 +28,7 @@ import qualified Git.CurrentRepo import qualified Git.Filename import qualified Locations +import qualified Types.KeySource import qualified Types.Backend import qualified Types import qualified GitAnnex @@ -172,7 +173,7 @@ git_annex "drop" ["--force", sha1annexedfile] @? "drop failed" writeFile tmp $ content sha1annexedfile r <- annexeval $ Types.Backend.getKey backendSHA1 $ - Types.Backend.KeySource { Types.Backend.keyFilename = tmp, Types.Backend.contentLocation = tmp } + Types.KeySource.KeySource { Types.KeySource.keyFilename = tmp, Types.KeySource.contentLocation = tmp } let key = show $ fromJust r git_annex "reinject" [tmp, sha1annexedfile] @? "reinject failed" git_annex "fromkey" [key, sha1annexedfiledup] @? "fromkey failed"