10b5f79e2d
Fix behavior when importing a tree from a directory remote when the
directory does not exist. An empty tree was imported, rather than the
import failing. Merging that tree would delete every file in the
branch, if those files had been exported to the directory before.
The problem was that dirContentsRecursive returned [] when the directory
did not exist. Better for it to throw an exception. But in commit
74f0d67aa3 back in 2012, I made it never
theow exceptions, because exceptions throw inside unsafeInterleaveIO become
untrappable when the list is being traversed.
So, changed it to list the contents of the directory before entering
unsafeInterleaveIO. So exceptions are thrown for the directory. But still
not if it's unable to list the contents of a subdirectory. That's less of a
problem, because the subdirectory does exist (or if not, it got removed
after being listed, and it's ok to not include it in the list). A
subdirectory that has permissions that don't allow listing it will have its
contents omitted from the list still.
(Might be better to have it return a type that includes indications of
errors listing contents of subdirectories?)
The rest of the changes are making callers of dirContentsRecursive
use emptyWhenDoesNotExist when they relied on the behavior of it not
throwing an exception when the directory does not exist. Note that
it's possible some callers of dirContentsRecursive that used to ignore
permissions problems listing a directory will now start throwing exceptions
on them.
The fix to the directory special remote consisted of not making its
call in listImportableContentsM use emptyWhenDoesNotExist. So it will
throw an exception as desired.
Sponsored-by: Joshua Antonishen on Patreon
317 lines
11 KiB
Haskell
317 lines
11 KiB
Haskell
{- git-annex transfer information files and lock files
|
|
-
|
|
- Copyright 2012-2021 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Logs.Transfer where
|
|
|
|
import Types.Transfer
|
|
import Types.ActionItem
|
|
import Annex.Common
|
|
import qualified Git
|
|
import qualified Git.Quote
|
|
import Utility.Metered
|
|
import Utility.Percentage
|
|
import Utility.PID
|
|
import Annex.LockPool
|
|
import Utility.TimeStamp
|
|
import Logs.File
|
|
import qualified Utility.RawFilePath as R
|
|
#ifndef mingw32_HOST_OS
|
|
import Annex.Perms
|
|
#endif
|
|
|
|
import Data.Time.Clock
|
|
import Data.Time.Clock.POSIX
|
|
import Control.Concurrent.STM
|
|
import qualified Data.ByteString.Char8 as B8
|
|
import qualified System.FilePath.ByteString as P
|
|
|
|
describeTransfer :: Git.Quote.QuotePath -> Transfer -> TransferInfo -> String
|
|
describeTransfer qp t info = unwords
|
|
[ show $ transferDirection t
|
|
, show $ transferUUID t
|
|
, decodeBS $ quote qp $ actionItemDesc $ ActionItemAssociatedFile
|
|
(associatedFile info)
|
|
(transferKey t)
|
|
, show $ bytesComplete info
|
|
]
|
|
|
|
{- Transfers that will accomplish the same task. -}
|
|
equivilantTransfer :: Transfer -> Transfer -> Bool
|
|
equivilantTransfer t1 t2
|
|
| transferDirection t1 == Download && transferDirection t2 == Download &&
|
|
transferKeyData t1 == transferKeyData t2 = True
|
|
| otherwise = t1 == t2
|
|
|
|
percentComplete :: Transfer -> TransferInfo -> Maybe Percentage
|
|
percentComplete t info =
|
|
percentage
|
|
<$> keySize (transferKeyData t)
|
|
<*> Just (fromMaybe 0 $ bytesComplete info)
|
|
|
|
{- Generates a callback that can be called as transfer progresses to update
|
|
- the transfer info file. Also returns the file it'll be updating,
|
|
- an action that sets up the file with appropriate permissions,
|
|
- which should be run after locking the transfer lock file, but
|
|
- before using the callback, and a TVar that can be used to read
|
|
- the number of bytes processed so far. -}
|
|
mkProgressUpdater :: Transfer -> TransferInfo -> Annex (MeterUpdate, RawFilePath, Annex (), TVar (Maybe BytesProcessed))
|
|
mkProgressUpdater t info = do
|
|
tfile <- fromRepo $ transferFile t
|
|
let createtfile = void $ tryNonAsync $ writeTransferInfoFile info tfile
|
|
tvar <- liftIO $ newTVarIO Nothing
|
|
loggedtvar <- liftIO $ newTVarIO 0
|
|
return (liftIO . updater (fromRawFilePath tfile) tvar loggedtvar, tfile, createtfile, tvar)
|
|
where
|
|
updater tfile tvar loggedtvar new = do
|
|
old <- atomically $ swapTVar tvar (Just new)
|
|
let oldbytes = maybe 0 fromBytesProcessed old
|
|
let newbytes = fromBytesProcessed new
|
|
when (newbytes - oldbytes >= mindelta) $ do
|
|
let info' = info { bytesComplete = Just newbytes }
|
|
_ <- tryIO $ updateTransferInfoFile info' tfile
|
|
atomically $ writeTVar loggedtvar newbytes
|
|
|
|
{- The minimum change in bytesComplete that is worth
|
|
- updating a transfer info file for is 1% of the total
|
|
- keySize, rounded down. -}
|
|
mindelta = case keySize (transferKeyData t) of
|
|
Just sz -> sz `div` 100
|
|
Nothing -> 100 * 1024 -- arbitrarily, 100 kb
|
|
|
|
startTransferInfo :: AssociatedFile -> IO TransferInfo
|
|
startTransferInfo afile = TransferInfo
|
|
<$> (Just . utcTimeToPOSIXSeconds <$> getCurrentTime)
|
|
#ifndef mingw32_HOST_OS
|
|
<*> pure Nothing -- pid not stored in file, so omitted for speed
|
|
#else
|
|
<*> (Just <$> getPID)
|
|
#endif
|
|
<*> pure Nothing -- tid ditto
|
|
<*> pure Nothing -- not 0; transfer may be resuming
|
|
<*> pure Nothing
|
|
<*> pure afile
|
|
<*> pure False
|
|
|
|
{- If a transfer is still running, returns its TransferInfo.
|
|
-
|
|
- If no transfer is running, attempts to clean up the stale
|
|
- lock and info files. This can happen if a transfer process was
|
|
- interrupted.
|
|
-}
|
|
checkTransfer :: Transfer -> Annex (Maybe TransferInfo)
|
|
checkTransfer t = debugLocks $ do
|
|
tfile <- fromRepo $ transferFile t
|
|
let lck = transferLockFile tfile
|
|
let cleanstale = do
|
|
void $ tryIO $ R.removeLink tfile
|
|
void $ tryIO $ R.removeLink lck
|
|
#ifndef mingw32_HOST_OS
|
|
v <- getLockStatus lck
|
|
case v of
|
|
StatusLockedBy pid -> liftIO $ catchDefaultIO Nothing $
|
|
readTransferInfoFile (Just pid) (fromRawFilePath tfile)
|
|
_ -> do
|
|
-- Take a non-blocking lock while deleting
|
|
-- the stale lock file. Ignore failure
|
|
-- due to permissions problems, races, etc.
|
|
void $ tryIO $ do
|
|
mode <- annexFileMode
|
|
r <- tryLockExclusive (Just mode) lck
|
|
case r of
|
|
Just lockhandle -> liftIO $ do
|
|
cleanstale
|
|
dropLock lockhandle
|
|
_ -> noop
|
|
return Nothing
|
|
#else
|
|
v <- liftIO $ lockShared lck
|
|
liftIO $ case v of
|
|
Nothing -> catchDefaultIO Nothing $
|
|
readTransferInfoFile Nothing (fromRawFilePath tfile)
|
|
Just lockhandle -> do
|
|
dropLock lockhandle
|
|
cleanstale
|
|
return Nothing
|
|
#endif
|
|
|
|
{- Gets all currently running transfers. -}
|
|
getTransfers :: Annex [(Transfer, TransferInfo)]
|
|
getTransfers = getTransfers' [Download, Upload] (const True)
|
|
|
|
getTransfers' :: [Direction] -> (Key -> Bool) -> Annex [(Transfer, TransferInfo)]
|
|
getTransfers' dirs wanted = do
|
|
transfers <- filter (wanted . transferKey)
|
|
<$> mapMaybe parseTransferFile . concat <$> findfiles
|
|
infos <- mapM checkTransfer transfers
|
|
return $ mapMaybe running $ zip transfers infos
|
|
where
|
|
findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive . fromRawFilePath)
|
|
=<< mapM (fromRepo . transferDir) dirs
|
|
running (t, Just i) = Just (t, i)
|
|
running (_, Nothing) = Nothing
|
|
|
|
{- Number of bytes remaining to download from matching downloads that are in
|
|
- progress. -}
|
|
sizeOfDownloadsInProgress :: (Key -> Bool) -> Annex Integer
|
|
sizeOfDownloadsInProgress wanted = sum . map remaining
|
|
<$> getTransfers' [Download] wanted
|
|
where
|
|
remaining (t, info) =
|
|
case (fromKey keySize (transferKey t), bytesComplete info) of
|
|
(Just sz, Just done) -> sz - done
|
|
(Just sz, Nothing) -> sz
|
|
(Nothing, _) -> 0
|
|
|
|
{- Gets failed transfers for a given remote UUID. -}
|
|
getFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)]
|
|
getFailedTransfers u = catMaybes <$> (liftIO . getpairs =<< concat <$> findfiles)
|
|
where
|
|
getpairs = mapM $ \f -> do
|
|
let mt = parseTransferFile f
|
|
mi <- readTransferInfoFile Nothing f
|
|
return $ case (mt, mi) of
|
|
(Just t, Just i) -> Just (t, i)
|
|
_ -> Nothing
|
|
findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive . fromRawFilePath)
|
|
=<< mapM (fromRepo . failedTransferDir u) [Download, Upload]
|
|
|
|
clearFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)]
|
|
clearFailedTransfers u = do
|
|
failed <- getFailedTransfers u
|
|
mapM_ (removeFailedTransfer . fst) failed
|
|
return failed
|
|
|
|
removeFailedTransfer :: Transfer -> Annex ()
|
|
removeFailedTransfer t = do
|
|
f <- fromRepo $ failedTransferFile t
|
|
liftIO $ void $ tryIO $ R.removeLink f
|
|
|
|
recordFailedTransfer :: Transfer -> TransferInfo -> Annex ()
|
|
recordFailedTransfer t info = do
|
|
failedtfile <- fromRepo $ failedTransferFile t
|
|
writeTransferInfoFile info failedtfile
|
|
|
|
{- The transfer information file to use for a given Transfer. -}
|
|
transferFile :: Transfer -> Git.Repo -> RawFilePath
|
|
transferFile (Transfer direction u kd) r =
|
|
transferDir direction r
|
|
P.</> B8.filter (/= '/') (fromUUID u)
|
|
P.</> keyFile (mkKey (const kd))
|
|
|
|
{- The transfer information file to use to record a failed Transfer -}
|
|
failedTransferFile :: Transfer -> Git.Repo -> RawFilePath
|
|
failedTransferFile (Transfer direction u kd) r =
|
|
failedTransferDir u direction r
|
|
P.</> keyFile (mkKey (const kd))
|
|
|
|
{- The transfer lock file corresponding to a given transfer info file. -}
|
|
transferLockFile :: RawFilePath -> RawFilePath
|
|
transferLockFile infofile =
|
|
let (d, f) = P.splitFileName infofile
|
|
in P.combine d ("lck." <> f)
|
|
|
|
{- Parses a transfer information filename to a Transfer. -}
|
|
parseTransferFile :: FilePath -> Maybe Transfer
|
|
parseTransferFile file
|
|
| "lck." `isPrefixOf` takeFileName file = Nothing
|
|
| otherwise = case drop (length bits - 3) bits of
|
|
[direction, u, key] -> Transfer
|
|
<$> parseDirection direction
|
|
<*> pure (toUUID u)
|
|
<*> fmap (fromKey id) (fileKey (toRawFilePath key))
|
|
_ -> Nothing
|
|
where
|
|
bits = splitDirectories file
|
|
|
|
writeTransferInfoFile :: TransferInfo -> RawFilePath -> Annex ()
|
|
writeTransferInfoFile info tfile = writeLogFile tfile $ writeTransferInfo info
|
|
|
|
-- The file keeps whatever permissions it has, so should be used only
|
|
-- after it's been created with the right perms by writeTransferInfoFile.
|
|
updateTransferInfoFile :: TransferInfo -> FilePath -> IO ()
|
|
updateTransferInfoFile info tfile = writeFile tfile $ writeTransferInfo info
|
|
|
|
{- File format is a header line containing the startedTime and any
|
|
- bytesComplete value. Followed by a newline and the associatedFile.
|
|
-
|
|
- On unix, the transferPid is not included; instead it is obtained
|
|
- by looking at the process that locks the file.
|
|
-
|
|
- On windows, the transferPid is included, as a second line.
|
|
-}
|
|
writeTransferInfo :: TransferInfo -> String
|
|
writeTransferInfo info = unlines
|
|
[ (maybe "" show $ startedTime info) ++
|
|
(maybe "" (\b -> ' ' : show b) (bytesComplete info))
|
|
#ifdef mingw32_HOST_OS
|
|
, maybe "" show (transferPid info)
|
|
#endif
|
|
-- comes last; arbitrary content
|
|
, let AssociatedFile afile = associatedFile info
|
|
in maybe "" fromRawFilePath afile
|
|
]
|
|
|
|
readTransferInfoFile :: Maybe PID -> FilePath -> IO (Maybe TransferInfo)
|
|
readTransferInfoFile mpid tfile = catchDefaultIO Nothing $
|
|
readTransferInfo mpid <$> readFileStrict tfile
|
|
|
|
readTransferInfo :: Maybe PID -> String -> Maybe TransferInfo
|
|
readTransferInfo mpid s = TransferInfo
|
|
<$> time
|
|
#ifdef mingw32_HOST_OS
|
|
<*> pure (if isJust mpid then mpid else mpid')
|
|
#else
|
|
<*> pure mpid
|
|
#endif
|
|
<*> pure Nothing
|
|
<*> pure Nothing
|
|
<*> bytes
|
|
<*> pure (AssociatedFile (if null filename then Nothing else Just (toRawFilePath filename)))
|
|
<*> pure False
|
|
where
|
|
#ifdef mingw32_HOST_OS
|
|
(firstline, otherlines) = separate (== '\n') s
|
|
(secondline, rest) = separate (== '\n') otherlines
|
|
mpid' = readish secondline
|
|
#else
|
|
(firstline, rest) = separate (== '\n') s
|
|
#endif
|
|
filename
|
|
| end rest == "\n" = beginning rest
|
|
| otherwise = rest
|
|
bits = splitc ' ' firstline
|
|
numbits = length bits
|
|
time = if numbits > 0
|
|
then Just <$> parsePOSIXTime =<< headMaybe bits
|
|
else pure Nothing -- not failure
|
|
bytes = if numbits > 1
|
|
then Just <$> readish =<< headMaybe (drop 1 bits)
|
|
else pure Nothing -- not failure
|
|
|
|
{- The directory holding transfer information files for a given Direction. -}
|
|
transferDir :: Direction -> Git.Repo -> RawFilePath
|
|
transferDir direction r = gitAnnexTransferDir r P.</> formatDirection direction
|
|
|
|
{- The directory holding failed transfer information files for a given
|
|
- Direction and UUID -}
|
|
failedTransferDir :: UUID -> Direction -> Git.Repo -> RawFilePath
|
|
failedTransferDir u direction r = gitAnnexTransferDir r
|
|
P.</> "failed"
|
|
P.</> formatDirection direction
|
|
P.</> B8.filter (/= '/') (fromUUID u)
|
|
|
|
prop_read_write_transferinfo :: TransferInfo -> Bool
|
|
prop_read_write_transferinfo info
|
|
| isJust (transferRemote info) = True -- remote not stored
|
|
| isJust (transferTid info) = True -- tid not stored
|
|
| otherwise = Just (info { transferPaused = False }) == info'
|
|
where
|
|
info' = readTransferInfo (transferPid info) (writeTransferInfo info)
|
|
|