display errors when any named thread crashes
This commit is contained in:
parent
d11ded822c
commit
a00f1d26bc
18 changed files with 133 additions and 64 deletions
11
Assistant.hs
11
Assistant.hs
|
@ -110,6 +110,7 @@ import Assistant.Pushes
|
||||||
import Assistant.ScanRemotes
|
import Assistant.ScanRemotes
|
||||||
import Assistant.TransferQueue
|
import Assistant.TransferQueue
|
||||||
import Assistant.TransferSlots
|
import Assistant.TransferSlots
|
||||||
|
import Assistant.Threads.DaemonStatus
|
||||||
import Assistant.Threads.Watcher
|
import Assistant.Threads.Watcher
|
||||||
import Assistant.Threads.Committer
|
import Assistant.Threads.Committer
|
||||||
import Assistant.Threads.Pusher
|
import Assistant.Threads.Pusher
|
||||||
|
@ -132,6 +133,8 @@ import Utility.ThreadScheduler
|
||||||
|
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
|
|
||||||
|
type NamedThread = IO () -> IO (String, IO ())
|
||||||
|
|
||||||
stopDaemon :: Annex ()
|
stopDaemon :: Annex ()
|
||||||
stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
|
stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
|
||||||
|
|
||||||
|
@ -162,7 +165,7 @@ startAssistant assistant daemonize webappwaiter = do
|
||||||
transferqueue <- newTransferQueue
|
transferqueue <- newTransferQueue
|
||||||
transferslots <- newTransferSlots
|
transferslots <- newTransferSlots
|
||||||
scanremotes <- newScanRemoteMap
|
scanremotes <- newScanRemoteMap
|
||||||
mapM_ startthread
|
mapM_ (startthread dstatus)
|
||||||
[ watch $ commitThread st changechan commitchan transferqueue dstatus
|
[ watch $ commitThread st changechan commitchan transferqueue dstatus
|
||||||
#ifdef WITH_WEBAPP
|
#ifdef WITH_WEBAPP
|
||||||
, assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots Nothing webappwaiter
|
, assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots Nothing webappwaiter
|
||||||
|
@ -177,12 +180,14 @@ startAssistant assistant daemonize webappwaiter = do
|
||||||
, assist $ sanityCheckerThread st dstatus transferqueue changechan
|
, assist $ sanityCheckerThread st dstatus transferqueue changechan
|
||||||
, assist $ mountWatcherThread st dstatus scanremotes
|
, assist $ mountWatcherThread st dstatus scanremotes
|
||||||
, assist $ netWatcherThread st dstatus scanremotes
|
, assist $ netWatcherThread st dstatus scanremotes
|
||||||
|
, assist $ netWatcherFallbackThread st dstatus scanremotes
|
||||||
, assist $ transferScannerThread st dstatus scanremotes transferqueue
|
, assist $ transferScannerThread st dstatus scanremotes transferqueue
|
||||||
, watch $ watchThread st dstatus transferqueue changechan
|
, watch $ watchThread st dstatus transferqueue changechan
|
||||||
]
|
]
|
||||||
waitForTermination
|
waitForTermination
|
||||||
watch a = (True, a)
|
watch a = (True, a)
|
||||||
assist a = (False, a)
|
assist a = (False, a)
|
||||||
startthread (watcher, a)
|
startthread dstatus (watcher, t)
|
||||||
| watcher || assistant = void $ forkIO a
|
| watcher || assistant = void $ forkIO $
|
||||||
|
runNamedThread dstatus t
|
||||||
| otherwise = noop
|
| otherwise = noop
|
||||||
|
|
|
@ -8,14 +8,38 @@
|
||||||
module Assistant.Common (
|
module Assistant.Common (
|
||||||
module X,
|
module X,
|
||||||
ThreadName,
|
ThreadName,
|
||||||
|
NamedThread(..),
|
||||||
|
runNamedThread,
|
||||||
debug
|
debug
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Common.Annex as X
|
import Common.Annex as X
|
||||||
|
import Assistant.DaemonStatus
|
||||||
|
import Assistant.Alert
|
||||||
|
|
||||||
import System.Log.Logger
|
import System.Log.Logger
|
||||||
|
import qualified Control.Exception as E
|
||||||
|
|
||||||
type ThreadName = String
|
type ThreadName = String
|
||||||
|
data NamedThread = NamedThread ThreadName (IO ())
|
||||||
|
|
||||||
debug :: ThreadName -> [String] -> IO ()
|
debug :: ThreadName -> [String] -> IO ()
|
||||||
debug threadname ws = debugM threadname $ unwords $ (threadname ++ ":") : ws
|
debug threadname ws = debugM threadname $ unwords $ (threadname ++ ":") : ws
|
||||||
|
|
||||||
|
runNamedThread :: DaemonStatusHandle -> NamedThread -> IO ()
|
||||||
|
runNamedThread dstatus (NamedThread name a) = go
|
||||||
|
where
|
||||||
|
go = do
|
||||||
|
r <- E.try a :: IO (Either E.SomeException ())
|
||||||
|
case r of
|
||||||
|
Right _ -> noop
|
||||||
|
Left e -> do
|
||||||
|
let msg = unwords
|
||||||
|
[ name
|
||||||
|
, "crashed:"
|
||||||
|
, show e
|
||||||
|
]
|
||||||
|
hPutStrLn stderr msg
|
||||||
|
-- TODO click to restart
|
||||||
|
void $ addAlert dstatus $
|
||||||
|
warningAlert name msg
|
||||||
|
|
|
@ -8,9 +8,7 @@
|
||||||
module Assistant.DaemonStatus where
|
module Assistant.DaemonStatus where
|
||||||
|
|
||||||
import Common.Annex
|
import Common.Annex
|
||||||
import Assistant.ThreadedMonad
|
|
||||||
import Assistant.Alert
|
import Assistant.Alert
|
||||||
import Utility.ThreadScheduler
|
|
||||||
import Utility.TempFile
|
import Utility.TempFile
|
||||||
import Utility.NotificationBroadcaster
|
import Utility.NotificationBroadcaster
|
||||||
import Logs.Transfer
|
import Logs.Transfer
|
||||||
|
@ -114,23 +112,6 @@ startDaemonStatus = do
|
||||||
, knownRemotes = remotes
|
, knownRemotes = remotes
|
||||||
}
|
}
|
||||||
|
|
||||||
{- This writes the daemon status to disk, when it changes, but no more
|
|
||||||
- frequently than once every ten minutes.
|
|
||||||
-}
|
|
||||||
daemonStatusThread :: ThreadState -> DaemonStatusHandle -> IO ()
|
|
||||||
daemonStatusThread st dstatus = do
|
|
||||||
notifier <- newNotificationHandle
|
|
||||||
=<< changeNotifier <$> getDaemonStatus dstatus
|
|
||||||
checkpoint
|
|
||||||
runEvery (Seconds tenMinutes) $ do
|
|
||||||
waitNotification notifier
|
|
||||||
checkpoint
|
|
||||||
where
|
|
||||||
checkpoint = do
|
|
||||||
status <- getDaemonStatus dstatus
|
|
||||||
file <- runThreadState st $ fromRepo gitAnnexDaemonStatusFile
|
|
||||||
writeDaemonStatusFile file status
|
|
||||||
|
|
||||||
{- Don't just dump out the structure, because it will change over time,
|
{- Don't just dump out the structure, because it will change over time,
|
||||||
- and parts of it are not relevant. -}
|
- and parts of it are not relevant. -}
|
||||||
writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO ()
|
writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO ()
|
||||||
|
|
|
@ -42,7 +42,7 @@ reconnectRemotes threadname st dstatus scanremotes rs = void $
|
||||||
addScanRemotes scanremotes diverged rs
|
addScanRemotes scanremotes diverged rs
|
||||||
return ok
|
return ok
|
||||||
where
|
where
|
||||||
(gitremotes, specialremotes) =
|
(gitremotes, _specialremotes) =
|
||||||
partition (Git.repoIsUrl . Remote.repo) rs
|
partition (Git.repoIsUrl . Remote.repo) rs
|
||||||
sync (Just branch) = do
|
sync (Just branch) = do
|
||||||
diverged <- manualPull st (Just branch) gitremotes
|
diverged <- manualPull st (Just branch) gitremotes
|
||||||
|
|
|
@ -36,8 +36,8 @@ thisThread :: ThreadName
|
||||||
thisThread = "Committer"
|
thisThread = "Committer"
|
||||||
|
|
||||||
{- This thread makes git commits at appropriate times. -}
|
{- This thread makes git commits at appropriate times. -}
|
||||||
commitThread :: ThreadState -> ChangeChan -> CommitChan -> TransferQueue -> DaemonStatusHandle -> IO ()
|
commitThread :: ThreadState -> ChangeChan -> CommitChan -> TransferQueue -> DaemonStatusHandle -> NamedThread
|
||||||
commitThread st changechan commitchan transferqueue dstatus = runEvery (Seconds 1) $ do
|
commitThread st changechan commitchan transferqueue dstatus = thread $ runEvery (Seconds 1) $ do
|
||||||
-- We already waited one second as a simple rate limiter.
|
-- We already waited one second as a simple rate limiter.
|
||||||
-- Next, wait until at least one change is available for
|
-- Next, wait until at least one change is available for
|
||||||
-- processing.
|
-- processing.
|
||||||
|
@ -61,6 +61,7 @@ commitThread st changechan commitchan transferqueue dstatus = runEvery (Seconds
|
||||||
else refill readychanges
|
else refill readychanges
|
||||||
else refill changes
|
else refill changes
|
||||||
where
|
where
|
||||||
|
thread = NamedThread thisThread
|
||||||
refill [] = noop
|
refill [] = noop
|
||||||
refill cs = do
|
refill cs = do
|
||||||
debug thisThread
|
debug thisThread
|
||||||
|
|
36
Assistant/Threads/DaemonStatus.hs
Normal file
36
Assistant/Threads/DaemonStatus.hs
Normal file
|
@ -0,0 +1,36 @@
|
||||||
|
{- git-annex assistant daemon status thread
|
||||||
|
-
|
||||||
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||||
|
-
|
||||||
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
|
-}
|
||||||
|
|
||||||
|
module Assistant.Threads.DaemonStatus where
|
||||||
|
|
||||||
|
import Assistant.Common
|
||||||
|
import Assistant.DaemonStatus
|
||||||
|
import Assistant.ThreadedMonad
|
||||||
|
import Utility.ThreadScheduler
|
||||||
|
import Utility.NotificationBroadcaster
|
||||||
|
|
||||||
|
thisThread :: ThreadName
|
||||||
|
thisThread = "DaemonStatus"
|
||||||
|
|
||||||
|
{- This writes the daemon status to disk, when it changes, but no more
|
||||||
|
- frequently than once every ten minutes.
|
||||||
|
-}
|
||||||
|
daemonStatusThread :: ThreadState -> DaemonStatusHandle -> NamedThread
|
||||||
|
daemonStatusThread st dstatus = thread $ do
|
||||||
|
notifier <- newNotificationHandle
|
||||||
|
=<< changeNotifier <$> getDaemonStatus dstatus
|
||||||
|
checkpoint
|
||||||
|
runEvery (Seconds tenMinutes) $ do
|
||||||
|
waitNotification notifier
|
||||||
|
checkpoint
|
||||||
|
where
|
||||||
|
thread = NamedThread thisThread
|
||||||
|
checkpoint = do
|
||||||
|
status <- getDaemonStatus dstatus
|
||||||
|
file <- runThreadState st $ fromRepo gitAnnexDaemonStatusFile
|
||||||
|
writeDaemonStatusFile file status
|
||||||
|
|
|
@ -22,8 +22,8 @@ thisThread = "Merger"
|
||||||
{- This thread watches for changes to .git/refs/heads/synced/,
|
{- This thread watches for changes to .git/refs/heads/synced/,
|
||||||
- which indicate incoming pushes. It merges those pushes into the
|
- which indicate incoming pushes. It merges those pushes into the
|
||||||
- currently checked out branch. -}
|
- currently checked out branch. -}
|
||||||
mergeThread :: ThreadState -> IO ()
|
mergeThread :: ThreadState -> NamedThread
|
||||||
mergeThread st = do
|
mergeThread st = thread $ do
|
||||||
g <- runThreadState st $ fromRepo id
|
g <- runThreadState st $ fromRepo id
|
||||||
let dir = Git.localGitDir g </> "refs" </> "heads" </> "synced"
|
let dir = Git.localGitDir g </> "refs" </> "heads" </> "synced"
|
||||||
createDirectoryIfMissing True dir
|
createDirectoryIfMissing True dir
|
||||||
|
@ -34,6 +34,8 @@ mergeThread st = do
|
||||||
}
|
}
|
||||||
void $ watchDir dir (const False) hooks id
|
void $ watchDir dir (const False) hooks id
|
||||||
debug thisThread ["watching", dir]
|
debug thisThread ["watching", dir]
|
||||||
|
where
|
||||||
|
thread = NamedThread thisThread
|
||||||
|
|
||||||
type Handler = Git.Repo -> FilePath -> Maybe FileStatus -> IO ()
|
type Handler = Git.Repo -> FilePath -> Maybe FileStatus -> IO ()
|
||||||
|
|
||||||
|
|
|
@ -38,13 +38,15 @@ import Data.Word (Word32)
|
||||||
thisThread :: ThreadName
|
thisThread :: ThreadName
|
||||||
thisThread = "MountWatcher"
|
thisThread = "MountWatcher"
|
||||||
|
|
||||||
mountWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO ()
|
mountWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> NamedThread
|
||||||
mountWatcherThread st handle scanremotes =
|
mountWatcherThread st handle scanremotes = thread $
|
||||||
#if WITH_DBUS
|
#if WITH_DBUS
|
||||||
dbusThread st handle scanremotes
|
dbusThread st handle scanremotes
|
||||||
#else
|
#else
|
||||||
pollingThread st handle scanremotes
|
pollingThread st handle scanremotes
|
||||||
#endif
|
#endif
|
||||||
|
where
|
||||||
|
thread = NamedThread thisThread
|
||||||
|
|
||||||
#if WITH_DBUS
|
#if WITH_DBUS
|
||||||
|
|
||||||
|
|
|
@ -15,13 +15,11 @@ import Assistant.ThreadedMonad
|
||||||
import Assistant.DaemonStatus
|
import Assistant.DaemonStatus
|
||||||
import Assistant.ScanRemotes
|
import Assistant.ScanRemotes
|
||||||
import Assistant.Sync
|
import Assistant.Sync
|
||||||
import qualified Git
|
|
||||||
import Utility.ThreadScheduler
|
import Utility.ThreadScheduler
|
||||||
import Remote.List
|
import Remote.List
|
||||||
import qualified Types.Remote as Remote
|
import qualified Types.Remote as Remote
|
||||||
|
|
||||||
import qualified Control.Exception as E
|
import qualified Control.Exception as E
|
||||||
import Control.Concurrent
|
|
||||||
|
|
||||||
#if WITH_DBUS
|
#if WITH_DBUS
|
||||||
import Utility.DBus
|
import Utility.DBus
|
||||||
|
@ -35,18 +33,27 @@ import Data.Word (Word32)
|
||||||
thisThread :: ThreadName
|
thisThread :: ThreadName
|
||||||
thisThread = "NetWatcher"
|
thisThread = "NetWatcher"
|
||||||
|
|
||||||
netWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO ()
|
netWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> NamedThread
|
||||||
netWatcherThread st dstatus scanremotes = do
|
netWatcherThread st dstatus scanremotes = thread $ do
|
||||||
#if WITH_DBUS
|
#if WITH_DBUS
|
||||||
void $ forkIO $ dbusThread st dstatus scanremotes
|
dbusThread st dstatus scanremotes
|
||||||
|
#else
|
||||||
|
noop
|
||||||
#endif
|
#endif
|
||||||
{- This is a fallback for when dbus cannot be used to detect
|
where
|
||||||
- network connection changes, but it also ensures that
|
thread = NamedThread thisThread
|
||||||
- any networked remotes that may have not been routable for a
|
|
||||||
- while (despite the local network staying up), are synced with
|
{- This is a fallback for when dbus cannot be used to detect
|
||||||
- periodically. -}
|
- network connection changes, but it also ensures that
|
||||||
|
- any networked remotes that may have not been routable for a
|
||||||
|
- while (despite the local network staying up), are synced with
|
||||||
|
- periodically. -}
|
||||||
|
netWatcherFallbackThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> NamedThread
|
||||||
|
netWatcherFallbackThread st dstatus scanremotes = thread $ do
|
||||||
runEvery (Seconds 3600) $
|
runEvery (Seconds 3600) $
|
||||||
handleConnection st dstatus scanremotes
|
handleConnection st dstatus scanremotes
|
||||||
|
where
|
||||||
|
thread = NamedThread thisThread
|
||||||
|
|
||||||
#if WITH_DBUS
|
#if WITH_DBUS
|
||||||
|
|
||||||
|
|
|
@ -24,8 +24,8 @@ thisThread :: ThreadName
|
||||||
thisThread = "Pusher"
|
thisThread = "Pusher"
|
||||||
|
|
||||||
{- This thread retries pushes that failed before. -}
|
{- This thread retries pushes that failed before. -}
|
||||||
pushRetryThread :: ThreadState -> DaemonStatusHandle -> FailedPushMap -> IO ()
|
pushRetryThread :: ThreadState -> DaemonStatusHandle -> FailedPushMap -> NamedThread
|
||||||
pushRetryThread st dstatus pushmap = runEvery (Seconds halfhour) $ do
|
pushRetryThread st dstatus pushmap = thread $ runEvery (Seconds halfhour) $ do
|
||||||
-- We already waited half an hour, now wait until there are failed
|
-- We already waited half an hour, now wait until there are failed
|
||||||
-- pushes to retry.
|
-- pushes to retry.
|
||||||
topush <- getFailedPushesBefore pushmap (fromIntegral halfhour)
|
topush <- getFailedPushesBefore pushmap (fromIntegral halfhour)
|
||||||
|
@ -40,10 +40,11 @@ pushRetryThread st dstatus pushmap = runEvery (Seconds halfhour) $ do
|
||||||
pushToRemotes thisThread now st (Just pushmap) topush
|
pushToRemotes thisThread now st (Just pushmap) topush
|
||||||
where
|
where
|
||||||
halfhour = 1800
|
halfhour = 1800
|
||||||
|
thread = NamedThread thisThread
|
||||||
|
|
||||||
{- This thread pushes git commits out to remotes soon after they are made. -}
|
{- This thread pushes git commits out to remotes soon after they are made. -}
|
||||||
pushThread :: ThreadState -> DaemonStatusHandle -> CommitChan -> FailedPushMap -> IO ()
|
pushThread :: ThreadState -> DaemonStatusHandle -> CommitChan -> FailedPushMap -> NamedThread
|
||||||
pushThread st dstatus commitchan pushmap = do
|
pushThread st dstatus commitchan pushmap = thread $ do
|
||||||
runEvery (Seconds 2) $ do
|
runEvery (Seconds 2) $ do
|
||||||
-- We already waited two seconds as a simple rate limiter.
|
-- We already waited two seconds as a simple rate limiter.
|
||||||
-- Next, wait until at least one commit has been made
|
-- Next, wait until at least one commit has been made
|
||||||
|
@ -64,11 +65,12 @@ pushThread st dstatus commitchan pushmap = do
|
||||||
, "commits"
|
, "commits"
|
||||||
]
|
]
|
||||||
refillCommits commitchan commits
|
refillCommits commitchan commits
|
||||||
where
|
where
|
||||||
pushable r
|
thread = NamedThread thisThread
|
||||||
| Remote.specialRemote r = False
|
pushable r
|
||||||
| Remote.readonly r = False
|
| Remote.specialRemote r = False
|
||||||
| otherwise = True
|
| Remote.readonly r = False
|
||||||
|
| otherwise = True
|
||||||
|
|
||||||
{- Decide if now is a good time to push to remotes.
|
{- Decide if now is a good time to push to remotes.
|
||||||
-
|
-
|
||||||
|
|
|
@ -25,8 +25,8 @@ thisThread :: ThreadName
|
||||||
thisThread = "SanityChecker"
|
thisThread = "SanityChecker"
|
||||||
|
|
||||||
{- This thread wakes up occasionally to make sure the tree is in good shape. -}
|
{- This thread wakes up occasionally to make sure the tree is in good shape. -}
|
||||||
sanityCheckerThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO ()
|
sanityCheckerThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> NamedThread
|
||||||
sanityCheckerThread st dstatus transferqueue changechan = forever $ do
|
sanityCheckerThread st dstatus transferqueue changechan = thread $ forever $ do
|
||||||
waitForNextCheck dstatus
|
waitForNextCheck dstatus
|
||||||
|
|
||||||
debug thisThread ["starting sanity check"]
|
debug thisThread ["starting sanity check"]
|
||||||
|
@ -35,6 +35,7 @@ sanityCheckerThread st dstatus transferqueue changechan = forever $ do
|
||||||
|
|
||||||
debug thisThread ["sanity check complete"]
|
debug thisThread ["sanity check complete"]
|
||||||
where
|
where
|
||||||
|
thread = NamedThread thisThread
|
||||||
go = do
|
go = do
|
||||||
modifyDaemonStatus_ dstatus $ \s -> s
|
modifyDaemonStatus_ dstatus $ \s -> s
|
||||||
{ sanityCheckRunning = True }
|
{ sanityCheckRunning = True }
|
||||||
|
|
|
@ -21,8 +21,8 @@ thisThread = "TransferPoller"
|
||||||
|
|
||||||
{- This thread polls the status of ongoing transfers, determining how much
|
{- This thread polls the status of ongoing transfers, determining how much
|
||||||
- of each transfer is complete. -}
|
- of each transfer is complete. -}
|
||||||
transferPollerThread :: ThreadState -> DaemonStatusHandle -> IO ()
|
transferPollerThread :: ThreadState -> DaemonStatusHandle -> NamedThread
|
||||||
transferPollerThread st dstatus = do
|
transferPollerThread st dstatus = thread $ do
|
||||||
g <- runThreadState st $ fromRepo id
|
g <- runThreadState st $ fromRepo id
|
||||||
tn <- newNotificationHandle =<<
|
tn <- newNotificationHandle =<<
|
||||||
transferNotifier <$> getDaemonStatus dstatus
|
transferNotifier <$> getDaemonStatus dstatus
|
||||||
|
@ -33,6 +33,7 @@ transferPollerThread st dstatus = do
|
||||||
then waitNotification tn -- block until transfers running
|
then waitNotification tn -- block until transfers running
|
||||||
else mapM_ (poll g) $ M.toList ts
|
else mapM_ (poll g) $ M.toList ts
|
||||||
where
|
where
|
||||||
|
thread = NamedThread thisThread
|
||||||
poll g (t, info)
|
poll g (t, info)
|
||||||
{- Downloads are polled by checking the size of the
|
{- Downloads are polled by checking the size of the
|
||||||
- temp file being used for the transfer. -}
|
- temp file being used for the transfer. -}
|
||||||
|
|
|
@ -31,11 +31,12 @@ thisThread = "TransferScanner"
|
||||||
{- This thread waits until a remote needs to be scanned, to find transfers
|
{- This thread waits until a remote needs to be scanned, to find transfers
|
||||||
- that need to be made, to keep data in sync.
|
- that need to be made, to keep data in sync.
|
||||||
-}
|
-}
|
||||||
transferScannerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> TransferQueue -> IO ()
|
transferScannerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> TransferQueue -> NamedThread
|
||||||
transferScannerThread st dstatus scanremotes transferqueue = do
|
transferScannerThread st dstatus scanremotes transferqueue = thread $ do
|
||||||
startupScan
|
startupScan
|
||||||
go S.empty
|
go S.empty
|
||||||
where
|
where
|
||||||
|
thread = NamedThread thisThread
|
||||||
go scanned = do
|
go scanned = do
|
||||||
threadDelaySeconds (Seconds 2)
|
threadDelaySeconds (Seconds 2)
|
||||||
(rs, infos) <- unzip <$> getScanRemote scanremotes
|
(rs, infos) <- unzip <$> getScanRemote scanremotes
|
||||||
|
|
|
@ -20,8 +20,8 @@ thisThread = "TransferWatcher"
|
||||||
|
|
||||||
{- This thread watches for changes to the gitAnnexTransferDir,
|
{- This thread watches for changes to the gitAnnexTransferDir,
|
||||||
- and updates the DaemonStatus's map of ongoing transfers. -}
|
- and updates the DaemonStatus's map of ongoing transfers. -}
|
||||||
transferWatcherThread :: ThreadState -> DaemonStatusHandle -> IO ()
|
transferWatcherThread :: ThreadState -> DaemonStatusHandle -> NamedThread
|
||||||
transferWatcherThread st dstatus = do
|
transferWatcherThread st dstatus = thread $ do
|
||||||
g <- runThreadState st $ fromRepo id
|
g <- runThreadState st $ fromRepo id
|
||||||
let dir = gitAnnexTransferDir g
|
let dir = gitAnnexTransferDir g
|
||||||
createDirectoryIfMissing True dir
|
createDirectoryIfMissing True dir
|
||||||
|
@ -33,6 +33,8 @@ transferWatcherThread st dstatus = do
|
||||||
}
|
}
|
||||||
void $ watchDir dir (const False) hooks id
|
void $ watchDir dir (const False) hooks id
|
||||||
debug thisThread ["watching for transfers"]
|
debug thisThread ["watching for transfers"]
|
||||||
|
where
|
||||||
|
thread = NamedThread thisThread
|
||||||
|
|
||||||
type Handler = ThreadState -> DaemonStatusHandle -> FilePath -> Maybe FileStatus -> IO ()
|
type Handler = ThreadState -> DaemonStatusHandle -> FilePath -> Maybe FileStatus -> IO ()
|
||||||
|
|
||||||
|
|
|
@ -30,9 +30,10 @@ maxTransfers :: Int
|
||||||
maxTransfers = 1
|
maxTransfers = 1
|
||||||
|
|
||||||
{- Dispatches transfers from the queue. -}
|
{- Dispatches transfers from the queue. -}
|
||||||
transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> IO ()
|
transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> NamedThread
|
||||||
transfererThread st dstatus transferqueue slots = go =<< readProgramFile
|
transfererThread st dstatus transferqueue slots = thread $ go =<< readProgramFile
|
||||||
where
|
where
|
||||||
|
thread = NamedThread thisThread
|
||||||
go program = forever $ inTransferSlot dstatus slots $
|
go program = forever $ inTransferSlot dstatus slots $
|
||||||
maybe (return Nothing) (uncurry $ startTransfer st dstatus program)
|
maybe (return Nothing) (uncurry $ startTransfer st dstatus program)
|
||||||
=<< getNextTransfer transferqueue dstatus notrunning
|
=<< getNextTransfer transferqueue dstatus notrunning
|
||||||
|
|
|
@ -56,8 +56,8 @@ needLsof = error $ unlines
|
||||||
, "Be warned: This can corrupt data in the annex, and make fsck complain."
|
, "Be warned: This can corrupt data in the annex, and make fsck complain."
|
||||||
]
|
]
|
||||||
|
|
||||||
watchThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO ()
|
watchThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> NamedThread
|
||||||
watchThread st dstatus transferqueue changechan = do
|
watchThread st dstatus transferqueue changechan = NamedThread thisThread $ do
|
||||||
void $ watchDir "." ignored hooks startup
|
void $ watchDir "." ignored hooks startup
|
||||||
debug thisThread [ "watching", "."]
|
debug thisThread [ "watching", "."]
|
||||||
where
|
where
|
||||||
|
|
|
@ -50,8 +50,8 @@ webAppThread
|
||||||
-> TransferSlots
|
-> TransferSlots
|
||||||
-> Maybe (IO String)
|
-> Maybe (IO String)
|
||||||
-> Maybe (Url -> FilePath -> IO ())
|
-> Maybe (Url -> FilePath -> IO ())
|
||||||
-> IO ()
|
-> NamedThread
|
||||||
webAppThread mst dstatus scanremotes transferqueue transferslots postfirstrun onstartup = do
|
webAppThread mst dstatus scanremotes transferqueue transferslots postfirstrun onstartup = thread $ do
|
||||||
webapp <- WebApp
|
webapp <- WebApp
|
||||||
<$> pure mst
|
<$> pure mst
|
||||||
<*> pure dstatus
|
<*> pure dstatus
|
||||||
|
@ -72,6 +72,7 @@ webAppThread mst dstatus scanremotes transferqueue transferslots postfirstrun on
|
||||||
Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile
|
Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile
|
||||||
Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)
|
Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)
|
||||||
where
|
where
|
||||||
|
thread = NamedThread thisThread
|
||||||
getreldir Nothing = return Nothing
|
getreldir Nothing = return Nothing
|
||||||
getreldir (Just st) = Just <$>
|
getreldir (Just st) = Just <$>
|
||||||
(relHome =<< absPath
|
(relHome =<< absPath
|
||||||
|
|
|
@ -10,6 +10,7 @@ module Command.WebApp where
|
||||||
import Common.Annex
|
import Common.Annex
|
||||||
import Command
|
import Command
|
||||||
import Assistant
|
import Assistant
|
||||||
|
import Assistant.Common
|
||||||
import Assistant.DaemonStatus
|
import Assistant.DaemonStatus
|
||||||
import Assistant.ScanRemotes
|
import Assistant.ScanRemotes
|
||||||
import Assistant.TransferQueue
|
import Assistant.TransferQueue
|
||||||
|
@ -93,8 +94,9 @@ firstRun = do
|
||||||
transferslots <- newTransferSlots
|
transferslots <- newTransferSlots
|
||||||
v <- newEmptyMVar
|
v <- newEmptyMVar
|
||||||
let callback a = Just $ a v
|
let callback a = Just $ a v
|
||||||
webAppThread Nothing dstatus scanremotes transferqueue transferslots
|
void $ runNamedThread dstatus $
|
||||||
(callback signaler) (callback mainthread)
|
webAppThread Nothing dstatus scanremotes transferqueue transferslots
|
||||||
|
(callback signaler) (callback mainthread)
|
||||||
where
|
where
|
||||||
signaler v = do
|
signaler v = do
|
||||||
putMVar v ""
|
putMVar v ""
|
||||||
|
|
Loading…
Reference in a new issue