UI for enabling special remotes

Now other repositories can configure special remotes, and when their
configuration has propigated out, they'll appear in the webapp's list of
repositories, with a link to enable them.

Added support for enabling rsync special remotes, and directory special
remotes that are on removable drives. However, encrypted directory special
remotes are not supported yet. The removable drive configuator doesn't
support them yet anyway.
This commit is contained in:
Joey Hess 2012-09-13 16:47:44 -04:00
parent df337bb63b
commit 74906ed13f
10 changed files with 253 additions and 89 deletions

View file

@ -19,9 +19,12 @@ import Utility.Yesod
import qualified Remote
import qualified Types.Remote as Remote
import Annex.UUID (getUUID)
import Logs.Remote
import Logs.Trust
import Yesod
import Data.Text (Text)
import qualified Data.Map as M
{- The main configuration screen. -}
getConfigR :: Handler RepHtml
@ -38,26 +41,45 @@ getRepositoriesR :: Handler RepHtml
getRepositoriesR = bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Repositories"
repolist <- lift repoList
repolist <- lift $ repoList False
$(widgetFile "configurators/repositories")
{- A numbered list of known repositories, including the current one. -}
repoList :: Handler [(String, String)]
repoList = do
rs <- filter (not . Remote.readonly) . knownRemotes <$>
(liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
l <- runAnnex [] $ do
u <- getUUID
Remote.prettyListUUIDs $ nub $ u : map Remote.uuid rs
return $ zip counter l
repoList :: Bool -> Handler [(String, String, Maybe (Route WebApp))]
repoList onlyconfigured
| onlyconfigured = list =<< configured
| otherwise = list =<< (++) <$> configured <*> unconfigured
where
configured = do
rs <- filter (not . Remote.readonly) . knownRemotes <$>
(liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
runAnnex [] $ do
u <- getUUID
return $ zip (u : map Remote.uuid rs) (repeat Nothing)
unconfigured = runAnnex [] $ do
m <- readRemoteLog
catMaybes . map (findtype m) . snd
<$> (trustPartition DeadTrusted $ M.keys m)
findtype m u = case M.lookup u m of
Nothing -> Nothing
Just c -> case M.lookup "type" c of
Just "rsync" -> u `enableswith` EnableRsyncR
Just "directory" -> u `enableswith` EnableDirectoryR
_ -> Nothing
u `enableswith` r = Just (u, Just $ r u)
list l = runAnnex [] $ do
let l' = nubBy (\x y -> fst x == fst y) l
zip3
<$> pure counter
<*> Remote.prettyListUUIDs (map fst l')
<*> pure (map snd l')
counter = map show ([1..] :: [Int])
{- An intro message, list of repositories, and nudge to make more. -}
introDisplay :: Text -> Widget
introDisplay ident = do
webapp <- lift getYesod
repolist <- lift repoList
repolist <- lift $ repoList True
let n = length repolist
let numrepos = show n
let notenough = n < enough