summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-08-03 14:36:16 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-08-03 14:36:16 -0400
commitb1a5a4f985783ab7a6e9f443975f9347cb4a4f30 (patch)
tree42cbc1fe5dc8fb7b8dcaec543de9e53eccbe78db /Assistant
parent2d4f1441c8af0b30eefdbea29816a7c1ade88aaa (diff)
moving toward configuring new repos in the webapp
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/WebApp/Configurators.hs89
-rw-r--r--Assistant/WebApp/DashBoard.hs2
-rw-r--r--Assistant/WebApp/Documentation.hs2
-rw-r--r--Assistant/WebApp/SideBar.hs10
-rw-r--r--Assistant/WebApp/routes1
5 files changed, 59 insertions, 45 deletions
diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs
index 27cffcecd..018f97363 100644
--- a/Assistant/WebApp/Configurators.hs
+++ b/Assistant/WebApp/Configurators.hs
@@ -30,25 +30,51 @@ import qualified Data.Text as T
import Data.Char
import System.Posix.Directory
-{- An intro message, list of repositories, and nudge to make more. -}
-introDisplay :: Text -> Widget
-introDisplay ident = do
- webapp <- lift getYesod
- l <- lift $ runAnnex [] $ do
+{- The main configuration screen. -}
+getConfigR :: Handler RepHtml
+getConfigR = ifM (inFirstRun)
+ ( getFirstRepositoryR
+ , bootstrap (Just Config) $ do
+ sideBarDisplay $ Just sidebar
+ setTitle "Configuration"
+ $(widgetFile "configurators/main")
+ )
+ where
+ sidebar = do
+ (_repolist, numrepos, notenough, barelyenough, morethanenough)
+ <- lift repoList
+ $(widgetFile "configurators/main/sidebar")
+
+{- Lists different types of repositories that can be added. -}
+getAddRepositoryR :: Handler RepHtml
+getAddRepositoryR = bootstrap (Just Config) $ do
+ sideBarDisplay Nothing
+ setTitle "Add repository"
+ $(widgetFile "configurators/addrepository")
+
+{- A numbered list of known repositories, including the current one,
+ - as well as the total number, and whether that is not enough,
+ - barely enough, or more than enough. -}
+repoList :: Handler ([(String, String)], String, Bool, Bool, Bool)
+repoList = do
+ l <- runAnnex [] $ do
u <- getUUID
rs <- map Remote.uuid <$> Remote.remoteList
rs' <- snd <$> trustPartition DeadTrusted rs
Remote.prettyListUUIDs $ filter (/= webUUID) $ nub $ u:rs'
- let remotelist = zip counter l
let n = length l
- let numrepos = show n
- let notenough = n < 2
- let barelyenough = n == 2
- let morethanenough = n > 2
- $(widgetFile "configurators/intro")
- lift $ modifyWebAppState $ \s -> s { showIntro = False }
+ return (zip counter l, show (length l), n < enough, n == enough, n > enough)
where
counter = map show ([1..] :: [Int])
+ enough = 2
+
+{- An intro message, list of repositories, and nudge to make more. -}
+introDisplay :: Text -> Widget
+introDisplay ident = do
+ webapp <- lift getYesod
+ (repolist, numrepos, notenough, barelyenough, morethanenough) <- lift repoList
+ $(widgetFile "configurators/intro")
+ lift $ modifyWebAppState $ \s -> s { showIntro = False }
data RepositoryPath = RepositoryPath Text
deriving Show
@@ -118,8 +144,8 @@ defaultRepositoryPath firstrun = do
(relHome (desktop </> "annex"), return "~/annex")
else return cwd
-addRepositoryForm :: Form RepositoryPath
-addRepositoryForm msg = do
+addLocalRepositoryForm :: Form RepositoryPath
+addLocalRepositoryForm msg = do
path <- T.pack . addTrailingPathSeparator
<$> (liftIO . defaultRepositoryPath =<< lift inFirstRun)
(pathRes, pathView) <- mreq (repositoryPathField True) "" (Just path)
@@ -129,20 +155,18 @@ addRepositoryForm msg = do
FormSuccess _ -> (False, "")
let form = do
webAppFormAuthToken
- $(widgetFile "configurators/addrepository/form")
+ $(widgetFile "configurators/localrepositoryform")
return (RepositoryPath <$> pathRes, form)
-addRepository :: Bool -> Widget
-addRepository firstrun = do
- setTitle $ if firstrun then "Getting started" else "Add repository"
- ((res, form), enctype) <- lift $ runFormGet addRepositoryForm
+getFirstRepositoryR :: Handler RepHtml
+getFirstRepositoryR = bootstrap (Just Config) $ do
+ sideBarDisplay Nothing
+ setTitle "Getting started"
+ ((res, form), enctype) <- lift $ runFormGet addLocalRepositoryForm
case res of
- FormSuccess (RepositoryPath p) -> go $ T.unpack p
- _ -> $(widgetFile "configurators/addrepository")
- where
- go path
- | firstrun = lift $ startFullAssistant path
- | otherwise = error "TODO"
+ FormSuccess (RepositoryPath p) -> lift $
+ startFullAssistant $ T.unpack p
+ _ -> $(widgetFile "configurators/firstrepository")
{- Bootstraps from first run mode to a fully running assistant in a
- repository, by running the postFirstRun callback, which returns the
@@ -167,18 +191,3 @@ makeRepo path = do
autostart <- autoStartFile
createDirectoryIfMissing True (parentDir autostart)
appendFile autostart $ path ++ "\n"
-
-getAddRepositoryR :: Handler RepHtml
-getAddRepositoryR = bootstrap (Just Config) $ do
- sideBarDisplay
- addRepository False
-
-getConfigR :: Handler RepHtml
-getConfigR = bootstrap (Just Config) $ do
- sideBarDisplay
- ifM (lift inFirstRun)
- ( addRepository True
- , do
- setTitle "Configuration"
- $(widgetFile "configurators/main")
- )
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index 8e526fb1d..32159c22d 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/Assistant/WebApp/DashBoard.hs
@@ -68,7 +68,7 @@ getTransfersR nid = do
{- The main dashboard. -}
dashboard :: Bool -> Widget
dashboard warnNoScript = do
- sideBarDisplay
+ sideBarDisplay Nothing
let content = transfersDisplay warnNoScript
$(widgetFile "dashboard/main")
diff --git a/Assistant/WebApp/Documentation.hs b/Assistant/WebApp/Documentation.hs
index b0a9e4d98..530c4ceb3 100644
--- a/Assistant/WebApp/Documentation.hs
+++ b/Assistant/WebApp/Documentation.hs
@@ -17,6 +17,6 @@ import Yesod
getAboutR :: Handler RepHtml
getAboutR = bootstrap (Just About) $ do
- sideBarDisplay
+ sideBarDisplay Nothing
setTitle "About git-annex"
$(widgetFile "documentation/about")
diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs
index 4373b5a5b..e0c31c949 100644
--- a/Assistant/WebApp/SideBar.hs
+++ b/Assistant/WebApp/SideBar.hs
@@ -22,9 +22,13 @@ import Data.Text (Text)
import qualified Data.Map as M
import Control.Concurrent
-sideBarDisplay :: Widget
-sideBarDisplay = do
+sideBarDisplay :: Maybe Widget -> Widget
+sideBarDisplay onsidebar = do
let content = do
+ {- If a widget was passed to include on the sidebar, display
+ - it above alerts. -}
+ maybe noop id onsidebar
+
{- Any yesod message appears as the first alert. -}
maybe noop rendermessage =<< lift getMessage
@@ -83,7 +87,7 @@ getSideBarR nid = do
- to avoid slowing down user actions like closing alerts. -}
liftIO $ threadDelay 100000
- page <- widgetToPageContent sideBarDisplay
+ page <- widgetToPageContent $ sideBarDisplay Nothing
hamletToRepHtml $ [hamlet|^{pageBody page}|]
{- Called by the client to close an alert. -}
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index 192e1cd6b..893ba79fe 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -5,6 +5,7 @@
/config ConfigR GET
/config/addrepository AddRepositoryR GET
+/config/firstrepository FirstRepositoryR GET
/transfers/#NotificationId TransfersR GET
/sidebar/#NotificationId SideBarR GET