webapp: Repository list is now included in the dashboard, and other UI tweaks.

This commit is contained in:
Joey Hess 2013-03-15 00:34:42 -04:00
parent 6c7ce8f193
commit 810a06b771
18 changed files with 77 additions and 108 deletions

View file

@ -29,31 +29,11 @@ getConfigurationR = ifM (inFirstRun)
$(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 }
{- 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
}
getAddRepositoryR :: Handler RepHtml
getAddRepositoryR = page "Add Repository" (Just Configuration) $ do
let repolist = repoListDisplay mainRepoSelector
$(widgetFile "configurators/repositories")
makeMiscRepositories :: Widget
makeMiscRepositories = $(widgetFile "configurators/repositories/misc")

View file

@ -128,7 +128,7 @@ editForm new uuid = page "Configure repository" (Just Configuration) $ do
FormSuccess input -> lift $ do
checkarchivedirectory input
setRepoConfig uuid mremote curr input
redirect RepositoriesR
redirect DashboardR
_ -> showform form enctype curr
where
showform form enctype curr = do

View file

@ -156,6 +156,7 @@ xmppPairEnd inprogress theirjid = pairPage $ do
{ onlyCloud = True
, onlyConfigured = False
, includeHere = False
, nudgeAddMore = False
}
$(widgetFile "configurators/pairing/xmpp/end")
#endif

View file

@ -11,8 +11,8 @@ module Assistant.WebApp.DashBoard where
import Assistant.WebApp.Common
import Assistant.WebApp.Utility
import Assistant.WebApp.RepoList
import Assistant.WebApp.Notifications
import Assistant.WebApp.Configurators
import Assistant.TransferQueue
import Utility.NotificationBroadcaster
import Logs.Transfer
@ -36,12 +36,7 @@ transfersDisplay warnNoScript = do
queued <- lift $ take 10 <$> liftAssistant getTransferQueue
autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
let transfers = simplifyTransfers $ current ++ queued
if null transfers
then ifM (lift $ showIntro <$> getWebAppState)
( introDisplay ident
, $(widgetFile "dashboard/transfers")
)
else $(widgetFile "dashboard/transfers")
$(widgetFile "dashboard/transfers")
where
ident = "transfers"
isrunning info = not $
@ -74,7 +69,9 @@ getTransfersR nid = do
{- The main dashboard. -}
dashboard :: Bool -> Widget
dashboard warnNoScript = do
let content = transfersDisplay warnNoScript
let repolist = repoListDisplay $
mainRepoSelector { nudgeAddMore = True }
let transferlist = transfersDisplay warnNoScript
$(widgetFile "dashboard/main")
getDashboardR :: Handler RepHtml

View file

@ -19,18 +19,16 @@ import Yesod
import Text.Hamlet
import Data.Text (Text)
data NavBarItem = DashBoard | Repositories | Configuration | About
data NavBarItem = DashBoard | 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 = DashboardR
navBarRoute Repositories = RepositoriesR
navBarRoute Configuration = ConfigurationR
navBarRoute About = AboutR

View file

@ -63,7 +63,7 @@ notSyncing (SyncingRepoActions _ _) = False
notSyncing _ = True
{- Called by client to get a list of repos, that refreshes
- when new repos as added.
- when new repos are added.
-
- Returns a div, which will be inserted into the calling page.
-}
@ -73,6 +73,14 @@ getRepoListR (RepoListNotificationId nid reposelector) = do
p <- widgetToPageContent $ repoListDisplay reposelector
hamletToRepHtml $ [hamlet|^{pageBody p}|]
mainRepoSelector :: RepoSelector
mainRepoSelector = RepoSelector
{ onlyCloud = False
, onlyConfigured = False
, includeHere = True
, nudgeAddMore = False
}
repoListDisplay :: RepoSelector -> Widget
repoListDisplay reposelector = do
autoUpdate ident (NotifierRepoListR reposelector) (10 :: Int) (10 :: Int)
@ -82,17 +90,16 @@ repoListDisplay reposelector = do
addScript $ StaticR jquery_ui_sortable_js
repolist <- lift $ repoList reposelector
let addmore = nudgeAddMore reposelector
let nootherrepos = length repolist < 2
$(widgetFile "repolist")
where
ident = "repolist"
-- (num, name, uuid, actions)
type RepoList = [(String, String, UUID, Actions)]
type RepoList = [(String, UUID, Actions)]
{- A numbered list of known repositories,
- with actions that can be taken on them. -}
{- A list of known repositories, with actions that can be taken on them. -}
repoList :: RepoSelector -> Handler RepoList
repoList reposelector
| onlyConfigured reposelector = list =<< configured
@ -149,12 +156,10 @@ repoList reposelector
val iscloud r = Just (iscloud, (u, DisabledRepoActions $ r u))
list l = liftAnnex $ do
let l' = nubBy (\x y -> fst x == fst y) l
l'' <- zip3
<$> pure counter
<*> Remote.prettyListUUIDs (map fst l')
l'' <- zip
<$> Remote.prettyListUUIDs (map fst l')
<*> pure l'
return $ map (\(num, name, (uuid, actions)) -> (num, name, uuid, actions)) l''
counter = map show ([1..] :: [Int])
return $ map (\(name, (uuid, actions)) -> (name, uuid, actions)) l''
getEnableSyncR :: UUID -> Handler ()
getEnableSyncR = flipSync True
@ -166,7 +171,7 @@ flipSync :: Bool -> UUID -> Handler ()
flipSync enable uuid = do
mremote <- liftAnnex $ Remote.remoteFromUUID uuid
changeSyncable mremote enable
redirect RepositoriesR
redirectBack
getRepositoriesReorderR :: Handler ()
getRepositoriesReorderR = do

View file

@ -83,6 +83,7 @@ data RepoSelector = RepoSelector
{ onlyCloud :: Bool
, onlyConfigured :: Bool
, includeHere :: Bool
, nudgeAddMore :: Bool
}
deriving (Read, Show, Eq)

View file

@ -1,8 +1,5 @@
/ DashboardR GET HEAD
/repositories RepositoriesR GET
/repositories/reorder RepositoriesReorderR GET
/noscript NoScriptR GET
/noscript/auto NoScriptAutoR GET
@ -20,6 +17,7 @@
/config/preferences PreferencesR GET
/config/xmpp XMPPR GET
/config/addrepository AddRepositoryR GET
/config/repository/new/first FirstRepositoryR GET
/config/repository/new NewRepositoryR GET
/config/repository/switcher RepositorySwitcherR GET
@ -55,6 +53,8 @@
/config/repository/enable/glacier/#UUID EnableGlacierR GET
/config/repository/enable/webdav/#UUID EnableWebDAVR GET
/config/repository/reorder RepositoriesReorderR GET
/transfers/#NotificationId TransfersR GET
/notifier/transfers NotifierTransfersR GET