mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

fix build (almost)

Browse source
This commit is contained in:
Joey Hess 2012-07-06 14:42:45 -04:00
parent a92f5589fc
commit 721748135b
2 changed files with 16 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

33
Assistant/Threads/Transferrer.hs
View file

@ -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
}

1
Assistant/TransferQueue.hs
View file

@ -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