set/unset annex-sync, rather than annex-ignore

This reserves annex.ignore for repos that should not be visible at all;
repos with syncing disabled are now skipped by the assistant, but are
displayed in the list and can be configured.
This commit is contained in:
Joey Hess 2012-10-11 19:22:29 -04:00
parent 2602c8f877
commit 0b266f970f
4 changed files with 43 additions and 26 deletions

View file

@ -17,6 +17,8 @@ import Utility.NotificationBroadcaster
import Logs.Transfer import Logs.Transfer
import Logs.Trust import Logs.Trust
import qualified Remote import qualified Remote
import qualified Types.Remote as Remote
import Config
import Control.Concurrent.STM import Control.Concurrent.STM
import System.Posix.Types import System.Posix.Types
@ -86,10 +88,11 @@ modifyDaemonStatus dstatus a = do
sendNotification $ changeNotifier s sendNotification $ changeNotifier s
return b return b
{- Remotes ordered by cost, with dead ones thrown out. -} {- Syncable remotes ordered by cost. -}
calcKnownRemotes :: Annex [Remote] calcKnownRemotes :: Annex [Remote]
calcKnownRemotes = do calcKnownRemotes = do
rs <- concat . Remote.byCost <$> Remote.enabledRemoteList rs <- filterM (repoSyncable . Remote.repo) =<<
concat . Remote.byCost <$> Remote.enabledRemoteList
alive <- snd <$> trustPartition DeadTrusted (map Remote.uuid rs) alive <- snd <$> trustPartition DeadTrusted (map Remote.uuid rs)
let good r = Remote.uuid r `elem` alive let good r = Remote.uuid r `elem` alive
return $ filter good rs return $ filter good rs

View file

@ -21,6 +21,7 @@ import qualified Types.Remote as Remote
import Annex.UUID (getUUID) import Annex.UUID (getUUID)
import Logs.Remote import Logs.Remote
import Logs.Trust import Logs.Trust
import Config
import Yesod import Yesod
import Data.Text (Text) import Data.Text (Text)
@ -44,21 +45,29 @@ getRepositoriesR = bootstrap (Just Config) $ do
repolist <- lift $ repoList False True repolist <- lift $ repoList False True
$(widgetFile "configurators/repositories") $(widgetFile "configurators/repositories")
data SetupRepo = EnableRepo (Route WebApp) | EditRepo (Route WebApp) data SetupRepo =
EnableRepo (Route WebApp) |
EditRepo (Route WebApp) |
EnableSyncRepo (Route WebApp)
needsEnabled :: SetupRepo -> Bool needsEnabled :: SetupRepo -> Bool
needsEnabled (EnableRepo _) = True needsEnabled (EnableRepo _) = True
needsEnabled _ = False needsEnabled _ = False
notSyncing :: SetupRepo -> Bool
notSyncing (EnableSyncRepo _) = True
notSyncing _ = False
setupRepoLink :: SetupRepo -> Route WebApp setupRepoLink :: SetupRepo -> Route WebApp
setupRepoLink (EnableRepo r) = r setupRepoLink (EnableRepo r) = r
setupRepoLink (EditRepo r) = r setupRepoLink (EditRepo r) = r
setupRepoLink (EnableSyncRepo r) = r
{- A numbered list of known repositories. -} {- A numbered list of known repositories. -}
repoList :: Bool -> Bool -> Handler [(String, String, SetupRepo)] repoList :: Bool -> Bool -> Handler [(String, String, SetupRepo)]
repoList onlyconfigured includehere repoList onlyconfigured includehere
| onlyconfigured = list =<< configured | onlyconfigured = list =<< configured
| otherwise = list =<< (++) <$> configured <*> unconfigured | otherwise = list =<< (++) <$> configured <*> rest
where where
configured = do configured = do
rs <- filter (not . Remote.readonly) . knownRemotes <$> rs <- filter (not . Remote.readonly) . knownRemotes <$>
@ -67,12 +76,16 @@ repoList onlyconfigured includehere
u <- getUUID u <- getUUID
let l = map Remote.uuid rs let l = map Remote.uuid rs
let l' = if includehere then u : l else l let l' = if includehere then u : l else l
return $ zip l' (map editlink l') return $ withlinks (EditRepo . EditRepositoryR) l'
editlink = EditRepo . EditRepositoryR withlinks mklink l = zip l (map mklink l)
unconfigured = runAnnex [] $ do rest = runAnnex [] $ do
m <- readRemoteLog m <- readRemoteLog
catMaybes . map (findtype m) . snd unconfigured <- catMaybes . map (findtype m) . snd
<$> (trustPartition DeadTrusted $ M.keys m) <$> (trustPartition DeadTrusted $ M.keys m)
unsyncable <- withlinks (EnableSyncRepo . EditRepositoryR) . map Remote.uuid <$>
(filterM (\r -> not <$> repoSyncable (Remote.repo r))
=<< Remote.enabledRemoteList)
return $ unsyncable ++ unconfigured
findtype m u = case M.lookup u m of findtype m u = case M.lookup u m of
Nothing -> Nothing Nothing -> Nothing
Just c -> case M.lookup "type" c of Just c -> case M.lookup "type" c of

View file

