{- git-annex transfer information files and lock files - - Copyright 2012-2021 Joey Hess - - 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 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 :: Transfer -> TransferInfo -> String describeTransfer t info = unwords [ show $ transferDirection t , show $ transferUUID t , decodeBS $ 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 (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 (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)