mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

split repolist out of configuration, into its own tab (temporarily)

Browse source
This commit is contained in:
Joey Hess 2013-03-12 21:51:03 -04:00
parent 7ea9b887bd
commit 8221c2b4ed
8 changed files with 202 additions and 190 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Assistant/Threads/WebApp.hs
View file

@ -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

173
Assistant/WebApp/Configurators.hs
View file

@ -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

2
Assistant/WebApp/Configurators/Pairing.hs
View file

@ -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

2
Assistant/WebApp/DashBoard.hs
View file

@ -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

8
Assistant/WebApp/Page.hs
View file

@ -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]

187
Assistant/WebApp/RepoList.hs Normal file
View file

@ -0,0 +1,187 @@
{- git-annex assistant webapp repository list
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- 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

4
Assistant/WebApp/routes
View file

@ -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

15
templates/configurators/main.hamlet
View file

@ -2,11 +2,11 @@
<div .row-fluid>
<div .span4>
<h3>
<a href="@{RepositoriesR}">
Manage repositories
<a href="@{PreferencesR}">
Preferences
<p>
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.
<div .span4>
$if xmppconfigured
<h3>
@ -22,10 +22,3 @@
<p>
Keep in touch with remote devices, and with your friends, #
by configuring a jabber account.
<div .span4>
<h3>
<a href="@{PreferencesR}">
Preferences
<p>
Tune the behavior of git-annex, including how many copies #
to retain of each file, and how much disk space it can use.