import Utility.CopyFile
import Git.FilePath
import Utility.PID
+import qualified Database.Keys
#ifdef WITH_DATABASE
import qualified Database.Fsck as FsckDb
go = runFsck inc file key
perform :: Key -> FilePath -> Backend -> NumCopies -> Annex Bool
-perform key file backend numcopies = check
- -- order matters
- [ fixLink key file
- , verifyLocationLog key file
- , verifyDirectMapping key file
- , verifyDirectMode key file
- , checkKeySize key
- , checkBackend backend key (Just file)
- , checkKeyNumCopies key (Just file) numcopies
- ]
+perform key file backend numcopies = do
+ keystatus <- getKeyStatus key
+ check
+ -- order matters
+ [ fixLink key file
+ , verifyLocationLog key keystatus file
+ , verifyDirectMapping key file
+ , verifyDirectMode key file
+ , checkKeySize key keystatus
+ , checkBackend backend key keystatus (Just file)
+ , checkKeyNumCopies key (Just file) numcopies
+ ]
{- To fsck a remote, the content is retrieved to a tmp file,
- and checked locally. -}
performKey key backend numcopies
performKey :: Key -> Backend -> NumCopies -> Annex Bool
-performKey key backend numcopies = check
- [ verifyLocationLog key (key2file key)
- , checkKeySize key
- , checkBackend backend key Nothing
- , checkKeyNumCopies key Nothing numcopies
- ]
+performKey key backend numcopies = do
+ keystatus <- getKeyStatus key
+ check
+ [ verifyLocationLog key keystatus (key2file key)
+ , checkKeySize key keystatus
+ , checkBackend backend key keystatus Nothing
+ , checkKeyNumCopies key Nothing numcopies
+ ]
check :: [Annex Bool] -> Annex Bool
check cs = and <$> sequence cs
-{- Checks that the file's link points correctly to the content.
- -
- - In direct mode, there is only a link when the content is not present.
+{- Checks that symlinks points correctly to the annexed content.
-}
fixLink :: Key -> FilePath -> Annex Bool
fixLink key file = do
{- Checks that the location log reflects the current status of the key,
- in this repository only. -}
-verifyLocationLog :: Key -> String -> Annex Bool
-verifyLocationLog key desc = do
- present <- inAnnex key
+verifyLocationLog :: Key -> KeyStatus -> String -> Annex Bool
+verifyLocationLog key keystatus desc = do
+ obj <- calcRepo $ gitAnnexLocation key
+ present <- if isKeyUnlocked keystatus
+ then liftIO (doesFileExist obj)
+ else inAnnex key
direct <- isDirect
u <- getUUID
- {- Since we're checking that a key's file is present, throw
+ {- Since we're checking that a key's object file is present, throw
- in a permission fixup here too. -}
- file <- calcRepo $ gitAnnexLocation key
- when (present && not direct) $
- freezeContent file
- whenM (liftIO $ doesDirectoryExist $ parentDir file) $
- freezeContentDir file
+ when (present && not direct) $ void $ tryIO $
+ if isKeyUnlocked keystatus
+ then thawContent obj
+ else freezeContent obj
+ whenM (liftIO $ doesDirectoryExist $ parentDir obj) $
+ freezeContentDir obj
{- In direct mode, modified files will show up as not present,
- but that is expected and not something to do anything about. -}
{- The size of the data for a key is checked against the size encoded in
- the key's metadata, if available.
-
- - Not checked in direct mode, because files can be changed directly.
+ - Not checked when a file is unlocked, or in direct mode.
-}
-checkKeySize :: Key -> Annex Bool
-checkKeySize key = ifM isDirect
+checkKeySize :: Key -> KeyStatus -> Annex Bool
+checkKeySize _ KeyUnlocked = return True
+checkKeySize key KeyLocked = ifM isDirect
( return True
, do
file <- calcRepo $ gitAnnexLocation key
, msg
]
-{- Runs the backend specific check on a key's content.
+{- Runs the backend specific check on a key's content object.
+ -
+ - When a file is unlocked, it may be a hard link to the object,
+ - thus when the user modifies the file, the object will be modified and
+ - not pass the check, and we don't want to find an error in this case.
+ - So, skip the check if the key is unlocked and modified.
-
- In direct mode this is not done if the file has clearly been modified,
- because modification of direct mode files is allowed. It's still done
- if the file does not appear modified, to catch disk corruption, etc.
-}
-checkBackend :: Backend -> Key -> Maybe FilePath -> Annex Bool
-checkBackend backend key mfile = go =<< isDirect
+checkBackend :: Backend -> Key -> KeyStatus -> Maybe FilePath -> Annex Bool
+checkBackend backend key keystatus mfile = go =<< isDirect
where
go False = do
content <- calcRepo $ gitAnnexLocation key
- checkBackendOr badContent backend key content
+ ifM (pure (isKeyUnlocked keystatus) <&&> (not <$> isUnmodified key content))
+ ( nocheck
+ , checkBackendOr badContent backend key content
+ )
go True = maybe nocheck checkdirect mfile
checkdirect file = ifM (goodContent key file)
( checkBackendOr' (badContentDirect file) backend key file
withFsckDb NonIncremental _ = noop
withFsckDb (ScheduleIncremental _ _ i) a = withFsckDb i a
#endif
+
+data KeyStatus = KeyLocked | KeyUnlocked
+
+isKeyUnlocked :: KeyStatus -> Bool
+isKeyUnlocked KeyUnlocked = True
+isKeyUnlocked KeyLocked = False
+
+getKeyStatus :: Key -> Annex KeyStatus
+getKeyStatus key = do
+ obj <- calcRepo $ gitAnnexLocation key
+ unlocked <- ((> 1) . linkCount <$> liftIO (getFileStatus obj))
+ <&&> (not . null <$> Database.Keys.getAssociatedFiles key)
+ return $ if unlocked then KeyUnlocked else KeyLocked
projects / git-annex.git / commitdiff