d83a244986
Improved probing the remote server, so it gathers a list of the capabilities it has. From that list, we can determine which types of remotes are supported, and display an appropriate UI. The new buttons for making gcrypt repos don't work yet, but the old buttons for unencrypted git repo and encrypted rsync repo have been adapted to the new data types and are working. This commit was sponsored by David Schmitt.
138 lines
4.5 KiB
Haskell
138 lines
4.5 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.Types
|
|
import Assistant.DaemonStatus
|
|
import Assistant.TransferQueue
|
|
import Assistant.Types.TransferSlots
|
|
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 qualified Config
|
|
import Config.Cost
|
|
import Config.Files
|
|
import Git.Config
|
|
import Assistant.Threads.Watcher
|
|
import Assistant.NamedThread
|
|
import Types.StandardGroups
|
|
import Git.Remote
|
|
import Logs.PreferredContent
|
|
import Assistant.MakeRemote
|
|
|
|
import qualified Data.Map as M
|
|
import Control.Concurrent
|
|
import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
|
|
import System.Posix.Process (getProcessGroupIDOf)
|
|
import Utility.Yesod
|
|
|
|
{- Use Nothing to change autocommit setting; or a remote to change
|
|
- its sync setting. -}
|
|
changeSyncable :: (Maybe Remote) -> Bool -> Handler ()
|
|
changeSyncable Nothing enable = do
|
|
liftAnnex $ Config.setConfig key (boolConfig enable)
|
|
liftIO . maybe noop (`throwTo` signal)
|
|
=<< liftAssistant (namedThreadId watchThread)
|
|
where
|
|
key = Config.annexConfig "autocommit"
|
|
signal
|
|
| enable = ResumeWatcher
|
|
| otherwise = PauseWatcher
|
|
changeSyncable (Just r) True = do
|
|
changeSyncFlag r True
|
|
liftAssistant $ syncRemote r
|
|
changeSyncable (Just r) False = do
|
|
changeSyncFlag r False
|
|
liftAssistant $ updateSyncRemotes
|
|
{- Stop all transfers to or from this remote.
|
|
- XXX Can't stop any ongoing scan, or git syncs. -}
|
|
void $ liftAssistant $ dequeueTransfers tofrom
|
|
mapM_ (cancelTransfer False) =<<
|
|
filter tofrom . M.keys <$>
|
|
liftAssistant (currentTransfers <$> getDaemonStatus)
|
|
where
|
|
tofrom t = transferUUID t == Remote.uuid r
|
|
|
|
changeSyncFlag :: Remote -> Bool -> Handler ()
|
|
changeSyncFlag r enabled = liftAnnex $ do
|
|
Config.setConfig key (boolConfig enabled)
|
|
void $ Remote.remoteListRefresh
|
|
where
|
|
key = Config.remoteConfig (Remote.repo r) "sync"
|
|
|
|
pauseTransfer :: Transfer -> Handler ()
|
|
pauseTransfer = cancelTransfer True
|
|
|
|
cancelTransfer :: Bool -> Transfer -> Handler ()
|
|
cancelTransfer pause t = do
|
|
m <- getCurrentTransfers
|
|
unless pause $
|
|
{- remove queued transfer -}
|
|
void $ liftAssistant $ dequeueTransfers $ equivilantTransfer t
|
|
{- stop running transfer -}
|
|
maybe noop stop (M.lookup t m)
|
|
where
|
|
stop info = liftAssistant $ 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. -}
|
|
liftIO $ maybe noop signalthread $ transferTid info
|
|
liftIO $ maybe noop killproc $ transferPid info
|
|
if pause
|
|
then void $ alterTransferInfo t $
|
|
\i -> i { transferPaused = True }
|
|
else void $ removeTransfer 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 = void $ tryIO $ 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
|
|
is <- liftAssistant $ map snd <$> getMatchingTransfers (== t)
|
|
maybe noop start $ headMaybe is
|
|
resume tid = do
|
|
liftAssistant $ alterTransferInfo t $
|
|
\i -> i { transferPaused = False }
|
|
liftIO $ throwTo tid ResumeTransfer
|
|
start info = liftAssistant $ do
|
|
program <- liftIO readProgramFile
|
|
inImmediateTransferSlot program $
|
|
Transferrer.genTransfer t info
|
|
|
|
getCurrentTransfers :: Handler TransferMap
|
|
getCurrentTransfers = currentTransfers <$> liftAssistant getDaemonStatus
|
|
|
|
{- Runs an action that creates or enables a cloud remote,
|
|
- and finishes setting it up, then starts syncing with it,
|
|
- and finishes by displaying the page to edit it. -}
|
|
setupCloudRemote :: StandardGroup -> Maybe Cost -> Annex RemoteName -> Handler a
|
|
setupCloudRemote defaultgroup mcost maker = do
|
|
r <- liftAnnex $ addRemote maker
|
|
liftAnnex $ do
|
|
setStandardGroup (Remote.uuid r) defaultgroup
|
|
maybe noop (Config.setRemoteCost r) mcost
|
|
liftAssistant $ syncRemote r
|
|
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
|