diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 39b9c95c32..4036c53097 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -16,6 +16,7 @@ import Assistant.WebApp.Types import Assistant.WebApp.DashBoard import Assistant.WebApp.SideBar import Assistant.WebApp.Notifications +import Assistant.WebApp.RepoList import Assistant.WebApp.Configurators import Assistant.WebApp.Configurators.Edit import Assistant.WebApp.Configurators.Local diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index 5aff94b48c..caa153c2af 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -10,23 +10,11 @@ module Assistant.WebApp.Configurators where import Assistant.WebApp.Common -import Assistant.DaemonStatus -import Assistant.WebApp.Notifications -import Assistant.WebApp.Utility import Assistant.WebApp.Configurators.Local -import qualified Annex -import qualified Remote -import qualified Types.Remote as Remote -import Annex.UUID (getUUID) -import Logs.Remote -import Logs.Trust -import qualified Git #ifdef WITH_XMPP import Assistant.XMPP.Client #endif -import qualified Data.Map as M - {- The main configuration screen. -} getConfigurationR :: Handler RepHtml getConfigurationR = ifM (inFirstRun) @@ -39,164 +27,3 @@ getConfigurationR = ifM (inFirstRun) #endif $(widgetFile "configurators/main") ) - -{- An intro message, list of repositories, and nudge to make more. -} -introDisplay :: Text -> Widget -introDisplay ident = do - webapp <- lift getYesod - repolist <- lift $ repoList $ RepoSelector - { onlyCloud = False - , onlyConfigured = True - , includeHere = False - } - let n = length repolist - let numrepos = show n - $(widgetFile "configurators/intro") - lift $ modifyWebAppState $ \s -> s { showIntro = False } - -makeMiscRepositories :: Widget -makeMiscRepositories = $(widgetFile "configurators/repositories/misc") - -makeCloudRepositories :: Bool -> Widget -makeCloudRepositories onlyTransfer = $(widgetFile "configurators/repositories/cloud") - -{- Lists known repositories, followed by options to add more. -} -getRepositoriesR :: Handler RepHtml -getRepositoriesR = page "Repositories" (Just Configuration) $ do - let repolist = repoListDisplay $ RepoSelector - { onlyCloud = False - , onlyConfigured = False - , includeHere = True - } - $(widgetFile "configurators/repositories") - -data Actions - = DisabledRepoActions - { setupRepoLink :: Route WebApp } - | SyncingRepoActions - { setupRepoLink :: Route WebApp - , syncToggleLink :: Route WebApp - } - | NotSyncingRepoActions - { setupRepoLink :: Route WebApp - , syncToggleLink :: Route WebApp - } - -mkSyncingRepoActions :: UUID -> Actions -mkSyncingRepoActions u = SyncingRepoActions - { setupRepoLink = EditRepositoryR u - , syncToggleLink = DisableSyncR u - } - -mkNotSyncingRepoActions :: UUID -> Actions -mkNotSyncingRepoActions u = NotSyncingRepoActions - { setupRepoLink = EditRepositoryR u - , syncToggleLink = EnableSyncR u - } - -needsEnabled :: Actions -> Bool -needsEnabled (DisabledRepoActions _) = True -needsEnabled _ = False - -notSyncing :: Actions -> Bool -notSyncing (SyncingRepoActions _ _) = False -notSyncing _ = True - -{- Called by client to get a list of repos, that refreshes - - when new repos as added. - - - - Returns a div, which will be inserted into the calling page. - -} -getRepoListR :: RepoListNotificationId -> Handler RepHtml -getRepoListR (RepoListNotificationId nid reposelector) = do - waitNotifier getRepoListBroadcaster nid - p <- widgetToPageContent $ repoListDisplay reposelector - hamletToRepHtml $ [hamlet|^{pageBody p}|] - -repoListDisplay :: RepoSelector -> Widget -repoListDisplay reposelector = do - autoUpdate ident (NotifierRepoListR reposelector) (10 :: Int) (10 :: Int) - - repolist <- lift $ repoList reposelector - - $(widgetFile "configurators/repositories/list") - - where - ident = "repolist" - -type RepoList = [(String, String, Actions)] - -{- A numbered list of known repositories, - - with actions that can be taken on them. -} -repoList :: RepoSelector -> Handler RepoList -repoList reposelector - | onlyConfigured reposelector = list =<< configured - | otherwise = list =<< (++) <$> configured <*> rest - where - configured = do - rs <- filter wantedrepo . syncRemotes - <$> liftAssistant getDaemonStatus - liftAnnex $ do - let us = map Remote.uuid rs - let l = zip us $ map mkSyncingRepoActions us - if includeHere reposelector - then do - u <- getUUID - autocommit <- annexAutoCommit <$> Annex.getGitConfig - let hereactions = if autocommit - then mkSyncingRepoActions u - else mkNotSyncingRepoActions u - let here = (u, hereactions) - return $ here : l - else return l - rest = liftAnnex $ do - m <- readRemoteLog - unconfigured <- map snd . catMaybes . filter wantedremote - . map (findinfo m) - <$> (trustExclude DeadTrusted $ M.keys m) - unsyncable <- map Remote.uuid . filter wantedrepo . - filter (not . remoteAnnexSync . Remote.gitconfig) - <$> Remote.enabledRemoteList - return $ zip unsyncable (map mkNotSyncingRepoActions unsyncable) ++ unconfigured - wantedrepo r - | Remote.readonly r = False - | onlyCloud reposelector = Git.repoIsUrl (Remote.repo r) && not (isXMPPRemote r) - | otherwise = True - wantedremote Nothing = False - wantedremote (Just (iscloud, _)) - | onlyCloud reposelector = iscloud - | otherwise = True - findinfo m u = case M.lookup u m of - Nothing -> Nothing - Just c -> case M.lookup "type" c of - Just "rsync" -> val True EnableRsyncR - Just "directory" -> val False EnableDirectoryR -#ifdef WITH_S3 - Just "S3" -> val True EnableS3R -#endif - Just "glacier" -> val True EnableGlacierR -#ifdef WITH_WEBDAV - Just "webdav" -> val True EnableWebDAVR -#endif - _ -> Nothing - where - val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u)) - list l = liftAnnex $ 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]) - -getEnableSyncR :: UUID -> Handler () -getEnableSyncR = flipSync True - -getDisableSyncR :: UUID -> Handler () -getDisableSyncR = flipSync False - -flipSync :: Bool -> UUID -> Handler () -flipSync enable uuid = do - mremote <- liftAnnex $ Remote.remoteFromUUID uuid - changeSyncable mremote enable - redirect RepositoriesR diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index c48163789d..6089ff87db 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -31,7 +31,7 @@ import Assistant.XMPP.Git import Network.Protocol.XMPP import Assistant.Types.NetMessager import Assistant.NetMessager -import Assistant.WebApp.Configurators +import Assistant.WebApp.RepoList import Assistant.WebApp.Configurators.XMPP #endif import Utility.UserInfo diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index d71f240cce..31e1d63d11 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -12,7 +12,7 @@ module Assistant.WebApp.DashBoard where import Assistant.WebApp.Common import Assistant.WebApp.Utility import Assistant.WebApp.Notifications -import Assistant.WebApp.Configurators +import Assistant.WebApp.RepoList import Assistant.TransferQueue import Utility.NotificationBroadcaster import Logs.Transfer diff --git a/Assistant/WebApp/Page.hs b/Assistant/WebApp/Page.hs index 8e6dd1b0af..1d92b048dd 100644 --- a/Assistant/WebApp/Page.hs +++ b/Assistant/WebApp/Page.hs @@ -19,21 +19,23 @@ import Yesod import Text.Hamlet import Data.Text (Text) -data NavBarItem = DashBoard | Configuration | About - deriving (Eq) +data NavBarItem = DashBoard | Repositories | Configuration | About + deriving (Eq, Ord, Enum, Bounded) navBarName :: NavBarItem -> Text navBarName DashBoard = "Dashboard" +navBarName Repositories = "Repositories" navBarName Configuration = "Configuration" navBarName About = "About" navBarRoute :: NavBarItem -> Route WebApp navBarRoute DashBoard = HomeR +navBarRoute Repositories = RepositoriesR navBarRoute Configuration = ConfigurationR navBarRoute About = AboutR defaultNavBar :: [NavBarItem] -defaultNavBar = [DashBoard, Configuration, About] +defaultNavBar = [minBound .. maxBound] firstRunNavBar :: [NavBarItem] firstRunNavBar = [Configuration, About] diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs new file mode 100644 index 0000000000..464f0821d4 --- /dev/null +++ b/Assistant/WebApp/RepoList.hs @@ -0,0 +1,187 @@ +{- git-annex assistant webapp repository list + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes, CPP #-} + +module Assistant.WebApp.RepoList where + +import Assistant.WebApp.Common +import Assistant.DaemonStatus +import Assistant.WebApp.Notifications +import Assistant.WebApp.Utility +import qualified Annex +import qualified Remote +import qualified Types.Remote as Remote +import Annex.UUID (getUUID) +import Logs.Remote +import Logs.Trust +import qualified Git +#ifdef WITH_XMPP +#endif + +import qualified Data.Map as M + +{- An intro message, list of repositories, and nudge to make more. -} +introDisplay :: Text -> Widget +introDisplay ident = do + webapp <- lift getYesod + repolist <- lift $ repoList $ RepoSelector + { onlyCloud = False + , onlyConfigured = True + , includeHere = False + } + let n = length repolist + let numrepos = show n + $(widgetFile "configurators/intro") + lift $ modifyWebAppState $ \s -> s { showIntro = False } + +makeMiscRepositories :: Widget +makeMiscRepositories = $(widgetFile "configurators/repositories/misc") + +makeCloudRepositories :: Bool -> Widget +makeCloudRepositories onlyTransfer = $(widgetFile "configurators/repositories/cloud") + +{- Lists known repositories, followed by options to add more. -} +getRepositoriesR :: Handler RepHtml +getRepositoriesR = page "Repositories" (Just Repositories) $ do + let repolist = repoListDisplay $ RepoSelector + { onlyCloud = False + , onlyConfigured = False + , includeHere = True + } + $(widgetFile "configurators/repositories") + +data Actions + = DisabledRepoActions + { setupRepoLink :: Route WebApp } + | SyncingRepoActions + { setupRepoLink :: Route WebApp + , syncToggleLink :: Route WebApp + } + | NotSyncingRepoActions + { setupRepoLink :: Route WebApp + , syncToggleLink :: Route WebApp + } + +mkSyncingRepoActions :: UUID -> Actions +mkSyncingRepoActions u = SyncingRepoActions + { setupRepoLink = EditRepositoryR u + , syncToggleLink = DisableSyncR u + } + +mkNotSyncingRepoActions :: UUID -> Actions +mkNotSyncingRepoActions u = NotSyncingRepoActions + { setupRepoLink = EditRepositoryR u + , syncToggleLink = EnableSyncR u + } + +needsEnabled :: Actions -> Bool +needsEnabled (DisabledRepoActions _) = True +needsEnabled _ = False + +notSyncing :: Actions -> Bool +notSyncing (SyncingRepoActions _ _) = False +notSyncing _ = True + +{- Called by client to get a list of repos, that refreshes + - when new repos as added. + - + - Returns a div, which will be inserted into the calling page. + -} +getRepoListR :: RepoListNotificationId -> Handler RepHtml +getRepoListR (RepoListNotificationId nid reposelector) = do + waitNotifier getRepoListBroadcaster nid + p <- widgetToPageContent $ repoListDisplay reposelector + hamletToRepHtml $ [hamlet|^{pageBody p}|] + +repoListDisplay :: RepoSelector -> Widget +repoListDisplay reposelector = do + autoUpdate ident (NotifierRepoListR reposelector) (10 :: Int) (10 :: Int) + + repolist <- lift $ repoList reposelector + + $(widgetFile "configurators/repositories/list") + + where + ident = "repolist" + +type RepoList = [(String, String, Actions)] + +{- A numbered list of known repositories, + - with actions that can be taken on them. -} +repoList :: RepoSelector -> Handler RepoList +repoList reposelector + | onlyConfigured reposelector = list =<< configured + | otherwise = list =<< (++) <$> configured <*> rest + where + configured = do + rs <- filter wantedrepo . syncRemotes + <$> liftAssistant getDaemonStatus + liftAnnex $ do + let us = map Remote.uuid rs + let l = zip us $ map mkSyncingRepoActions us + if includeHere reposelector + then do + u <- getUUID + autocommit <- annexAutoCommit <$> Annex.getGitConfig + let hereactions = if autocommit + then mkSyncingRepoActions u + else mkNotSyncingRepoActions u + let here = (u, hereactions) + return $ here : l + else return l + rest = liftAnnex $ do + m <- readRemoteLog + unconfigured <- map snd . catMaybes . filter wantedremote + . map (findinfo m) + <$> (trustExclude DeadTrusted $ M.keys m) + unsyncable <- map Remote.uuid . filter wantedrepo . + filter (not . remoteAnnexSync . Remote.gitconfig) + <$> Remote.enabledRemoteList + return $ zip unsyncable (map mkNotSyncingRepoActions unsyncable) ++ unconfigured + wantedrepo r + | Remote.readonly r = False + | onlyCloud reposelector = Git.repoIsUrl (Remote.repo r) && not (isXMPPRemote r) + | otherwise = True + wantedremote Nothing = False + wantedremote (Just (iscloud, _)) + | onlyCloud reposelector = iscloud + | otherwise = True + findinfo m u = case M.lookup u m of + Nothing -> Nothing + Just c -> case M.lookup "type" c of + Just "rsync" -> val True EnableRsyncR + Just "directory" -> val False EnableDirectoryR +#ifdef WITH_S3 + Just "S3" -> val True EnableS3R +#endif + Just "glacier" -> val True EnableGlacierR +#ifdef WITH_WEBDAV + Just "webdav" -> val True EnableWebDAVR +#endif + _ -> Nothing + where + val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u)) + list l = liftAnnex $ 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]) + +getEnableSyncR :: UUID -> Handler () +getEnableSyncR = flipSync True + +getDisableSyncR :: UUID -> Handler () +getDisableSyncR = flipSync False + +flipSync :: Bool -> UUID -> Handler () +flipSync enable uuid = do + mremote <- liftAnnex $ Remote.remoteFromUUID uuid + changeSyncable mremote enable + redirect RepositoriesR diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index e258966971..7a03387000 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -1,6 +1,9 @@ / HomeR GET HEAD +/repositories RepositoriesR GET + /noscript NoScriptR GET /noscript/auto NoScriptAutoR GET + /about AboutR GET /about/license LicenseR GET /about/repogroups RepoGroupR GET @@ -12,7 +15,6 @@ /log LogR GET /config ConfigurationR GET -/config/repository RepositoriesR GET /config/preferences PreferencesR GET /config/xmpp XMPPR GET diff --git a/templates/configurators/main.hamlet b/templates/configurators/main.hamlet index 29cf3ce4fb..b196358895 100644 --- a/templates/configurators/main.hamlet +++ b/templates/configurators/main.hamlet @@ -2,11 +2,11 @@

- - Manage repositories + + Preferences

- Distribute the files in this repository to other devices, # - make backups, and more, by adding repositories. + Tune the behavior of git-annex, including how many copies # + to retain of each file, and how much disk space it can use.

$if xmppconfigured

@@ -22,10 +22,3 @@

Keep in touch with remote devices, and with your friends, # by configuring a jabber account. -