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:
parent
80b3952930
commit
5b9900133c
4 changed files with 62 additions and 9 deletions
|
@ -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
|
||||
|
|
|
@ -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
2
debian/changelog
vendored
|
@ -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
|
||||
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
<div .span9 .hero-unit>
|
||||
<h2>
|
||||
Configuring #{description}
|
||||
Configuring repository: #{description}
|
||||
<p>
|
||||
<form .form-horizontal enctype=#{enctype}>
|
||||
<fieldset>
|
||||
|
|
Loading…
Add table
Reference in a new issue