@ -27,7 +27,7 @@ import Logs.Group
import Logs.PreferredContent import Logs.PreferredContent
import Logs.Transfer import Logs.Transfer
import Types.StandardGroups import Types.StandardGroups
import Config import qualified Config
import Annex.UUID import Annex.UUID
import Yesod import Yesod
@ -42,7 +42,7 @@ data RepoGroup = RepoGroupCustom String | RepoGroupStandard StandardGroup
data RepoConfig = RepoConfig data RepoConfig = RepoConfig
{ repoDescription :: Text { repoDescription :: Text
, repoGroup :: RepoGroup , repoGroup :: RepoGroup
, repoEnabled :: Bool , repoSyncable :: Bool
} }
deriving (Show) deriving (Show)
@ -50,18 +50,16 @@ getRepoConfig :: Remote -> Annex RepoConfig
getRepoConfig r = RepoConfig getRepoConfig r = RepoConfig
<$> (T.pack . fromMaybe "" . M.lookup uuid <$> uuidMap) <$> (T.pack . fromMaybe "" . M.lookup uuid <$> uuidMap)
<*> getrepogroup <*> getrepogroup
<*> (thisrepo <||> (elem r <$> Remote.enabledRemoteList)) <*> Config.repoSyncable (Remote.repo r)
where where
getrepogroup = do getrepogroup = do
groups <- lookupGroups uuid groups <- lookupGroups uuid
return $ return $
maybe (RepoGroupCustom $ unwords $ S.toList groups) RepoGroupStandard maybe (RepoGroupCustom $ unwords $ S.toList groups) RepoGroupStandard
(getStandardGroup groups) (getStandardGroup groups)
thisrepo = (==) uuid <$> getUUID
uuid = Remote.uuid r uuid = Remote.uuid r
{- Returns Just False if the repository has been disabled, {- Returns Just False if syncing has been disabled, or Just True when enabled. -}
- or Just True when enabled. -}
setRepoConfig :: Remote -> RepoConfig -> Annex (Maybe Bool) setRepoConfig :: Remote -> RepoConfig -> Annex (Maybe Bool)
setRepoConfig r c = do setRepoConfig r c = do
describeUUID uuid $ T.unpack $ repoDescription c describeUUID uuid $ T.unpack $ repoDescription c
@ -71,27 +69,27 @@ setRepoConfig r c = do
ifM ((==) uuid <$> getUUID) ifM ((==) uuid <$> getUUID)
( return Nothing ( return Nothing
, do , do
enabled <- elem r <$> Remote.enabledRemoteList syncable <- Config.repoSyncable $ Remote.repo r
if (enabled /= repoEnabled c) if (syncable /= repoSyncable c)
then do then do
setConfig annex_ignore $ let key = Config.remoteConfig (Remote.repo r) "sync"
if enabled then "true" else "false" Config.setConfig key $
if syncable then "false" else "true"
void $ Remote.remoteListRefresh void $ Remote.remoteListRefresh
return $ Just $ repoEnabled c return $ Just $ repoSyncable c
else return Nothing else return Nothing
) )
where where
uuid = Remote.uuid r uuid = Remote.uuid r
annex_ignore = remoteConfig (Remote.repo r) "ignore"
changeEnabled :: Remote -> Bool -> Handler () changeSyncable :: Remote -> Bool -> Handler ()
changeEnabled r True = syncRemote r changeSyncable r True = syncRemote r
changeEnabled r False = do changeSyncable r False = do
webapp <- getYesod webapp <- getYesod
let dstatus = daemonStatus webapp let dstatus = daemonStatus webapp
let st = fromJust $ threadState webapp let st = fromJust $ threadState webapp
liftIO $ runThreadState st $ updateKnownRemotes dstatus liftIO $ runThreadState st $ updateKnownRemotes dstatus
{- Stop all transfers to or from this disabled remote. {- Stop all transfers to or from this remote.
- XXX Can't stop any ongoing scan, or git syncs. -} - XXX Can't stop any ongoing scan, or git syncs. -}
void $ liftIO $ dequeueTransfers (transferQueue webapp) dstatus tofrom void $ liftIO $ dequeueTransfers (transferQueue webapp) dstatus tofrom
mapM_ (cancelTransfer False) =<< mapM_ (cancelTransfer False) =<<
@ -104,7 +102,7 @@ editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
editRepositoryAForm def = RepoConfig editRepositoryAForm def = RepoConfig
<$> areq textField "Description" (Just $ repoDescription def) <$> areq textField "Description" (Just $ repoDescription def)
<*> areq (selectFieldList $ customgroups++standardgroups) "Repository group" (Just $ repoGroup def) <*> areq (selectFieldList $ customgroups++standardgroups) "Repository group" (Just $ repoGroup def)
<*> areq checkBoxField "Syncing enabled" (Just $ repoEnabled def) <*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def)
where where
standardgroups :: [(Text, RepoGroup)] standardgroups :: [(Text, RepoGroup)]
standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g)) standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g))
@ -132,7 +130,7 @@ editForm new uuid = bootstrap (Just Config) $ do
runFormGet $ renderBootstrap $ editRepositoryAForm curr runFormGet $ renderBootstrap $ editRepositoryAForm curr
case result of case result of
FormSuccess input -> lift $ do FormSuccess input -> lift $ do
maybe noop (changeEnabled r) =<< maybe noop (changeSyncable r) =<<
runAnnex undefined (setRepoConfig r input) runAnnex undefined (setRepoConfig r input)
redirect RepositoriesR redirect RepositoriesR
_ -> showform form enctype curr _ -> showform form enctype curr

View file

@ -19,6 +19,9 @@
<a href="@{setupRepoLink setuprepo}"> <a href="@{setupRepoLink setuprepo}">
enable enable
$else $else
$if notSyncing setuprepo
<i>syncing disabled #
&rarr; #
<a href="@{setupRepoLink setuprepo}"> <a href="@{setupRepoLink setuprepo}">
configure configure
<div .row-fluid> <div .row-fluid>