diff options
| -rw-r--r-- | Assistant.hs | 4 | ||||
| -rw-r--r-- | Assistant/Commits.hs | 9 | ||||
| -rw-r--r-- | Assistant/Threads/Committer.hs | 2 | ||||
| -rw-r--r-- | Assistant/Threads/ConfigMonitor.hs | 4 | ||||
| -rw-r--r-- | Assistant/Threads/Pusher.hs | 10 | ||||
| -rw-r--r-- | Assistant/Threads/Transferrer.hs | 25 | ||||
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 5 | ||||
| -rw-r--r-- | Command/WebApp.hs | 5 |
8 files changed, 37 insertions, 27 deletions
diff --git a/Assistant.hs b/Assistant.hs index 6da565b5e..cf92a8625 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -197,7 +197,7 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do mapM_ (startthread dstatus) [ watch $ commitThread st changechan commitchan transferqueue dstatus #ifdef WITH_WEBAPP - , assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots pushnotifier urlrenderer Nothing webappwaiter + , assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots pushnotifier commitchan urlrenderer Nothing webappwaiter #ifdef WITH_PAIRING , assist $ pairListenerThread st dstatus scanremotes urlrenderer #endif @@ -207,7 +207,7 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do , assist $ mergeThread st dstatus transferqueue branchhandle , assist $ transferWatcherThread st dstatus transferqueue , assist $ transferPollerThread st dstatus - , assist $ transfererThread st dstatus transferqueue transferslots + , assist $ transfererThread st dstatus transferqueue transferslots commitchan , assist $ daemonStatusThread st dstatus , assist $ sanityCheckerThread st dstatus transferqueue changechan , assist $ mountWatcherThread st dstatus scanremotes pushnotifier diff --git a/Assistant/Commits.hs b/Assistant/Commits.hs index 86fd7599f..6c27ce3cb 100644 --- a/Assistant/Commits.hs +++ b/Assistant/Commits.hs @@ -9,12 +9,9 @@ module Assistant.Commits where import Utility.TSet -import Data.Time.Clock - type CommitChan = TSet Commit -data Commit = Commit UTCTime - deriving (Show) +data Commit = Commit newCommitChan :: IO CommitChan newCommitChan = newTSet @@ -30,5 +27,5 @@ refillCommits :: CommitChan -> [Commit] -> IO () refillCommits = putTSet {- Records a commit in the channel. -} -recordCommit :: CommitChan -> Commit -> IO () -recordCommit = putTSet1 +recordCommit :: CommitChan -> IO () +recordCommit = flip putTSet1 Commit diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 7c34f7a93..ceb885100 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -65,7 +65,7 @@ commitThread st changechan commitchan transferqueue dstatus = thread $ do ] void $ alertWhile dstatus commitAlert $ runThreadState st commitStaged - recordCommit commitchan (Commit time) + recordCommit commitchan else refill readychanges else refill changes where diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs index cfd3ca7d9..7450d5c6b 100644 --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -24,7 +24,6 @@ import qualified Git.LsTree as LsTree import qualified Annex.Branch import qualified Annex -import Data.Time.Clock import qualified Data.Set as S thisThread :: ThreadName @@ -56,8 +55,7 @@ configMonitorThread st dstatus branchhandle commitchan = thread $ do reloadConfigs st dstatus changedconfigs {- Record a commit to get this config - change pushed out to remotes. -} - time <- getCurrentTime - recordCommit commitchan (Commit time) + recordCommit commitchan go r new {- Config files, and their checksums. -} diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 295ceddc9..671a620b4 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -49,12 +49,12 @@ pushThread st dstatus commitchan pushmap pushnotifier = thread $ runEvery (Secon -- Next, wait until at least one commit has been made commits <- getCommits commitchan -- Now see if now's a good time to push. - now <- getCurrentTime - if shouldPush now commits + if shouldPush commits then do remotes <- filter pushable . syncRemotes <$> getDaemonStatus dstatus - unless (null remotes) $ + unless (null remotes) $ do + now <- getCurrentTime void $ alertWhile dstatus (pushAlert remotes) $ pushToRemotes thisThread now st (Just pushnotifier) (Just pushmap) remotes else do @@ -77,7 +77,7 @@ pushThread st dstatus commitchan pushmap pushnotifier = thread $ runEvery (Secon - already determines batches of changes, so we can't easily determine - batches better. -} -shouldPush :: UTCTime -> [Commit] -> Bool -shouldPush _now commits +shouldPush :: [Commit] -> Bool +shouldPush commits | not (null commits) = True | otherwise = False diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index fe06d5fa1..30d736073 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -13,6 +13,7 @@ import Assistant.DaemonStatus import Assistant.TransferQueue import Assistant.TransferSlots import Assistant.Alert +import Assistant.Commits import Logs.Transfer import Logs.Location import Annex.Content @@ -30,20 +31,20 @@ maxTransfers :: Int maxTransfers = 1 {- Dispatches transfers from the queue. -} -transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> NamedThread -transfererThread st dstatus transferqueue slots = thread $ go =<< readProgramFile +transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> CommitChan -> NamedThread +transfererThread st dstatus transferqueue slots commitchan = thread $ go =<< readProgramFile where thread = NamedThread thisThread go program = forever $ inTransferSlot dstatus slots $ - maybe (return Nothing) (uncurry $ startTransfer st dstatus program) + 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 -> FilePath -> Transfer -> TransferInfo -> TransferGenerator -startTransfer st dstatus program t info = case (transferRemote info, associatedFile info) of +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 debug thisThread [ "Transferring:" , show t ] @@ -66,11 +67,19 @@ startTransfer st dstatus program t info = case (transferRemote info, associatedF {- 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. -} - whenM ((==) ExitSuccess <$> waitForProcess pid) $ void $ - addAlert dstatus $ + - 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" diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 7657fc7b8..6ed827e01 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -33,6 +33,7 @@ import Assistant.ScanRemotes import Assistant.TransferQueue import Assistant.TransferSlots import Assistant.Pushes +import Assistant.Commits import Utility.WebApp import Utility.FileMode import Utility.TempFile @@ -57,11 +58,12 @@ webAppThread -> TransferQueue -> TransferSlots -> PushNotifier + -> CommitChan -> UrlRenderer -> Maybe (IO String) -> Maybe (Url -> FilePath -> IO ()) -> NamedThread -webAppThread mst dstatus scanremotes transferqueue transferslots pushnotifier urlrenderer postfirstrun onstartup = thread $ do +webAppThread mst dstatus scanremotes transferqueue transferslots pushnotifier commitchan urlrenderer postfirstrun onstartup = thread $ do webapp <- WebApp <$> pure mst <*> pure dstatus @@ -69,6 +71,7 @@ webAppThread mst dstatus scanremotes transferqueue transferslots pushnotifier ur <*> pure transferqueue <*> pure transferslots <*> pure pushnotifier + <*> pure commitchan <*> (pack <$> genRandomToken) <*> getreldir mst <*> pure $(embed "static") diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 99f94cd2f..5a372f94d 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -16,6 +16,7 @@ import Assistant.ScanRemotes import Assistant.TransferQueue import Assistant.TransferSlots import Assistant.Pushes +import Assistant.Commits import Assistant.Threads.WebApp import Assistant.WebApp import Assistant.Install @@ -106,11 +107,13 @@ firstRun = do transferslots <- newTransferSlots urlrenderer <- newUrlRenderer pushnotifier <- newPushNotifier + commitchan <- newCommitChan v <- newEmptyMVar let callback a = Just $ a v void $ runNamedThread dstatus $ webAppThread Nothing dstatus scanremotes - transferqueue transferslots pushnotifier urlrenderer + transferqueue transferslots pushnotifier commitchan + urlrenderer (callback signaler) (callback mainthread) where signaler v = do |