111 lines
3.5 KiB
Haskell
111 lines
3.5 KiB
Haskell
{- git-annex assistant data transferrer thread
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.Threads.Transferrer where
|
|
|
|
import Assistant.Common
|
|
import Assistant.ThreadedMonad
|
|
import Assistant.DaemonStatus
|
|
import Assistant.TransferQueue
|
|
import Assistant.TransferSlots
|
|
import Logs.Transfer
|
|
import Logs.Presence
|
|
import Logs.Location
|
|
import Annex.Content
|
|
import qualified Remote
|
|
|
|
import Data.Time.Clock.POSIX
|
|
import Data.Time.Clock
|
|
import qualified Data.Map as M
|
|
|
|
thisThread :: ThreadName
|
|
thisThread = "Transferrer"
|
|
|
|
{- For now only one transfer is run at a time. -}
|
|
maxTransfers :: Int
|
|
maxTransfers = 1
|
|
|
|
{- Dispatches transfers from the queue. -}
|
|
transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> IO ()
|
|
transfererThread st dstatus transferqueue slots = go
|
|
where
|
|
go = do
|
|
(t, info) <- getNextTransfer transferqueue
|
|
ifM (runThreadState st $ shouldTransfer dstatus t info)
|
|
( do
|
|
debug thisThread [ "Transferring:" , show t ]
|
|
runTransfer st dstatus slots t info
|
|
, debug thisThread [ "Skipping unnecessary transfer:" , show t ]
|
|
)
|
|
go
|
|
|
|
{- Checks if the requested transfer is already running, or
|
|
- the file to download is already present, or the remote
|
|
- being uploaded to isn't known to have the file. -}
|
|
shouldTransfer :: DaemonStatusHandle -> Transfer -> TransferInfo -> Annex Bool
|
|
shouldTransfer dstatus t info =
|
|
go =<< currentTransfers <$> getDaemonStatus dstatus
|
|
where
|
|
go m
|
|
| M.member t m = return False
|
|
| transferDirection t == Download =
|
|
not <$> inAnnex key
|
|
| transferDirection t == Upload =
|
|
{- Trust the location log to check if the
|
|
- remote already has the key. This avoids
|
|
- a roundtrip to the remote. -}
|
|
case transferRemote info of
|
|
Nothing -> return False
|
|
Just remote ->
|
|
notElem (Remote.uuid remote)
|
|
<$> loggedLocations key
|
|
| otherwise = return False
|
|
key = transferKey t
|
|
|
|
{- A transfer is run in a separate thread, with a *copy* of the Annex
|
|
- state. This is necessary to avoid blocking the rest of the assistant
|
|
- on the transfer completing, and also to allow multiple transfers to run
|
|
- at once. This requires GHC's threaded runtime to work!
|
|
-
|
|
- The copy of state means that the transfer processes are responsible
|
|
- for doing any necessary shutdown cleanups, and that the parent
|
|
- thread's cache must be invalidated once a transfer completes, as
|
|
- changes may have been made to the git-annex branch.
|
|
-}
|
|
runTransfer :: ThreadState -> DaemonStatusHandle -> TransferSlots -> Transfer -> TransferInfo -> IO ()
|
|
runTransfer st dstatus slots t info = case (transferRemote info, associatedFile info) of
|
|
(Nothing, _) -> noop
|
|
(_, Nothing) -> noop
|
|
(Just remote, Just file) -> do
|
|
tid <- inTransferSlot slots st $
|
|
transferprocess remote file
|
|
now <- getCurrentTime
|
|
runThreadState st $ adjustTransfers dstatus $
|
|
M.insertWith' const t info
|
|
{ startedTime = Just $ utcTimeToPOSIXSeconds now
|
|
, transferTid = Just tid
|
|
}
|
|
where
|
|
isdownload = transferDirection t == Download
|
|
tofrom
|
|
| isdownload = "from"
|
|
| otherwise = "to"
|
|
key = transferKey t
|
|
|
|
transferprocess remote file = do
|
|
showStart "copy" file
|
|
showAction $ tofrom ++ " " ++ Remote.name remote
|
|
ok <- transfer t (Just file) $
|
|
if isdownload
|
|
then getViaTmp key $
|
|
Remote.retrieveKeyFile remote key (Just file)
|
|
else do
|
|
ok <- Remote.storeKey remote key $ Just file
|
|
when ok $
|
|
Remote.logStatus remote key InfoPresent
|
|
return ok
|
|
showEndResult ok
|