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:
parent
2602c8f877
commit
0b266f970f
4 changed files with 43 additions and 26 deletions
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -19,6 +19,9 @@
|
||||||
<a href="@{setupRepoLink setuprepo}">
|
<a href="@{setupRepoLink setuprepo}">
|
||||||
enable
|
enable
|
||||||
$else
|
$else
|
||||||
|
$if notSyncing setuprepo
|
||||||
|
<i>syncing disabled #
|
||||||
|
→ #
|
||||||
<a href="@{setupRepoLink setuprepo}">
|
<a href="@{setupRepoLink setuprepo}">
|
||||||
configure
|
configure
|
||||||
<div .row-fluid>
|
<div .row-fluid>
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue