allow disabling syncing to a repo on its edit form

This is not quite right yet, since it disables it so hard it doesn't show
up in the repo list anymore!
This commit is contained in:
Joey Hess 2012-10-11 17:14:42 -04:00
parent 80b3952930
commit 5b9900133c
4 changed files with 62 additions and 9 deletions

View file

@ -13,12 +13,22 @@ import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Assistant.WebApp.Configurators.Local (syncRemote)
import Assistant.WebApp.DashBoard (cancelTransfer)
import Assistant.DaemonStatus
import Assistant.TransferQueue
import Assistant.ThreadedMonad
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
import Logs.Transfer
import Types.StandardGroups
import Config
import Annex.UUID
import Yesod
import Data.Text (Text)
@ -32,31 +42,69 @@ data RepoGroup = RepoGroupCustom String | RepoGroupStandard StandardGroup
data RepoConfig = RepoConfig
{ repoDescription :: Text
, repoGroup :: RepoGroup
, repoEnabled :: Bool
}
deriving (Show)
getRepoConfig :: UUID -> Annex RepoConfig
getRepoConfig uuid = RepoConfig
getRepoConfig :: Remote -> Annex RepoConfig
getRepoConfig r = RepoConfig
<$> (T.pack . fromMaybe "" . M.lookup uuid <$> uuidMap)
<*> getrepogroup
<*> (thisrepo <||> (elem r <$> Remote.enabledRemoteList))
where
getrepogroup = do
groups <- lookupGroups uuid
return $
maybe (RepoGroupCustom $ unwords $ S.toList groups) RepoGroupStandard
(getStandardGroup groups)
thisrepo = (==) uuid <$> getUUID
uuid = Remote.uuid r
setRepoConfig :: UUID -> RepoConfig -> Annex ()
setRepoConfig uuid c = do
{- Returns Just False if the repository has been disabled,
- or Just True when enabled. -}
setRepoConfig :: Remote -> RepoConfig -> Annex (Maybe Bool)
setRepoConfig r c = do
describeUUID uuid $ T.unpack $ repoDescription c
case repoGroup c of
RepoGroupStandard g -> setStandardGroup uuid g
RepoGroupCustom s -> groupSet uuid $ S.fromList $ words s
ifM ((==) uuid <$> getUUID)
( return Nothing
, do
enabled <- elem r <$> Remote.enabledRemoteList
if (enabled /= repoEnabled c)
then do
setConfig annex_ignore $
if enabled then "true" else "false"
void $ Remote.remoteListRefresh
return $ Just $ repoEnabled c
else return Nothing
)
where
uuid = Remote.uuid r
annex_ignore = remoteConfig (Remote.repo r) "ignore"
changeEnabled :: Remote -> Bool -> Handler ()
changeEnabled r True = syncRemote r
changeEnabled r False = do
webapp <- getYesod
let dstatus = daemonStatus webapp
let st = fromJust $ threadState webapp
liftIO $ runThreadState st $ updateKnownRemotes dstatus
{- Stop all transfers to or from this disabled remote.
- XXX Can't stop any ongoing scan, or git syncs. -}
void $ liftIO $ dequeueTransfers (transferQueue webapp) dstatus tofrom
mapM_ (cancelTransfer False) =<<
filter tofrom . M.keys <$>
liftIO (currentTransfers <$> getDaemonStatus dstatus)
where
tofrom t = transferUUID t == Remote.uuid r
editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
editRepositoryAForm def = RepoConfig
<$> areq textField "Description" (Just $ repoDescription def)
<*> areq (selectFieldList $ customgroups++standardgroups) "Repository group" (Just $ repoGroup def)
<*> areq checkBoxField "Syncing enabled" (Just $ repoEnabled def)
where
standardgroups :: [(Text, RepoGroup)]
standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g))
@ -70,13 +118,16 @@ getEditRepositoryR :: UUID -> Handler RepHtml
getEditRepositoryR uuid = bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Configure repository"
curr <- lift $ runAnnex undefined $ getRepoConfig uuid
r <- lift $ fromMaybe (error "Unknown UUID") . M.lookup uuid
<$> runAnnex M.empty (Remote.remoteMap id)
curr <- lift $ runAnnex undefined $ getRepoConfig r
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap $ editRepositoryAForm curr
case result of
FormSuccess input -> lift $ do
runAnnex undefined $ setRepoConfig uuid input
maybe noop (changeEnabled r) =<<
runAnnex undefined (setRepoConfig r input)
redirect RepositoriesR
_ -> showform form enctype
where

View file

@ -166,7 +166,7 @@ postCancelTransferR t = cancelTransfer False t
pauseTransfer :: Transfer -> Handler ()
pauseTransfer = cancelTransfer True
cancelTransfer :: Bool -> Transfer-> Handler ()
cancelTransfer :: Bool -> Transfer -> Handler ()
cancelTransfer pause t = do
webapp <- getYesod
let dstatus = daemonStatus webapp

2
debian/changelog vendored
View file

@ -9,6 +9,8 @@ git-annex (3.20121010) UNRELEASED; urgency=low
* Makefile: Avoid building with -threaded if the ghc threaded runtime does
not exist.
* webapp: Improve wording of intro display. Closes: #689848
* webapp: Repositories can now be configured, to change their description,
their group, or even to disable syncing to them.
-- Joey Hess <joeyh@debian.org> Wed, 10 Oct 2012 12:59:25 -0400

View file

@ -1,6 +1,6 @@
<div .span9 .hero-unit>
<h2>
Configuring #{description}
Configuring repository: #{description}
<p>
<form .form-horizontal enctype=#{enctype}>
<fieldset>