fix build (almost)
This commit is contained in:
parent
a92f5589fc
commit
721748135b
2 changed files with 16 additions and 18 deletions
|
@ -13,13 +13,10 @@ import Assistant.DaemonStatus
|
||||||
import Assistant.TransferQueue
|
import Assistant.TransferQueue
|
||||||
import Logs.Transfer
|
import Logs.Transfer
|
||||||
import Annex.Content
|
import Annex.Content
|
||||||
import Annex.BranchState
|
|
||||||
import Utility.ThreadScheduler
|
import Utility.ThreadScheduler
|
||||||
import Command
|
import Command
|
||||||
import qualified Command.Move
|
import qualified Command.Move
|
||||||
|
|
||||||
import Control.Exception as E
|
|
||||||
import Control.Concurrent
|
|
||||||
import Data.Time.Clock
|
import Data.Time.Clock
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
|
||||||
|
@ -31,11 +28,11 @@ maxTransfers = 1
|
||||||
transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> IO ()
|
transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> IO ()
|
||||||
transfererThread st dstatus transferqueue = runEvery (Seconds 1) $ do
|
transfererThread st dstatus transferqueue = runEvery (Seconds 1) $ do
|
||||||
(t, info) <- getNextTransfer transferqueue
|
(t, info) <- getNextTransfer transferqueue
|
||||||
go =<< runThreadState st $ shouldTransfer t
|
c <- runThreadState st $ shouldTransfer dstatus t
|
||||||
where
|
case c of
|
||||||
go Yes = runTransfer st t
|
Yes -> void $ runTransfer st dstatus t info
|
||||||
go No = noop
|
Skip -> noop
|
||||||
go TooMany = waitTransfer >> go Yes
|
TooMany -> void $ waitTransfer >> runTransfer st dstatus t info
|
||||||
|
|
||||||
data ShouldTransfer = Yes | Skip | TooMany
|
data ShouldTransfer = Yes | Skip | TooMany
|
||||||
|
|
||||||
|
@ -51,7 +48,8 @@ shouldTransfer dstatus t = go =<< currentTransfers <$> getDaemonStatus dstatus
|
||||||
| M.member t m = return Skip
|
| M.member t m = return Skip
|
||||||
| M.size m > maxTransfers = return TooMany
|
| M.size m > maxTransfers = return TooMany
|
||||||
| transferDirection t == Download =
|
| transferDirection t == Download =
|
||||||
ifM (inAnnex $ transferKey t) (No, Yes)
|
ifM (inAnnex $ transferKey t)
|
||||||
|
(return Skip, return Yes)
|
||||||
| otherwise = return Yes
|
| otherwise = return Yes
|
||||||
|
|
||||||
{- Waits for any of the transfers in the map to complete. -}
|
{- Waits for any of the transfers in the map to complete. -}
|
||||||
|
@ -74,8 +72,8 @@ waitTransfer = error "TODO"
|
||||||
- effectively running in oneshot mode, without committing changes to the
|
- effectively running in oneshot mode, without committing changes to the
|
||||||
- git-annex branch, and transfers should never queue git commands to run.
|
- git-annex branch, and transfers should never queue git commands to run.
|
||||||
-}
|
-}
|
||||||
runTransfer :: ThreadState -> Transfer -> TransferInfo -> IO ProcessID
|
runTransfer :: ThreadState -> DaemonStatusHandle -> Transfer -> TransferInfo -> IO ()
|
||||||
runTransfer st t info
|
runTransfer st dstatus t info
|
||||||
| transferDirection t == Download = go Command.Move.fromStart
|
| transferDirection t == Download = go Command.Move.fromStart
|
||||||
| otherwise = go Command.Move.toStart
|
| otherwise = go Command.Move.toStart
|
||||||
where
|
where
|
||||||
|
@ -84,10 +82,11 @@ runTransfer st t info
|
||||||
(_, Nothing) -> noop
|
(_, Nothing) -> noop
|
||||||
(Just remote, Just file) -> do
|
(Just remote, Just file) -> do
|
||||||
now <- getCurrentTime
|
now <- getCurrentTime
|
||||||
pid <- forkProcess $ unsafeRunThreadState st $
|
pid <- forkProcess $ unsafeRunThreadState st $ void $
|
||||||
doCommand $ cmd remote False file (transferKey t)
|
doCommand $ cmd remote False file (transferKey t)
|
||||||
adjustTransfers dstatus $
|
runThreadState st $
|
||||||
M.insertWith' const t info
|
adjustTransfers dstatus $
|
||||||
{ startedTime = Just now
|
M.insertWith' const t info
|
||||||
, transferPid = Just pid
|
{ startedTime = Just now
|
||||||
}
|
, transferPid = Just pid
|
||||||
|
}
|
||||||
|
|
|
@ -24,7 +24,6 @@ stubInfo :: AssociatedFile -> TransferInfo
|
||||||
stubInfo f = TransferInfo
|
stubInfo f = TransferInfo
|
||||||
{ startedTime = Nothing
|
{ startedTime = Nothing
|
||||||
, transferPid = Nothing
|
, transferPid = Nothing
|
||||||
, transferThread = Nothing
|
|
||||||
, transferRemote = Nothing
|
, transferRemote = Nothing
|
||||||
, bytesComplete = Nothing
|
, bytesComplete = Nothing
|
||||||
, associatedFile = f
|
, associatedFile = f
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue