2011-01-16 20:05:05 +00:00
|
|
|
{- git-annex file content managing
|
2010-10-27 20:53:54 +00:00
|
|
|
-
|
|
|
|
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
-}
|
2010-10-14 07:40:26 +00:00
|
|
|
|
2011-10-04 04:40:47 +00:00
|
|
|
module Annex.Content (
|
2011-01-16 20:05:05 +00:00
|
|
|
inAnnex,
|
2011-11-09 22:33:15 +00:00
|
|
|
inAnnexSafe,
|
|
|
|
lockContent,
|
2011-01-16 20:05:05 +00:00
|
|
|
calcGitLink,
|
|
|
|
logStatus,
|
|
|
|
getViaTmp,
|
2011-03-22 21:27:04 +00:00
|
|
|
getViaTmpUnchecked,
|
2011-04-28 00:06:07 +00:00
|
|
|
withTmp,
|
2011-03-22 21:27:04 +00:00
|
|
|
checkDiskSpace,
|
2011-01-16 20:05:05 +00:00
|
|
|
moveAnnex,
|
|
|
|
removeAnnex,
|
|
|
|
fromAnnex,
|
|
|
|
moveBad,
|
2011-06-23 01:19:52 +00:00
|
|
|
getKeysPresent,
|
2012-01-02 18:20:20 +00:00
|
|
|
saveState,
|
|
|
|
downloadUrl,
|
2012-01-19 21:05:39 +00:00
|
|
|
preseedTmp,
|
2011-01-16 20:05:05 +00:00
|
|
|
) where
|
2010-10-14 07:40:26 +00:00
|
|
|
|
2011-11-10 01:45:03 +00:00
|
|
|
import Control.Exception (bracket_)
|
|
|
|
import System.Posix.Types
|
|
|
|
|
2011-10-05 20:02:51 +00:00
|
|
|
import Common.Annex
|
2011-10-15 20:21:08 +00:00
|
|
|
import Logs.Location
|
2011-10-15 21:47:03 +00:00
|
|
|
import Annex.UUID
|
2011-06-30 17:16:57 +00:00
|
|
|
import qualified Git
|
2012-02-25 19:23:17 +00:00
|
|
|
import qualified Git.Config
|
2010-10-14 07:40:26 +00:00
|
|
|
import qualified Annex
|
2011-10-04 04:40:47 +00:00
|
|
|
import qualified Annex.Queue
|
|
|
|
import qualified Annex.Branch
|
2011-08-20 20:11:42 +00:00
|
|
|
import Utility.StatFS
|
2011-09-23 22:13:24 +00:00
|
|
|
import Utility.FileMode
|
2012-01-02 18:20:20 +00:00
|
|
|
import qualified Utility.Url as Url
|
2011-06-02 01:56:04 +00:00
|
|
|
import Types.Key
|
2011-07-06 00:36:43 +00:00
|
|
|
import Utility.DataUnits
|
2012-01-19 21:05:39 +00:00
|
|
|
import Utility.CopyFile
|
2011-03-28 01:43:25 +00:00
|
|
|
import Config
|
2011-11-10 01:45:03 +00:00
|
|
|
import Annex.Exception
|
2010-10-25 23:17:11 +00:00
|
|
|
|
2011-11-09 22:33:15 +00:00
|
|
|
{- Checks if a given key's content is currently present. -}
|
2010-10-14 23:36:11 +00:00
|
|
|
inAnnex :: Key -> Annex Bool
|
2011-12-09 05:57:13 +00:00
|
|
|
inAnnex = inAnnex' doesFileExist
|
2011-11-09 22:33:15 +00:00
|
|
|
inAnnex' :: (FilePath -> IO a) -> Key -> Annex a
|
|
|
|
inAnnex' a key = do
|
2011-11-08 19:34:10 +00:00
|
|
|
whenM (fromRepo Git.repoIsUrl) $
|
|
|
|
error "inAnnex cannot check remote repo"
|
2011-11-29 02:43:51 +00:00
|
|
|
inRepo $ \g -> gitAnnexLocation key g >>= a
|
2011-11-09 22:33:15 +00:00
|
|
|
|
|
|
|
{- A safer check; the key's content must not only be present, but
|
|
|
|
- is not in the process of being removed. -}
|
|
|
|
inAnnexSafe :: Key -> Annex (Maybe Bool)
|
2011-11-10 01:45:03 +00:00
|
|
|
inAnnexSafe = inAnnex' $ \f -> openForLock f False >>= check
|
2011-11-09 22:33:15 +00:00
|
|
|
where
|
2011-11-10 01:45:03 +00:00
|
|
|
check Nothing = return is_missing
|
|
|
|
check (Just h) = do
|
|
|
|
v <- getLock h (ReadLock, AbsoluteSeek, 0, 0)
|
|
|
|
closeFd h
|
|
|
|
return $ case v of
|
|
|
|
Just _ -> is_locked
|
|
|
|
Nothing -> is_unlocked
|
|
|
|
is_locked = Nothing
|
|
|
|
is_unlocked = Just True
|
|
|
|
is_missing = Just False
|
2010-10-16 17:59:48 +00:00
|
|
|
|
2011-11-10 02:15:33 +00:00
|
|
|
{- Content is exclusively locked while running an action that might remove
|
|
|
|
- it. (If the content is not present, no locking is done.) -}
|
2011-11-09 22:33:15 +00:00
|
|
|
lockContent :: Key -> Annex a -> Annex a
|
2011-11-10 01:45:03 +00:00
|
|
|
lockContent key a = do
|
2011-11-29 02:43:51 +00:00
|
|
|
file <- inRepo $ gitAnnexLocation key
|
2011-11-10 01:45:03 +00:00
|
|
|
bracketIO (openForLock file True >>= lock) unlock a
|
|
|
|
where
|
|
|
|
lock Nothing = return Nothing
|
|
|
|
lock (Just l) = do
|
2012-02-03 20:47:24 +00:00
|
|
|
v <- tryIO $ setLock l (WriteLock, AbsoluteSeek, 0, 0)
|
2011-11-10 06:59:13 +00:00
|
|
|
case v of
|
|
|
|
Left _ -> error "content is locked"
|
|
|
|
Right _ -> return $ Just l
|
2011-11-10 01:45:03 +00:00
|
|
|
unlock Nothing = return ()
|
|
|
|
unlock (Just l) = closeFd l
|
|
|
|
|
|
|
|
openForLock :: FilePath -> Bool -> IO (Maybe Fd)
|
2011-11-11 00:24:24 +00:00
|
|
|
openForLock file writelock = bracket_ prep cleanup go
|
2011-11-10 01:45:03 +00:00
|
|
|
where
|
2011-11-11 00:24:24 +00:00
|
|
|
go = catchMaybeIO $ openFd file mode Nothing defaultFileFlags
|
2011-11-10 01:45:03 +00:00
|
|
|
mode = if writelock then ReadWrite else ReadOnly
|
2011-11-10 02:15:33 +00:00
|
|
|
{- Since files are stored with the write bit disabled,
|
|
|
|
- have to fiddle with permissions to open for an
|
2011-11-11 00:24:24 +00:00
|
|
|
- exclusive lock. -}
|
2011-11-10 02:15:33 +00:00
|
|
|
forwritelock a =
|
2011-11-11 05:52:58 +00:00
|
|
|
when writelock $ whenM (doesFileExist file) a
|
2011-11-11 00:24:24 +00:00
|
|
|
prep = forwritelock $ allowWrite file
|
|
|
|
cleanup = forwritelock $ preventWrite file
|
2011-11-09 20:54:18 +00:00
|
|
|
|
2010-10-17 01:03:25 +00:00
|
|
|
{- Calculates the relative path to use to link a file to a key. -}
|
|
|
|
calcGitLink :: FilePath -> Key -> Annex FilePath
|
|
|
|
calcGitLink file key = do
|
2011-07-15 07:12:05 +00:00
|
|
|
cwd <- liftIO getCurrentDirectory
|
|
|
|
let absfile = fromMaybe whoops $ absNormPath cwd file
|
2011-11-29 02:43:51 +00:00
|
|
|
loc <- inRepo $ gitAnnexLocation key
|
|
|
|
return $ relPathDirToFile (parentDir absfile) loc
|
2011-05-15 06:49:43 +00:00
|
|
|
where
|
|
|
|
whoops = error $ "unable to normalize " ++ file
|
2010-10-17 16:08:59 +00:00
|
|
|
|
2011-10-15 20:21:08 +00:00
|
|
|
{- Updates the Logs.Location when a key's presence changes in the current
|
2011-07-01 19:24:07 +00:00
|
|
|
- repository. -}
|
2010-10-17 16:08:59 +00:00
|
|
|
logStatus :: Key -> LogStatus -> Annex ()
|
|
|
|
logStatus key status = do
|
2011-10-11 18:43:45 +00:00
|
|
|
u <- getUUID
|
2011-11-09 05:15:51 +00:00
|
|
|
logChange key u status
|
2010-10-17 16:08:59 +00:00
|
|
|
|
support .git/annex on a different disk than the rest of the repo
The only fully supported thing is to have the main repository on one disk,
and .git/annex on another. Only commands that move data in/out of the annex
will need to copy it across devices.
There is only partial support for putting arbitrary subdirectories of
.git/annex on different devices. For one thing, but this can require more
copies to be done. For example, when .git/annex/tmp is on one device, and
.git/annex/journal on another, every journal write involves a call to
mv(1). Also, there are a few places that make hard links between various
subdirectories of .git/annex with createLink, that are not handled.
In the common case without cross-device, the new moveFile is actually
faster than renameFile, avoiding an unncessary stat to check that a file
(not a directory) is being moved. Of course if a cross-device move is
needed, it is as slow as mv(1) of the data.
2011-11-28 19:26:27 +00:00
|
|
|
{- Runs an action, passing it a temporary filename to get,
|
2010-10-23 18:26:38 +00:00
|
|
|
- and if the action succeeds, moves the temp file into
|
|
|
|
- the annex as a key's content. -}
|
2010-10-25 18:10:38 +00:00
|
|
|
getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool
|
2010-10-23 18:26:38 +00:00
|
|
|
getViaTmp key action = do
|
2011-11-08 19:34:10 +00:00
|
|
|
tmp <- fromRepo $ gitAnnexTmpLocation key
|
2011-03-22 21:27:04 +00:00
|
|
|
|
|
|
|
-- Check that there is enough free disk space.
|
|
|
|
-- When the temp file already exists, count the space
|
|
|
|
-- it is using as free.
|
|
|
|
e <- liftIO $ doesFileExist tmp
|
|
|
|
if e
|
|
|
|
then do
|
|
|
|
stat <- liftIO $ getFileStatus tmp
|
|
|
|
checkDiskSpace' (fromIntegral $ fileSize stat) key
|
|
|
|
else checkDiskSpace key
|
|
|
|
|
2011-04-26 02:04:12 +00:00
|
|
|
when e $ liftIO $ allowWrite tmp
|
|
|
|
|
2011-03-22 21:27:04 +00:00
|
|
|
getViaTmpUnchecked key action
|
|
|
|
|
2011-07-15 07:12:05 +00:00
|
|
|
prepTmp :: Key -> Annex FilePath
|
|
|
|
prepTmp key = do
|
2011-11-08 19:34:10 +00:00
|
|
|
tmp <- fromRepo $ gitAnnexTmpLocation key
|
2011-07-15 07:12:05 +00:00
|
|
|
liftIO $ createDirectoryIfMissing True (parentDir tmp)
|
|
|
|
return tmp
|
|
|
|
|
2011-03-22 21:27:04 +00:00
|
|
|
{- Like getViaTmp, but does not check that there is enough disk space
|
|
|
|
- for the incoming key. For use when the key content is already on disk
|
|
|
|
- and not being copied into place. -}
|
|
|
|
getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool
|
|
|
|
getViaTmpUnchecked key action = do
|
2011-07-15 07:12:05 +00:00
|
|
|
tmp <- prepTmp key
|
2010-10-23 18:26:38 +00:00
|
|
|
success <- action tmp
|
2010-11-22 19:46:57 +00:00
|
|
|
if success
|
2010-10-23 18:26:38 +00:00
|
|
|
then do
|
2010-11-08 23:26:37 +00:00
|
|
|
moveAnnex key tmp
|
2011-07-01 19:24:07 +00:00
|
|
|
logStatus key InfoPresent
|
2010-10-25 18:10:38 +00:00
|
|
|
return True
|
2010-10-23 18:26:38 +00:00
|
|
|
else do
|
2010-10-25 19:44:27 +00:00
|
|
|
-- the tmp file is left behind, in case caller wants
|
|
|
|
-- to resume its transfer
|
2010-10-25 18:10:38 +00:00
|
|
|
return False
|
2010-10-23 18:26:38 +00:00
|
|
|
|
2011-04-28 00:06:07 +00:00
|
|
|
{- Creates a temp file, runs an action on it, and cleans up the temp file. -}
|
|
|
|
withTmp :: Key -> (FilePath -> Annex a) -> Annex a
|
|
|
|
withTmp key action = do
|
2011-07-15 07:12:05 +00:00
|
|
|
tmp <- prepTmp key
|
2011-04-28 00:06:07 +00:00
|
|
|
res <- action tmp
|
2011-05-17 07:10:13 +00:00
|
|
|
liftIO $ whenM (doesFileExist tmp) $ liftIO $ removeFile tmp
|
2011-04-28 00:06:07 +00:00
|
|
|
return res
|
|
|
|
|
2011-03-22 21:27:04 +00:00
|
|
|
{- Checks that there is disk space available to store a given key,
|
|
|
|
- throwing an error if not. -}
|
|
|
|
checkDiskSpace :: Key -> Annex ()
|
|
|
|
checkDiskSpace = checkDiskSpace' 0
|
|
|
|
|
|
|
|
checkDiskSpace' :: Integer -> Key -> Annex ()
|
|
|
|
checkDiskSpace' adjustment key = do
|
2011-10-04 02:24:57 +00:00
|
|
|
g <- gitRepo
|
2011-03-28 01:43:25 +00:00
|
|
|
r <- getConfig g "diskreserve" ""
|
2011-07-15 07:12:05 +00:00
|
|
|
let reserve = fromMaybe megabyte $ readSize dataUnits r
|
2011-03-22 21:27:04 +00:00
|
|
|
stats <- liftIO $ getFileSystemStats (gitAnnexDir g)
|
2012-01-15 17:26:17 +00:00
|
|
|
sanitycheck r stats
|
2011-03-22 21:27:04 +00:00
|
|
|
case (stats, keySize key) of
|
|
|
|
(Nothing, _) -> return ()
|
|
|
|
(_, Nothing) -> return ()
|
|
|
|
(Just (FileSystemStats { fsStatBytesAvailable = have }), Just need) ->
|
2011-07-15 07:12:05 +00:00
|
|
|
when (need + reserve > have + adjustment) $
|
|
|
|
needmorespace (need + reserve - have - adjustment)
|
2011-03-22 21:27:04 +00:00
|
|
|
where
|
2011-03-22 21:53:40 +00:00
|
|
|
megabyte :: Integer
|
2011-03-26 18:37:39 +00:00
|
|
|
megabyte = 1000000
|
2011-07-15 07:12:05 +00:00
|
|
|
needmorespace n = unlessM (Annex.getState Annex.force) $
|
|
|
|
error $ "not enough free space, need " ++
|
|
|
|
roughSize storageUnits True n ++
|
2012-01-15 17:26:17 +00:00
|
|
|
" more" ++ forcemsg
|
|
|
|
forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
|
|
|
|
sanitycheck r stats
|
|
|
|
| not (null r) && isNothing stats = do
|
|
|
|
unlessM (Annex.getState Annex.force) $
|
|
|
|
error $ "You have configured a diskreserve of "
|
|
|
|
++ r ++
|
|
|
|
" but disk space checking is not working"
|
|
|
|
++ forcemsg
|
|
|
|
return ()
|
|
|
|
| otherwise = return ()
|
2011-03-22 21:27:04 +00:00
|
|
|
|
2011-04-29 00:41:40 +00:00
|
|
|
{- Moves a file into .git/annex/objects/
|
|
|
|
-
|
|
|
|
- What if the key there already has content? This could happen for
|
|
|
|
- various reasons; perhaps the same content is being annexed again.
|
|
|
|
- Perhaps there has been a hash collision generating the keys.
|
|
|
|
-
|
|
|
|
- The current strategy is to assume that in this case it's safe to delete
|
|
|
|
- one of the two copies of the content; and the one already in the annex
|
|
|
|
- is left there, assuming it's the original, canonical copy.
|
|
|
|
-
|
|
|
|
- I considered being more paranoid, and checking that both files had
|
|
|
|
- the same content. Decided against it because A) users explicitly choose
|
|
|
|
- a backend based on its hashing properties and so if they're dealing
|
|
|
|
- with colliding files it's their own fault and B) adding such a check
|
|
|
|
- would not catch all cases of colliding keys. For example, perhaps
|
|
|
|
- a remote has a key; if it's then added again with different content then
|
|
|
|
- the overall system now has two different peices of content for that
|
|
|
|
- key, and one of them will probably get deleted later. So, adding the
|
|
|
|
- check here would only raise expectations that git-annex cannot truely
|
|
|
|
- meet.
|
|
|
|
-}
|
2010-11-08 23:26:37 +00:00
|
|
|
moveAnnex :: Key -> FilePath -> Annex ()
|
|
|
|
moveAnnex key src = do
|
2011-11-29 02:43:51 +00:00
|
|
|
dest <- inRepo $ gitAnnexLocation key
|
2010-11-08 23:26:37 +00:00
|
|
|
let dir = parentDir dest
|
2011-04-29 00:41:40 +00:00
|
|
|
e <- liftIO $ doesFileExist dest
|
|
|
|
if e
|
|
|
|
then liftIO $ removeFile src
|
|
|
|
else liftIO $ do
|
|
|
|
createDirectoryIfMissing True dir
|
|
|
|
allowWrite dir -- in case the directory already exists
|
support .git/annex on a different disk than the rest of the repo
The only fully supported thing is to have the main repository on one disk,
and .git/annex on another. Only commands that move data in/out of the annex
will need to copy it across devices.
There is only partial support for putting arbitrary subdirectories of
.git/annex on different devices. For one thing, but this can require more
copies to be done. For example, when .git/annex/tmp is on one device, and
.git/annex/journal on another, every journal write involves a call to
mv(1). Also, there are a few places that make hard links between various
subdirectories of .git/annex with createLink, that are not handled.
In the common case without cross-device, the new moveFile is actually
faster than renameFile, avoiding an unncessary stat to check that a file
(not a directory) is being moved. Of course if a cross-device move is
needed, it is as slow as mv(1) of the data.
2011-11-28 19:26:27 +00:00
|
|
|
moveFile src dest
|
2011-04-29 00:41:40 +00:00
|
|
|
preventWrite dest
|
|
|
|
preventWrite dir
|
2010-11-08 23:26:37 +00:00
|
|
|
|
2011-07-15 07:12:05 +00:00
|
|
|
withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a
|
|
|
|
withObjectLoc key a = do
|
2011-11-29 02:43:51 +00:00
|
|
|
file <- inRepo $ gitAnnexLocation key
|
2010-11-08 23:26:37 +00:00
|
|
|
let dir = parentDir file
|
2011-07-15 07:12:05 +00:00
|
|
|
a (dir, file)
|
|
|
|
|
2012-02-24 20:30:47 +00:00
|
|
|
cleanObjectLoc :: Key -> Annex ()
|
|
|
|
cleanObjectLoc key = do
|
|
|
|
file <- inRepo $ gitAnnexLocation key
|
|
|
|
liftIO $ removeparents file (3 :: Int)
|
|
|
|
where
|
|
|
|
removeparents _ 0 = return ()
|
|
|
|
removeparents file n = do
|
|
|
|
let dir = parentDir file
|
|
|
|
maybe (return ()) (const $ removeparents dir (n-1))
|
|
|
|
=<< catchMaybeIO (removeDirectory dir)
|
|
|
|
|
2011-07-15 07:12:05 +00:00
|
|
|
{- Removes a key's file from .git/annex/objects/ -}
|
|
|
|
removeAnnex :: Key -> Annex ()
|
2012-02-24 20:30:47 +00:00
|
|
|
removeAnnex key = withObjectLoc key $ \(dir, file) -> do
|
|
|
|
liftIO $ do
|
|
|
|
allowWrite dir
|
|
|
|
removeFile file
|
|
|
|
cleanObjectLoc key
|
2010-11-08 23:26:37 +00:00
|
|
|
|
|
|
|
{- Moves a key's file out of .git/annex/objects/ -}
|
|
|
|
fromAnnex :: Key -> FilePath -> Annex ()
|
2012-02-24 20:30:47 +00:00
|
|
|
fromAnnex key dest = withObjectLoc key $ \(dir, file) -> do
|
|
|
|
liftIO $ do
|
|
|
|
allowWrite dir
|
|
|
|
allowWrite file
|
|
|
|
moveFile file dest
|
|
|
|
cleanObjectLoc key
|
2010-11-08 20:47:36 +00:00
|
|
|
|
2010-11-13 18:59:27 +00:00
|
|
|
{- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
|
2010-11-13 19:42:56 +00:00
|
|
|
- returns the file it was moved to. -}
|
2010-11-13 18:59:27 +00:00
|
|
|
moveBad :: Key -> Annex FilePath
|
|
|
|
moveBad key = do
|
2011-11-29 02:43:51 +00:00
|
|
|
src <- inRepo $ gitAnnexLocation key
|
2011-11-11 05:52:58 +00:00
|
|
|
bad <- fromRepo gitAnnexBadDir
|
2011-11-08 19:34:10 +00:00
|
|
|
let dest = bad </> takeFileName src
|
2011-07-01 05:11:41 +00:00
|
|
|
liftIO $ do
|
|
|
|
createDirectoryIfMissing True (parentDir dest)
|
|
|
|
allowWrite (parentDir src)
|
support .git/annex on a different disk than the rest of the repo
The only fully supported thing is to have the main repository on one disk,
and .git/annex on another. Only commands that move data in/out of the annex
will need to copy it across devices.
There is only partial support for putting arbitrary subdirectories of
.git/annex on different devices. For one thing, but this can require more
copies to be done. For example, when .git/annex/tmp is on one device, and
.git/annex/journal on another, every journal write involves a call to
mv(1). Also, there are a few places that make hard links between various
subdirectories of .git/annex with createLink, that are not handled.
In the common case without cross-device, the new moveFile is actually
faster than renameFile, avoiding an unncessary stat to check that a file
(not a directory) is being moved. Of course if a cross-device move is
needed, it is as slow as mv(1) of the data.
2011-11-28 19:26:27 +00:00
|
|
|
moveFile src dest
|
2012-02-24 20:30:47 +00:00
|
|
|
cleanObjectLoc key
|
2011-07-01 19:24:07 +00:00
|
|
|
logStatus key InfoMissing
|
2010-11-13 18:59:27 +00:00
|
|
|
return dest
|
|
|
|
|
2010-11-08 19:15:21 +00:00
|
|
|
{- List of keys whose content exists in .git/annex/objects/ -}
|
|
|
|
getKeysPresent :: Annex [Key]
|
2011-11-08 19:34:10 +00:00
|
|
|
getKeysPresent = getKeysPresent' =<< fromRepo gitAnnexObjectDir
|
2010-11-08 20:47:36 +00:00
|
|
|
getKeysPresent' :: FilePath -> Annex [Key]
|
|
|
|
getKeysPresent' dir = do
|
2010-12-20 18:57:43 +00:00
|
|
|
exists <- liftIO $ doesDirectoryExist dir
|
2011-07-15 07:12:05 +00:00
|
|
|
if not exists
|
2010-12-20 18:57:43 +00:00
|
|
|
then return []
|
2011-07-01 05:11:41 +00:00
|
|
|
else liftIO $ do
|
2011-03-16 15:27:29 +00:00
|
|
|
-- 2 levels of hashing
|
2011-07-01 05:11:41 +00:00
|
|
|
levela <- dirContents dir
|
|
|
|
levelb <- mapM dirContents levela
|
|
|
|
contents <- mapM dirContents (concat levelb)
|
2011-08-30 19:16:34 +00:00
|
|
|
let files = concat contents
|
2011-07-15 07:12:05 +00:00
|
|
|
return $ mapMaybe (fileKey . takeFileName) files
|
2011-06-23 01:19:52 +00:00
|
|
|
|
2012-01-28 19:41:52 +00:00
|
|
|
{- Things to do to record changes to content when shutting down.
|
|
|
|
-
|
|
|
|
- It's acceptable to avoid committing changes to the branch,
|
|
|
|
- especially if performing a short-lived action.
|
|
|
|
-}
|
|
|
|
saveState :: Bool -> Annex ()
|
|
|
|
saveState oneshot = do
|
2011-10-04 04:40:47 +00:00
|
|
|
Annex.Queue.flush False
|
2012-02-25 20:11:47 +00:00
|
|
|
unless oneshot $ do
|
2012-02-25 23:15:29 +00:00
|
|
|
alwayscommit <- fromMaybe True . Git.configTrue
|
|
|
|
<$> fromRepo (Git.Config.get "annex.alwayscommit" "")
|
2012-02-25 20:11:47 +00:00
|
|
|
if alwayscommit
|
|
|
|
then Annex.Branch.commit "update"
|
|
|
|
else Annex.Branch.stage
|
2012-01-02 18:20:20 +00:00
|
|
|
|
|
|
|
{- Downloads content from any of a list of urls. -}
|
|
|
|
downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool
|
|
|
|
downloadUrl urls file = do
|
|
|
|
g <- gitRepo
|
|
|
|
o <- map Param . words <$> getConfig g "web-options" ""
|
|
|
|
liftIO $ anyM (\u -> Url.download u o file) urls
|
2012-01-19 21:05:39 +00:00
|
|
|
|
|
|
|
{- Copies a key's content, when present, to a temp file.
|
|
|
|
- This is used to speed up some rsyncs. -}
|
2012-01-20 17:23:11 +00:00
|
|
|
preseedTmp :: Key -> FilePath -> Annex Bool
|
|
|
|
preseedTmp key file = go =<< inAnnex key
|
|
|
|
where
|
|
|
|
go False = return False
|
|
|
|
go True = do
|
|
|
|
ok <- copy
|
|
|
|
when ok $ liftIO $ allowWrite file
|
|
|
|
return ok
|
|
|
|
copy = do
|
|
|
|
present <- liftIO $ doesFileExist file
|
|
|
|
if present
|
|
|
|
then return True
|
|
|
|
else do
|
|
|
|
s <- inRepo $ gitAnnexLocation key
|
|
|
|
liftIO $ copyFileExternal s file
|