git-annex/Logs/Transfer.hs

{- 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)