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.
142 lines
4.4 KiB
Haskell
142 lines
4.4 KiB
Haskell
{- git-annex assistant webapp utilities
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.WebApp.Utility where
|
|
|
|
import Assistant.Common
|
|
import Assistant.WebApp
|
|
import Assistant.WebApp.Types
|
|
import Assistant.DaemonStatus
|
|
import Assistant.ThreadedMonad
|
|
import Assistant.TransferQueue
|
|
import Assistant.TransferSlots
|
|
import Assistant.Sync
|
|
import qualified Remote
|
|
import qualified Types.Remote as Remote
|
|
import qualified Remote.List as Remote
|
|
import qualified Assistant.Threads.Transferrer as Transferrer
|
|
import Logs.Transfer
|
|
import Locations.UserConfig
|
|
import qualified Config
|
|
|
|
import qualified Data.Map as M
|
|
import Control.Concurrent
|
|
import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
|
|
import System.Posix.Process (getProcessGroupIDOf)
|
|
|
|
{- Use Nothing to change global sync setting. -}
|
|
changeSyncable :: (Maybe Remote) -> Bool -> Handler ()
|
|
changeSyncable Nothing _ = noop -- TODO
|
|
changeSyncable (Just r) True = do
|
|
changeSyncFlag r True
|
|
syncRemote r
|
|
changeSyncable (Just r) False = do
|
|
changeSyncFlag r False
|
|
d <- getAssistantY id
|
|
let dstatus = daemonStatusHandle d
|
|
let st = threadState d
|
|
liftIO $ runThreadState st $ updateSyncRemotes dstatus
|
|
{- Stop all transfers to or from this remote.
|
|
- XXX Can't stop any ongoing scan, or git syncs. -}
|
|
void $ liftIO $ dequeueTransfers (transferQueue d) dstatus tofrom
|
|
mapM_ (cancelTransfer False) =<<
|
|
filter tofrom . M.keys <$>
|
|
liftIO (currentTransfers <$> getDaemonStatus dstatus)
|
|
where
|
|
tofrom t = transferUUID t == Remote.uuid r
|
|
|
|
changeSyncFlag :: Remote -> Bool -> Handler ()
|
|
changeSyncFlag r enabled = runAnnex undefined $ do
|
|
Config.setConfig key value
|
|
void $ Remote.remoteListRefresh
|
|
where
|
|
key = Config.remoteConfig (Remote.repo r) "sync"
|
|
value
|
|
| enabled = "true"
|
|
| otherwise = "false"
|
|
|
|
{- Start syncing remote, using a background thread. -}
|
|
syncRemote :: Remote -> Handler ()
|
|
syncRemote remote = do
|
|
d <- getAssistantY id
|
|
liftIO $ syncNewRemote
|
|
(threadState d)
|
|
(daemonStatusHandle d)
|
|
(scanRemoteMap d)
|
|
remote
|
|
|
|
pauseTransfer :: Transfer -> Handler ()
|
|
pauseTransfer = cancelTransfer True
|
|
|
|
cancelTransfer :: Bool -> Transfer -> Handler ()
|
|
cancelTransfer pause t = do
|
|
dstatus <- getAssistantY daemonStatusHandle
|
|
tq <- getAssistantY transferQueue
|
|
m <- getCurrentTransfers
|
|
liftIO $ do
|
|
unless pause $
|
|
{- remove queued transfer -}
|
|
void $ dequeueTransfers tq dstatus $
|
|
equivilantTransfer t
|
|
{- stop running transfer -}
|
|
maybe noop (stop dstatus) (M.lookup t m)
|
|
where
|
|
stop dstatus info = do
|
|
{- When there's a thread associated with the
|
|
- transfer, it's signaled first, to avoid it
|
|
- displaying any alert about the transfer having
|
|
- failed when the transfer process is killed. -}
|
|
maybe noop signalthread $ transferTid info
|
|
maybe noop killproc $ transferPid info
|
|
if pause
|
|
then void $
|
|
alterTransferInfo t
|
|
(\i -> i { transferPaused = True })
|
|
dstatus
|
|
else void $
|
|
removeTransfer dstatus t
|
|
signalthread tid
|
|
| pause = throwTo tid PauseTransfer
|
|
| otherwise = killThread tid
|
|
{- In order to stop helper processes like rsync,
|
|
- kill the whole process group of the process running the
|
|
- transfer. -}
|
|
killproc pid = do
|
|
g <- getProcessGroupIDOf pid
|
|
void $ tryIO $ signalProcessGroup sigTERM g
|
|
threadDelay 50000 -- 0.05 second grace period
|
|
void $ tryIO $ signalProcessGroup sigKILL g
|
|
|
|
startTransfer :: Transfer -> Handler ()
|
|
startTransfer t = do
|
|
m <- getCurrentTransfers
|
|
maybe startqueued go (M.lookup t m)
|
|
where
|
|
go info = maybe (start info) resume $ transferTid info
|
|
startqueued = do
|
|
dstatus <- getAssistantY daemonStatusHandle
|
|
q <- getAssistantY transferQueue
|
|
is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t)
|
|
maybe noop start $ headMaybe is
|
|
resume tid = do
|
|
dstatus <- getAssistantY daemonStatusHandle
|
|
liftIO $ do
|
|
alterTransferInfo t
|
|
(\i -> i { transferPaused = False })
|
|
dstatus
|
|
throwTo tid ResumeTransfer
|
|
start info = do
|
|
st <- getAssistantY threadState
|
|
dstatus <- getAssistantY daemonStatusHandle
|
|
slots <- getAssistantY transferSlots
|
|
commitchan <- getAssistantY commitChan
|
|
liftIO $ inImmediateTransferSlot dstatus slots $ do
|
|
program <- readProgramFile
|
|
Transferrer.startTransfer st dstatus commitchan program t info
|
|
|
|
getCurrentTransfers :: Handler TransferMap
|
|
getCurrentTransfers = currentTransfers <$> getDaemonStatusY
|