diff options
author | Joey Hess <joey@kitenet.net> | 2012-08-03 14:36:16 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-08-03 14:36:16 -0400 |
commit | b1a5a4f985783ab7a6e9f443975f9347cb4a4f30 (patch) | |
tree | 42cbc1fe5dc8fb7b8dcaec543de9e53eccbe78db /Assistant | |
parent | 2d4f1441c8af0b30eefdbea29816a7c1ade88aaa (diff) |
moving toward configuring new repos in the webapp
Diffstat (limited to 'Assistant')
-rw-r--r-- | Assistant/WebApp/Configurators.hs | 89 | ||||
-rw-r--r-- | Assistant/WebApp/DashBoard.hs | 2 | ||||
-rw-r--r-- | Assistant/WebApp/Documentation.hs | 2 | ||||
-rw-r--r-- | Assistant/WebApp/SideBar.hs | 10 | ||||
-rw-r--r-- | Assistant/WebApp/routes | 1 |
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 |