hook up syncing toggles

Although I observe that these toggles don't always prevent syncing.
When a transfer scan is active, it will still queue items from the disabled
remote.

Also, transfers from a disabled remote show up as from "unknown", which is
not ideal.
This commit is contained in:
Joey Hess 2012-10-12 12:45:16 -04:00
parent 06831e7754
commit 3f06c883f2
4 changed files with 51 additions and 33 deletions

View file

@ -13,6 +13,7 @@ import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Assistant.WebApp.Utility
import Assistant.WebApp.Configurators.Local
import Assistant.DaemonStatus
import Utility.Yesod
@ -129,13 +130,14 @@ repoList onlyconfigured includehere
<*> pure (map snd l')
counter = map show ([1..] :: [Int])
getEnableSyncR :: UUID -> Handler ()
getEnableSyncR uuid = do
error "TODO"
redirect RepositoriesR
getEnableSyncR = flipSync True
getDisableSyncR :: UUID -> Handler ()
getDisableSyncR uuid = do
error "TODO"
getDisableSyncR = flipSync False
flipSync :: Bool -> UUID -> Handler ()
flipSync enable uuid = do
mremote <- runAnnex undefined $ snd <$> Remote.repoFromUUID uuid
changeSyncable mremote enable
redirect RepositoriesR

View file

@ -16,8 +16,6 @@ import Assistant.WebApp.SideBar
import Assistant.WebApp.Utility
import Utility.Yesod
import qualified Remote
import qualified Remote.List as Remote
import qualified Types.Remote as Remote
import Logs.UUID
import Logs.Group
import Logs.PreferredContent
@ -54,7 +52,8 @@ getRepoConfig uuid r = RepoConfig
maybe (RepoGroupCustom $ unwords $ S.toList groups) RepoGroupStandard
(getStandardGroup groups)
{- Returns Just False if syncing has been disabled, or Just True when enabled. -}
{- Returns Just False if syncing should be disabled, Just True when enabled;
- Nothing when it is not changed. -}
setRepoConfig :: UUID -> Git.Repo -> RepoConfig -> Annex (Maybe Bool)
setRepoConfig uuid r c = do
describeUUID uuid $ T.unpack $ repoDescription c
@ -65,14 +64,9 @@ setRepoConfig uuid r c = do
( return Nothing
, do
syncable <- Config.repoSyncable r
if (syncable /= repoSyncable c)
then do
let key = Config.remoteConfig r "sync"
Config.setConfig key $
if syncable then "false" else "true"
void $ Remote.remoteListRefresh
return $ Just $ repoSyncable c
else return Nothing
return $ if (syncable /= repoSyncable c)
then Just $ repoSyncable c
else Nothing
)
editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
@ -100,29 +94,19 @@ editForm new uuid = bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Configure repository"
(repo, mremote) <- lift $ runAnnex undefined getrepo
(repo, mremote) <- lift $ runAnnex undefined $ Remote.repoFromUUID uuid
curr <- lift $ runAnnex undefined $ getRepoConfig uuid repo
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap $ editRepositoryAForm curr
case result of
FormSuccess input -> lift $ do
r <- runAnnex undefined $
syncchanged <- runAnnex undefined $
setRepoConfig uuid repo input
maybe noop (uncurry changeSyncable) $
(,) <$> mremote <*> r
maybe noop (changeSyncable mremote) syncchanged
redirect RepositoriesR
_ -> showform form enctype curr
where
getrepo = ifM ((==) uuid <$> getUUID)
( (,) <$> gitRepo <*> pure Nothing
, do
remote <- fromMaybe (error "Unknown UUID") . M.lookup uuid
<$> Remote.remoteMap id
return (Remote.repo remote, Just remote)
)
showform form enctype curr = do
let istransfer = repoGroup curr == RepoGroupStandard TransferGroup
let authtoken = webAppFormAuthToken
$(widgetFile "configurators/editrepository")

View file

@ -8,6 +8,7 @@
module Assistant.WebApp.Utility where
import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.DaemonStatus
import Assistant.ThreadedMonad
@ -15,9 +16,12 @@ 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 Yesod
import qualified Data.Map as M
@ -25,9 +29,14 @@ import Control.Concurrent
import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
import System.Posix.Process (getProcessGroupIDOf)
changeSyncable :: Remote -> Bool -> Handler ()
changeSyncable r True = syncRemote r
changeSyncable r False = do
{- 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
webapp <- getYesod
let dstatus = daemonStatus webapp
let st = fromJust $ threadState webapp
@ -41,6 +50,16 @@ changeSyncable r False = do
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

View file

@ -27,6 +27,7 @@ module Remote (
byCost,
prettyPrintUUIDs,
prettyListUUIDs,
repoFromUUID,
remotesWithUUID,
remotesWithoutUUID,
keyLocations,
@ -52,6 +53,7 @@ import Logs.UUID
import Logs.Trust
import Logs.Location
import Remote.List
import qualified Git
{- Map from UUIDs of Remotes to a calculated value. -}
remoteMap :: (Remote -> a) -> Annex (M.Map UUID a)
@ -145,6 +147,17 @@ prettyListUUIDs uuids = do
where
n = finddescription m u
{- Gets the git repo associated with a UUID.
- There's no associated remote when this is the UUID of the local repo. -}
repoFromUUID :: UUID -> Annex (Git.Repo, Maybe Remote)
repoFromUUID u = ifM ((==) u <$> getUUID)
( (,) <$> gitRepo <*> pure Nothing
, do
remote <- fromMaybe (error "Unknown UUID") . M.lookup u
<$> remoteMap id
return (repo remote, Just remote)
)
{- Filters a list of remotes to ones that have the listed uuids. -}
remotesWithUUID :: [Remote] -> [UUID] -> [Remote]
remotesWithUUID rs us = filter (\r -> uuid r `elem` us) rs