diff options
| -rw-r--r-- | Command/Fsck.hs | 117 |
1 files changed, 75 insertions, 42 deletions
diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 508e76966..a53963323 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -51,29 +51,29 @@ options = [fromOption, startIncrementalOption, incrementalOption] seek :: [CommandSeek] seek = [ withField fromOption Remote.byName $ \from -> - withFlag startIncrementalOption $ \startincremental -> - withFlag incrementalOption $ \incremental -> - withFilesInGit $ whenAnnexed $ - start from $ case (startincremental, incremental) of - (False, False) -> NonIncremental - (True, _) -> StartIncremental - (False, True) -> ContIncremental - , withBarePresentKeys startBare + withIncremental $ \i -> withFilesInGit $ whenAnnexed $ start from i + , withIncremental $ \i -> withBarePresentKeys $ startBare i ] -data Incremental = StartIncremental | ContIncremental | NonIncremental - deriving (Eq) +withIncremental :: (Incremental -> CommandSeek) -> CommandSeek +withIncremental a = withFlag startIncrementalOption $ \startincremental -> + withFlag incrementalOption $ \incremental -> + a $ case (startincremental, incremental) of + (False, False) -> NonIncremental + (True, _) -> StartIncremental + (False, True) -> ContIncremental start :: Maybe Remote -> Incremental -> FilePath -> (Key, Backend) -> CommandStart start from inc file (key, backend) = do numcopies <- numCopies file - showStart "fsck" file case from of - Nothing -> next $ perform inc key file backend numcopies - Just r -> next $ performRemote inc key file backend numcopies r + Nothing -> go $ perform key file backend numcopies + Just r -> go $ performRemote key file backend numcopies r + where + go = runFsck inc file key -perform :: Incremental -> Key -> FilePath -> Backend -> Maybe Int -> CommandPerform -perform inc key file backend numcopies = check +perform :: Key -> FilePath -> Backend -> Maybe Int -> Annex Bool +perform key file backend numcopies = check -- order matters [ fixLink key file , verifyLocationLog key file @@ -84,13 +84,13 @@ perform inc key file backend numcopies = check {- To fsck a remote, the content is retrieved to a tmp file, - and checked locally. -} -performRemote :: Incremental -> Key -> FilePath -> Backend -> Maybe Int -> Remote -> CommandPerform -performRemote inc key file backend numcopies remote = +performRemote :: Key -> FilePath -> Backend -> Maybe Int -> Remote -> Annex Bool +performRemote key file backend numcopies remote = dispatch =<< Remote.hasKey remote key where dispatch (Left err) = do showNote err - stop + return False dispatch (Right True) = withtmp $ \tmpfile -> ifM (getfile tmpfile) ( go True (Just tmpfile) @@ -130,30 +130,23 @@ withBarePresentKeys a params = isBareRepo >>= go error "fsck should be run without parameters in a bare repository" map a <$> loggedKeys -startBare :: Key -> CommandStart -startBare key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of +startBare :: Incremental -> Key -> CommandStart +startBare inc key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of Nothing -> stop - Just backend -> do - showStart "fsck" (key2file key) - next $ performBare key backend + Just backend -> runFsck inc (key2file key) key $ performBare key backend {- Note that numcopies cannot be checked in a bare repository, because - getting the numcopies value requires a working copy with .gitattributes - files. -} -performBare :: Key -> Backend -> CommandPerform +performBare :: Key -> Backend -> Annex Bool performBare key backend = check [ verifyLocationLog key (key2file key) , checkKeySize key , checkBackend backend key ] -check :: [Annex Bool] -> CommandPerform -check = sequence >=> dispatch - where - dispatch vs - | all (== True) vs = next $ return True - | otherwise = stop - +check :: [Annex Bool] -> Annex Bool +check cs = all id <$> sequence cs {- Checks that the file's symlink points correctly to the content. -} fixLink :: Key -> FilePath -> Annex Bool @@ -323,7 +316,37 @@ badContentRemote remote key = do return $ (if ok then "dropped from " else "failed to drop from ") ++ Remote.name remote -{- To record the time that an annexed file was last fscked, without +data Incremental = StartIncremental | ContIncremental | NonIncremental + deriving (Eq) + +runFsck :: Incremental -> FilePath -> Key -> Annex Bool -> CommandStart +runFsck inc file key a = do + starttime <- getstart + ifM (needFsck inc starttime key) + ( do + showStart "fsck" file + next $ do + ok <- a + when ok $ + recordFsckTime key + next $ return ok + , stop + ) + where + getstart + | inc == StartIncremental = Just <$> recordStartTime + | inc == ContIncremental = getStartTime + | otherwise = return Nothing + +{- Check if a key needs to be fscked, with support for incremental fscks. -} +needFsck :: Incremental -> Maybe EpochTime -> Key -> Annex Bool +needFsck ContIncremental Nothing _ = return True +needFsck ContIncremental starttime key = do + fscktime <- getFsckTime key + return $ fscktime < starttime +needFsck _ _ _ = return True + +{- To record the time that a key was last fscked, without - modifying its mtime, we set the timestamp of its parent directory. - Each annexed file is the only thing in its directory, so this is fine. - @@ -332,31 +355,41 @@ badContentRemote remote key = do - we can reuse this permission bit.) - - Note that this relies on the parent directory being deleted when a file - - is dropped. That way, if it's later added back, the fsck metadata + - is dropped. That way, if it's later added back, the fsck record - won't still be present. -} -updateMetadata :: Key -> Annex Bool -updateMetadata key = do - file <- inRepo $ gitAnnexLocation key - let parent = parentDir file - liftIO $ touchFile parent - liftIO $ setSticky parent - return True +recordFsckTime :: Key -> Annex () +recordFsckTime key = do + parent <- parentDir <$> inRepo (gitAnnexLocation key) + liftIO $ void $ tryIO $ do + touchFile parent + setSticky parent + +getFsckTime :: Key -> Annex (Maybe EpochTime) +getFsckTime key = do + parent <- parentDir <$> inRepo (gitAnnexLocation key) + liftIO $ catchDefaultIO Nothing $ do + s <- getFileStatus parent + return $ if isSticky $ fileMode s + then Just $ modificationTime s + else Nothing -{- Records the start time of an interactive fsck. +{- Records the start time of an interactive fsck, also returning it. - - To guard against time stamp damange (for example, if an annex directory - is copied without -a), the fsckstate file contains a time that should - be identical to its modification time. -} -recordStartTime :: Annex () +recordStartTime :: Annex (EpochTime) recordStartTime = do f <- fromRepo gitAnnexFsckState + createAnnexDirectory $ parentDir f liftIO $ do nukeFile f h <- openFile f WriteMode t <- modificationTime <$> getFileStatus f hPutStr h $ showTime $ realToFrac t hClose h + return t where showTime :: POSIXTime -> String showTime = show |