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.
57 lines
1.8 KiB
Haskell
57 lines
1.8 KiB
Haskell
{- git-annex assistant transfer polling thread
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.Threads.TransferPoller where
|
|
|
|
import Assistant.Common
|
|
import Assistant.DaemonStatus
|
|
import Logs.Transfer
|
|
import Utility.NotificationBroadcaster
|
|
import qualified Assistant.Threads.TransferWatcher as TransferWatcher
|
|
|
|
import Control.Concurrent
|
|
import qualified Data.Map as M
|
|
|
|
{- This thread polls the status of ongoing transfers, determining how much
|
|
- of each transfer is complete. -}
|
|
transferPollerThread :: NamedThread
|
|
transferPollerThread = NamedThread "TransferPoller" $ do
|
|
g <- liftAnnex gitRepo
|
|
tn <- liftIO . newNotificationHandle =<<
|
|
transferNotifier <$> daemonStatus
|
|
forever $ do
|
|
liftIO $ threadDelay 500000 -- 0.5 seconds
|
|
ts <- currentTransfers <$> daemonStatus
|
|
if M.null ts
|
|
-- block until transfers running
|
|
then liftIO $ waitNotification tn
|
|
else mapM_ (poll g) $ M.toList ts
|
|
where
|
|
poll g (t, info)
|
|
{- Downloads are polled by checking the size of the
|
|
- temp file being used for the transfer. -}
|
|
| transferDirection t == Download = do
|
|
let f = gitAnnexTmpLocation (transferKey t) g
|
|
sz <- liftIO $ catchMaybeIO $
|
|
fromIntegral . fileSize <$> getFileStatus f
|
|
newsize t info sz
|
|
{- Uploads don't need to be polled for when the TransferWatcher
|
|
- thread can track file modifications. -}
|
|
| TransferWatcher.watchesTransferSize = noop
|
|
{- Otherwise, this code polls the upload progress
|
|
- by reading the transfer info file. -}
|
|
| otherwise = do
|
|
let f = transferFile t g
|
|
mi <- liftIO $ catchDefaultIO Nothing $
|
|
readTransferInfoFile Nothing f
|
|
maybe noop (newsize t info . bytesComplete) mi
|
|
|
|
newsize t info sz
|
|
| bytesComplete info /= sz && isJust sz =
|
|
alterTransferInfo t (\i -> i { bytesComplete = sz })
|
|
<<~ daemonStatusHandle
|
|
| otherwise = noop
|