4dbdc2b666
Converted several threads to run in the monad. Added a lot of useful combinators for working with the monad. Now the monad includes the name of the thread. Some debugging messages are disabled pending converting other threads.
113 lines
3.7 KiB
Haskell
113 lines
3.7 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 Assistant.Alert
|
|
import Assistant.Commits
|
|
import Logs.Transfer
|
|
import Logs.Location
|
|
import Annex.Content
|
|
import qualified Remote
|
|
import Types.Key
|
|
import Locations.UserConfig
|
|
|
|
import System.Process (create_group)
|
|
|
|
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 -> CommitChan -> NamedThread
|
|
transfererThread st dstatus transferqueue slots commitchan = thread $ liftIO $ go =<< readProgramFile
|
|
where
|
|
thread = NamedThread thisThread
|
|
go program = forever $ inTransferSlot dstatus slots $
|
|
maybe (return Nothing) (uncurry $ startTransfer st dstatus commitchan program)
|
|
=<< getNextTransfer transferqueue dstatus notrunning
|
|
{- Skip transfers that are already running. -}
|
|
notrunning = isNothing . startedTime
|
|
|
|
{- By the time this is called, the daemonstatus's transfer map should
|
|
- already have been updated to include the transfer. -}
|
|
startTransfer :: ThreadState -> DaemonStatusHandle -> CommitChan -> FilePath -> Transfer -> TransferInfo -> TransferGenerator
|
|
startTransfer st dstatus commitchan program t info = case (transferRemote info, associatedFile info) of
|
|
(Just remote, Just file) -> ifM (runThreadState st $ shouldTransfer t info)
|
|
( do
|
|
brokendebug thisThread [ "Transferring:" , show t ]
|
|
notifyTransfer dstatus
|
|
return $ Just (t, info, transferprocess remote file)
|
|
, do
|
|
brokendebug thisThread [ "Skipping unnecessary transfer:" , show t ]
|
|
void $ removeTransfer dstatus t
|
|
return Nothing
|
|
)
|
|
_ -> return Nothing
|
|
where
|
|
direction = transferDirection t
|
|
isdownload = direction == Download
|
|
|
|
transferprocess remote file = void $ do
|
|
(_, _, _, pid)
|
|
<- createProcess (proc program $ toCommand params)
|
|
{ create_group = True }
|
|
{- Alerts are only shown for successful transfers.
|
|
- Transfers can temporarily fail for many reasons,
|
|
- so there's no point in bothering the user about
|
|
- those. The assistant should recover.
|
|
-
|
|
- Also, after a successful transfer, the location
|
|
- log has changed. Indicate that a commit has been
|
|
- made, in order to queue a push of the git-annex
|
|
- branch out to remotes that did not participate
|
|
- in the transfer.
|
|
-}
|
|
whenM ((==) ExitSuccess <$> waitForProcess pid) $ do
|
|
void $ addAlert dstatus $
|
|
makeAlertFiller True $
|
|
transferFileAlert direction True file
|
|
recordCommit commitchan
|
|
where
|
|
params =
|
|
[ Param "transferkey"
|
|
, Param "--quiet"
|
|
, Param $ key2file $ transferKey t
|
|
, Param $ if isdownload
|
|
then "--from"
|
|
else "--to"
|
|
, Param $ Remote.name remote
|
|
, Param "--file"
|
|
, File file
|
|
]
|
|
|
|
{- Checks if the file to download is already present, or the remote
|
|
- being uploaded to isn't known to have the file. -}
|
|
shouldTransfer :: Transfer -> TransferInfo -> Annex Bool
|
|
shouldTransfer t info
|
|
| 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
|
|
where
|
|
key = transferKey t
|