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:
parent
06831e7754
commit
3f06c883f2
4 changed files with 51 additions and 33 deletions
|
@ -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
|
||||
|
|
|
@ -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")
|
||||
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
13
Remote.hs
13
Remote.hs
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue