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

refactor

Browse source
This commit is contained in:
Joey Hess 2012-11-25 00:26:46 -04:00
parent 3bd354ab84
commit 59733456ed
15 changed files with 129 additions and 172 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

51
Assistant/WebApp.hs
View file

@ -22,48 +22,9 @@ import Data.Text (Text)
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent import Control.Concurrent
data NavBarItem = DashBoard | Config | About
deriving (Eq)
navBarName :: NavBarItem -> Text
navBarName DashBoard = "Dashboard"
navBarName Config = "Configuration"
navBarName About = "About"
navBarRoute :: NavBarItem -> Route WebApp
navBarRoute DashBoard = HomeR
navBarRoute Config = ConfigR
navBarRoute About = AboutR
defaultNavBar :: [NavBarItem]
defaultNavBar = [DashBoard, Config, About]
firstRunNavBar :: [NavBarItem]
firstRunNavBar = [Config, About]
selectNavBar :: Handler [NavBarItem]
selectNavBar = ifM (inFirstRun) (return firstRunNavBar, return defaultNavBar)
inFirstRun :: Handler Bool inFirstRun :: Handler Bool
inFirstRun = isNothing . relDir <$> getYesod inFirstRun = isNothing . relDir <$> getYesod
{- Used instead of defaultContent; highlights the current page if it's
- on the navbar. -}
bootstrap :: Maybe NavBarItem -> Widget -> Handler RepHtml
bootstrap navbaritem content = do
webapp <- getYesod
navbar <- map navdetails <$> selectNavBar
page <- widgetToPageContent $ do
addStylesheet $ StaticR css_bootstrap_css
addStylesheet $ StaticR css_bootstrap_responsive_css
addScript $ StaticR jquery_full_js
addScript $ StaticR js_bootstrap_dropdown_js
addScript $ StaticR js_bootstrap_modal_js
$(widgetFile "page")
hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap")
where
navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
newWebAppState :: IO (TMVar WebAppState) newWebAppState :: IO (TMVar WebAppState)
newWebAppState = do newWebAppState = do
otherrepos <- listOtherRepos otherrepos <- listOtherRepos
@ -156,12 +117,12 @@ listOtherRepos = do
return $ sort $ zip names dirs return $ sort $ zip names dirs
htmlIcon :: AlertIcon -> GWidget sub master () htmlIcon :: AlertIcon -> GWidget sub master ()
htmlIcon ActivityIcon = bootStrapIcon "refresh" htmlIcon ActivityIcon = bootstrapIcon "refresh"
htmlIcon InfoIcon = bootStrapIcon "info-sign" htmlIcon InfoIcon = bootstrapIcon "info-sign"
htmlIcon SuccessIcon = bootStrapIcon "ok" htmlIcon SuccessIcon = bootstrapIcon "ok"
htmlIcon ErrorIcon = bootStrapIcon "exclamation-sign" htmlIcon ErrorIcon = bootstrapIcon "exclamation-sign"
-- utf-8 umbrella (utf-8 cloud looks too stormy) -- utf-8 umbrella (utf-8 cloud looks too stormy)
htmlIcon TheCloud = [whamlet|&#9730;|] htmlIcon TheCloud = [whamlet|&#9730;|]
bootStrapIcon :: Text -> GWidget sub master () bootstrapIcon :: Text -> GWidget sub master ()
bootStrapIcon name = [whamlet|<i .icon-#{name}></i>|] bootstrapIcon name = [whamlet|<i .icon-#{name}></i>|]

17
Assistant/WebApp/Common.hs Normal file
View file

@ -0,0 +1,17 @@
{- git-annex assistant webapp, common imports
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Assistant.WebApp.Common (module X) where
import Assistant.Common as X
import Assistant.WebApp as X
import Assistant.WebApp.Page as X
import Assistant.WebApp.Types as X
import Utility.Yesod as X
import Data.Text as X (Text)

19
Assistant/WebApp/Configurators.hs
View file

@ -9,15 +9,11 @@
module Assistant.WebApp.Configurators where module Assistant.WebApp.Configurators where
import Assistant.Common import Assistant.WebApp.Common
import Assistant.DaemonStatus import Assistant.DaemonStatus
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Assistant.WebApp.Notifications import Assistant.WebApp.Notifications
import Assistant.WebApp.Utility import Assistant.WebApp.Utility
import Assistant.WebApp.Configurators.Local import Assistant.WebApp.Configurators.Local
import Utility.Yesod
import qualified Remote import qualified Remote
import qualified Types.Remote as Remote import qualified Types.Remote as Remote
import Annex.UUID (getUUID) import Annex.UUID (getUUID)
@ -30,21 +26,18 @@ import Assistant.XMPP.Client
#endif #endif
import Yesod import Yesod
import Data.Text (Text)
import qualified Data.Map as M import qualified Data.Map as M
{- The main configuration screen. -} {- The main configuration screen. -}
getConfigR :: Handler RepHtml getConfigR :: Handler RepHtml
getConfigR = ifM (inFirstRun) getConfigR = ifM (inFirstRun)
( getFirstRepositoryR ( getFirstRepositoryR
, bootstrap (Just Config) $ do , page "Configuration" (Just Config) $ do
#ifdef WITH_XMPP #ifdef WITH_XMPP
xmppconfigured <- lift $ runAnnex False $ isJust <$> getXMPPCreds xmppconfigured <- lift $ runAnnex False $ isJust <$> getXMPPCreds
#else #else
let xmppconfigured = False let xmppconfigured = False
#endif #endif
sideBarDisplay
setTitle "Configuration"
$(widgetFile "configurators/main") $(widgetFile "configurators/main")
) )
@ -70,9 +63,7 @@ makeCloudRepositories = $(widgetFile "configurators/repositories/cloud")
{- Lists known repositories, followed by options to add more. -} {- Lists known repositories, followed by options to add more. -}
getRepositoriesR :: Handler RepHtml getRepositoriesR :: Handler RepHtml
getRepositoriesR = bootstrap (Just Config) $ do getRepositoriesR = page "Repositories" (Just Config) $ do
sideBarDisplay
setTitle "Repositories"
let repolist = repoListDisplay $ RepoSelector let repolist = repoListDisplay $ RepoSelector
{ onlyCloud = False { onlyCloud = False
, onlyConfigured = False , onlyConfigured = False
@ -120,8 +111,8 @@ notSyncing _ = True
getRepoListR :: RepoListNotificationId -> Handler RepHtml getRepoListR :: RepoListNotificationId -> Handler RepHtml
getRepoListR (RepoListNotificationId nid reposelector) = do getRepoListR (RepoListNotificationId nid reposelector) = do
waitNotifier getRepoListBroadcaster nid waitNotifier getRepoListBroadcaster nid
page <- widgetToPageContent $ repoListDisplay reposelector p <- widgetToPageContent $ repoListDisplay reposelector
hamletToRepHtml $ [hamlet|^{pageBody page}|] hamletToRepHtml $ [hamlet|^{pageBody p}|]
repoListDisplay :: RepoSelector -> Widget repoListDisplay :: RepoSelector -> Widget
repoListDisplay reposelector = do repoListDisplay reposelector = do

12
Assistant/WebApp/Configurators/AWS.hs
View file

@ -9,13 +9,9 @@
module Assistant.WebApp.Configurators.AWS where module Assistant.WebApp.Configurators.AWS where
import Assistant.Common import Assistant.WebApp.Common
import Assistant.MakeRemote import Assistant.MakeRemote
import Assistant.Sync import Assistant.Sync
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod
#ifdef WITH_S3 #ifdef WITH_S3
import qualified Remote.S3 as S3 import qualified Remote.S3 as S3
#endif #endif
@ -28,15 +24,11 @@ import Types.StandardGroups
import Logs.PreferredContent import Logs.PreferredContent
import Yesod import Yesod
import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
awsConfigurator :: Widget -> Handler RepHtml awsConfigurator :: Widget -> Handler RepHtml
awsConfigurator a = bootstrap (Just Config) $ do awsConfigurator = page "Add an Amazon repository" (Just Config)
sideBarDisplay
setTitle "Add an Amazon repository"
a
glacierConfigurator :: Widget -> Handler RepHtml glacierConfigurator :: Widget -> Handler RepHtml
glacierConfigurator a = do glacierConfigurator a = do

12
Assistant/WebApp/Configurators/Edit.hs
View file

@ -9,15 +9,11 @@
module Assistant.WebApp.Configurators.Edit where module Assistant.WebApp.Configurators.Edit where
import Assistant.Common import Assistant.WebApp.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Assistant.WebApp.Utility import Assistant.WebApp.Utility
import Assistant.DaemonStatus import Assistant.DaemonStatus
import Assistant.MakeRemote (uniqueRemoteName) import Assistant.MakeRemote (uniqueRemoteName)
import Assistant.WebApp.Configurators.XMPP (xmppNeeded) import Assistant.WebApp.Configurators.XMPP (xmppNeeded)
import Utility.Yesod
import qualified Remote import qualified Remote
import qualified Remote.List as Remote import qualified Remote.List as Remote
import Logs.UUID import Logs.UUID
@ -30,7 +26,6 @@ import qualified Git.Command
import qualified Git.Config import qualified Git.Config
import Yesod import Yesod
import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Set as S import qualified Data.Set as S
@ -116,10 +111,7 @@ getEditNewCloudRepositoryR :: UUID -> Handler RepHtml
getEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid getEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid
editForm :: Bool -> UUID -> Handler RepHtml editForm :: Bool -> UUID -> Handler RepHtml
editForm new uuid = bootstrap (Just Config) $ do editForm new uuid = page "Configure repository" (Just Config) $ do
sideBarDisplay
setTitle "Configure repository"
(repo, mremote) <- lift $ runAnnex undefined $ Remote.repoFromUUID uuid (repo, mremote) <- lift $ runAnnex undefined $ Remote.repoFromUUID uuid
curr <- lift $ runAnnex undefined $ getRepoConfig uuid repo mremote curr <- lift $ runAnnex undefined $ getRepoConfig uuid repo mremote
lift $ checkarchivedirectory curr lift $ checkarchivedirectory curr

23
Assistant/WebApp/Configurators/Local.hs
View file

@ -9,13 +9,9 @@
module Assistant.WebApp.Configurators.Local where module Assistant.WebApp.Configurators.Local where
import Assistant.Common import Assistant.WebApp.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Assistant.WebApp.Utility import Assistant.WebApp.Utility
import Assistant.MakeRemote import Assistant.MakeRemote
import Utility.Yesod
import Init import Init
import qualified Git import qualified Git
import qualified Git.Construct import qualified Git.Construct
@ -35,7 +31,6 @@ import Logs.PreferredContent
import Utility.UserInfo import Utility.UserInfo
import Yesod import Yesod
import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Char import Data.Char
import System.Posix.Directory import System.Posix.Directory
@ -133,9 +128,7 @@ newRepositoryForm defpath msg = do
{- Making the first repository, when starting the webapp for the first time. -} {- Making the first repository, when starting the webapp for the first time. -}
getFirstRepositoryR :: Handler RepHtml getFirstRepositoryR :: Handler RepHtml
getFirstRepositoryR = bootstrap (Just Config) $ do getFirstRepositoryR = page "Getting started" (Just Config) $ do
sideBarDisplay
setTitle "Getting started"
path <- liftIO . defaultRepositoryPath =<< lift inFirstRun path <- liftIO . defaultRepositoryPath =<< lift inFirstRun
((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm path ((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm path
case res of case res of
@ -145,9 +138,7 @@ getFirstRepositoryR = bootstrap (Just Config) $ do
{- Adding a new, separate repository. -} {- Adding a new, separate repository. -}
getNewRepositoryR :: Handler RepHtml getNewRepositoryR :: Handler RepHtml
getNewRepositoryR = bootstrap (Just Config) $ do getNewRepositoryR = page "Add another repository" (Just Config) $ do
sideBarDisplay
setTitle "Add another repository"
home <- liftIO myHomeDir home <- liftIO myHomeDir
((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm home ((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm home
case res of case res of
@ -184,9 +175,7 @@ selectDriveForm drives def = renderBootstrap $ RemovableDrive
{- Adding a removable drive. -} {- Adding a removable drive. -}
getAddDriveR :: Handler RepHtml getAddDriveR :: Handler RepHtml
getAddDriveR = bootstrap (Just Config) $ do getAddDriveR = page "AAdd a removable drive" (Just Config) $ do
sideBarDisplay
setTitle "Add a removable drive"
removabledrives <- liftIO $ driveList removabledrives <- liftIO $ driveList
writabledrives <- liftIO $ writabledrives <- liftIO $
filterM (canWrite . T.unpack . mountPoint) removabledrives filterM (canWrite . T.unpack . mountPoint) removabledrives
@ -226,9 +215,7 @@ getAddDriveR = bootstrap (Just Config) $ do
addRemote $ makeGitRemote name dir addRemote $ makeGitRemote name dir
getEnableDirectoryR :: UUID -> Handler RepHtml getEnableDirectoryR :: UUID -> Handler RepHtml
getEnableDirectoryR uuid = bootstrap (Just Config) $ do getEnableDirectoryR uuid = page "Enable a repository" (Just Config) $ do
sideBarDisplay
setTitle "Enable a repository"
description <- lift $ runAnnex "" $ description <- lift $ runAnnex "" $
T.pack . concat <$> prettyListUUIDs [uuid] T.pack . concat <$> prettyListUUIDs [uuid]
$(widgetFile "configurators/enabledirectory") $(widgetFile "configurators/enabledirectory")

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

@ -11,13 +11,9 @@
module Assistant.WebApp.Configurators.Pairing where module Assistant.WebApp.Configurators.Pairing where
import Assistant.Pairing import Assistant.Pairing
import Assistant.WebApp import Assistant.WebApp.Common
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Assistant.Types.Buddies import Assistant.Types.Buddies
import Utility.Yesod
#ifdef WITH_PAIRING #ifdef WITH_PAIRING
import Assistant.Common
import Assistant.Pairing.Network import Assistant.Pairing.Network
import Assistant.Pairing.MakeRemote import Assistant.Pairing.MakeRemote
import Assistant.Ssh import Assistant.Ssh
@ -42,7 +38,6 @@ import Utility.UserInfo
import Git import Git
import Yesod import Yesod
import Data.Text (Text)
#ifdef WITH_PAIRING #ifdef WITH_PAIRING
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
@ -293,10 +288,7 @@ sampleQuote = T.unwords
#endif #endif
pairPage :: Widget -> Handler RepHtml pairPage :: Widget -> Handler RepHtml
pairPage w = bootstrap (Just Config) $ do pairPage = page "Pairing" (Just Config)
sideBarDisplay
setTitle "Pairing"
w
noPairing :: Text -> Handler RepHtml noPairing :: Text -> Handler RepHtml
noPairing pairingtype = pairPage $ noPairing pairingtype = pairPage $

17
Assistant/WebApp/Configurators/Ssh.hs
View file

@ -9,13 +9,9 @@
module Assistant.WebApp.Configurators.Ssh where module Assistant.WebApp.Configurators.Ssh where
import Assistant.Common import Assistant.WebApp.Common
import Assistant.Ssh import Assistant.Ssh
import Assistant.MakeRemote import Assistant.MakeRemote
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod
import Utility.Rsync (rsyncUrlIsShell) import Utility.Rsync (rsyncUrlIsShell)
import Logs.Remote import Logs.Remote
import Remote import Remote
@ -24,16 +20,12 @@ import Types.StandardGroups
import Utility.UserInfo import Utility.UserInfo
import Yesod import Yesod
import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
import Network.Socket import Network.Socket
sshConfigurator :: Widget -> Handler RepHtml sshConfigurator :: Widget -> Handler RepHtml
sshConfigurator a = bootstrap (Just Config) $ do sshConfigurator = page "Add a remote server" (Just Config)
sideBarDisplay
setTitle "Add a remote server"
a
data SshInput = SshInput data SshInput = SshInput
{ hostname :: Maybe Text { hostname :: Maybe Text
@ -291,10 +283,7 @@ getAddRsyncNetR = do
((result, form), enctype) <- runFormGet $ ((result, form), enctype) <- runFormGet $
renderBootstrap $ sshInputAForm $ renderBootstrap $ sshInputAForm $
SshInput Nothing Nothing Nothing SshInput Nothing Nothing Nothing
let showform status = bootstrap (Just Config) $ do let showform status = page "Add a Rsync.net repository" (Just Config) $
sideBarDisplay
setTitle "Add a Rsync.net repository"
let authtoken = webAppFormAuthToken
$(widgetFile "configurators/addrsync.net") $(widgetFile "configurators/addrsync.net")
case result of case result of
FormSuccess sshinput FormSuccess sshinput

17
Assistant/WebApp/Configurators/WebDAV.hs
View file

@ -9,13 +9,9 @@
module Assistant.WebApp.Configurators.WebDAV where module Assistant.WebApp.Configurators.WebDAV where
import Assistant.Common import Assistant.WebApp.Common
import Assistant.MakeRemote import Assistant.MakeRemote
import Assistant.Sync import Assistant.Sync
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod
import qualified Remote.WebDAV as WebDAV import qualified Remote.WebDAV as WebDAV
import qualified Remote import qualified Remote
import Types.Remote (RemoteConfig) import Types.Remote (RemoteConfig)
@ -24,21 +20,14 @@ import Logs.PreferredContent
import Logs.Remote import Logs.Remote
import Yesod import Yesod
import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map as M import qualified Data.Map as M
webDAVConfigurator :: Widget -> Handler RepHtml webDAVConfigurator :: Widget -> Handler RepHtml
webDAVConfigurator a = bootstrap (Just Config) $ do webDAVConfigurator = page "Add a WebDAV repository" (Just Config)
sideBarDisplay
setTitle "Add a WebDAV repository"
a
boxConfigurator :: Widget -> Handler RepHtml boxConfigurator :: Widget -> Handler RepHtml
boxConfigurator a = bootstrap (Just Config) $ do boxConfigurator = page "Add a Box.com repository" (Just Config)
sideBarDisplay
setTitle "Add a Box.com repository"
a
data WebDAVInput = WebDAVInput data WebDAVInput = WebDAVInput
{ user :: Text { user :: Text

16
Assistant/WebApp/Configurators/XMPP.hs
View file

@ -10,14 +10,10 @@
module Assistant.WebApp.Configurators.XMPP where module Assistant.WebApp.Configurators.XMPP where
import Assistant.WebApp import Assistant.WebApp.Common
import Assistant.WebApp.Types
import Assistant.WebApp.Notifications import Assistant.WebApp.Notifications
import Assistant.WebApp.SideBar
import Utility.Yesod
import Utility.NotificationBroadcaster import Utility.NotificationBroadcaster
#ifdef WITH_XMPP #ifdef WITH_XMPP
import Assistant.Common
import Assistant.XMPP.Client import Assistant.XMPP.Client
import Assistant.XMPP.Buddies import Assistant.XMPP.Buddies
import Assistant.Types.Buddies import Assistant.Types.Buddies
@ -31,7 +27,6 @@ import Yesod
#ifdef WITH_XMPP #ifdef WITH_XMPP
import Network import Network
import Network.Protocol.XMPP import Network.Protocol.XMPP
import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Control.Exception (SomeException) import Control.Exception (SomeException)
#endif #endif
@ -97,8 +92,8 @@ getBuddyListR :: NotificationId -> Handler RepHtml
getBuddyListR nid = do getBuddyListR nid = do
waitNotifier getBuddyListBroadcaster nid waitNotifier getBuddyListBroadcaster nid
page <- widgetToPageContent buddyListDisplay p <- widgetToPageContent buddyListDisplay
hamletToRepHtml $ [hamlet|^{pageBody page}|] hamletToRepHtml $ [hamlet|^{pageBody p}|]
buddyListDisplay :: Widget buddyListDisplay :: Widget
buddyListDisplay = do buddyListDisplay = do
@ -163,7 +158,4 @@ testXMPP creds = either Left (const $ Right creds)
#endif #endif
xmppPage :: Widget -> Handler RepHtml xmppPage :: Widget -> Handler RepHtml
xmppPage w = bootstrap (Just Config) $ do xmppPage = page "Jabber" (Just Config)
sideBarDisplay
setTitle "Jabber"
w

17
Assistant/WebApp/DashBoard.hs
View file

@ -9,16 +9,12 @@
module Assistant.WebApp.DashBoard where module Assistant.WebApp.DashBoard where
import Assistant.Common import Assistant.WebApp.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.Utility import Assistant.WebApp.Utility
import Assistant.WebApp.SideBar
import Assistant.WebApp.Notifications import Assistant.WebApp.Notifications
import Assistant.WebApp.Configurators import Assistant.WebApp.Configurators
import Assistant.TransferQueue import Assistant.TransferQueue
import Utility.NotificationBroadcaster import Utility.NotificationBroadcaster
import Utility.Yesod
import Logs.Transfer import Logs.Transfer
import Utility.Percentage import Utility.Percentage
import Utility.DataUnits import Utility.DataUnits
@ -73,20 +69,19 @@ getTransfersR :: NotificationId -> Handler RepHtml
getTransfersR nid = do getTransfersR nid = do
waitNotifier getTransferBroadcaster nid waitNotifier getTransferBroadcaster nid
page <- widgetToPageContent $ transfersDisplay False p <- widgetToPageContent $ transfersDisplay False
hamletToRepHtml $ [hamlet|^{pageBody page}|] hamletToRepHtml $ [hamlet|^{pageBody p}|]
{- The main dashboard. -} {- The main dashboard. -}
dashboard :: Bool -> Widget dashboard :: Bool -> Widget
dashboard warnNoScript = do dashboard warnNoScript = do
sideBarDisplay
let content = transfersDisplay warnNoScript let content = transfersDisplay warnNoScript
$(widgetFile "dashboard/main") $(widgetFile "dashboard/main")
getHomeR :: Handler RepHtml getHomeR :: Handler RepHtml
getHomeR = ifM (inFirstRun) getHomeR = ifM (inFirstRun)
( redirect ConfigR ( redirect ConfigR
, bootstrap (Just DashBoard) $ dashboard True , page "" (Just DashBoard) $ dashboard True
) )
{- Used to test if the webapp is running. -} {- Used to test if the webapp is running. -}
@ -95,11 +90,11 @@ headHomeR = noop
{- Same as HomeR, except no autorefresh at all (and no noscript warning). -} {- Same as HomeR, except no autorefresh at all (and no noscript warning). -}
getNoScriptR :: Handler RepHtml getNoScriptR :: Handler RepHtml
getNoScriptR = bootstrap (Just DashBoard) $ dashboard False getNoScriptR = page "" (Just DashBoard) $ dashboard False
{- Same as HomeR, except with autorefreshing via meta refresh. -} {- Same as HomeR, except with autorefreshing via meta refresh. -}
getNoScriptAutoR :: Handler RepHtml getNoScriptAutoR :: Handler RepHtml
getNoScriptAutoR = bootstrap (Just DashBoard) $ do getNoScriptAutoR = page "" (Just DashBoard) $ do
let ident = NoScriptR let ident = NoScriptR
let delayseconds = 3 :: Int let delayseconds = 3 :: Int
let this = NoScriptAutoR let this = NoScriptAutoR

12
Assistant/WebApp/Documentation.hs
View file

@ -9,12 +9,8 @@
module Assistant.WebApp.Documentation where module Assistant.WebApp.Documentation where
import Assistant.Common import Assistant.WebApp.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Assistant.Install (standaloneAppBase) import Assistant.Install (standaloneAppBase)
import Utility.Yesod
import Build.SysConfig (packageversion) import Build.SysConfig (packageversion)
import Yesod import Yesod
@ -27,9 +23,7 @@ licenseFile = do
return $ (</> "LICENSE") <$> base return $ (</> "LICENSE") <$> base
getAboutR :: Handler RepHtml getAboutR :: Handler RepHtml
getAboutR = bootstrap (Just About) $ do getAboutR = page "About git-annex" (Just About) $ do
sideBarDisplay
setTitle "About git-annex"
builtinlicense <- isJust <$> liftIO licenseFile builtinlicense <- isJust <$> liftIO licenseFile
$(widgetFile "documentation/about") $(widgetFile "documentation/about")
@ -38,7 +32,7 @@ getLicenseR = do
v <- liftIO licenseFile v <- liftIO licenseFile
case v of case v of
Nothing -> redirect AboutR Nothing -> redirect AboutR
Just f -> bootstrap (Just About) $ do Just f -> customPage (Just About) $ do
-- no sidebar, just pages of legalese.. -- no sidebar, just pages of legalese..
setTitle "License" setTitle "License"
license <- liftIO $ readFile f license <- liftIO $ readFile f

66
Assistant/WebApp/Page.hs Normal file
View file

@ -0,0 +1,66 @@
{- git-annex assistant webapp page display
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
module Assistant.WebApp.Page where
import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod
import Yesod
import Text.Hamlet
import Data.Text (Text)
data NavBarItem = DashBoard | Config | About
deriving (Eq)
navBarName :: NavBarItem -> Text
navBarName DashBoard = "Dashboard"
navBarName Config = "Configuration"
navBarName About = "About"
navBarRoute :: NavBarItem -> Route WebApp
navBarRoute DashBoard = HomeR
navBarRoute Config = ConfigR
navBarRoute About = AboutR
defaultNavBar :: [NavBarItem]
defaultNavBar = [DashBoard, Config, About]
firstRunNavBar :: [NavBarItem]
firstRunNavBar = [Config, About]
selectNavBar :: Handler [NavBarItem]
selectNavBar = ifM (inFirstRun) (return firstRunNavBar, return defaultNavBar)
{- A standard page of the webapp, with a title, a sidebar, and that may
- be highlighted on the navbar. -}
page :: Html -> Maybe NavBarItem -> Widget -> Handler RepHtml
page title navbaritem content = customPage navbaritem $ do
setTitle title
sideBarDisplay
content
{- A custom page, with no title or sidebar set. -}
customPage :: Maybe NavBarItem -> Widget -> Handler RepHtml
customPage navbaritem content = do
webapp <- getYesod
navbar <- map navdetails <$> selectNavBar
pageinfo <- widgetToPageContent $ do
addStylesheet $ StaticR css_bootstrap_css
addStylesheet $ StaticR css_bootstrap_responsive_css
addScript $ StaticR jquery_full_js
addScript $ StaticR js_bootstrap_dropdown_js
addScript $ StaticR js_bootstrap_modal_js
$(widgetFile "page")
hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap")
where
navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)

8
templates/bootstrap.hamlet
View file

@ -3,12 +3,12 @@ $doctype 5
<head> <head>
<title> <title>
$maybe reldir <- relDir webapp $maybe reldir <- relDir webapp
#{reldir} #{pageTitle page} #{reldir} #{pageTitle pageinfo}
$nothing $nothing
#{pageTitle page} #{pageTitle pageinfo}
<link rel="icon" href=@{StaticR favicon_ico} type="image/x-icon"> <link rel="icon" href=@{StaticR favicon_ico} type="image/x-icon">
<meta name="viewport" content="width=device-width,initial-scale=1.0"> <meta name="viewport" content="width=device-width,initial-scale=1.0">
^{pageHead page} ^{pageHead pageinfo}
<body> <body>
^{pageBody page} ^{pageBody pageinfo}
<div #modal></div> <div #modal></div>

2
templates/configurators/addrsync.net.hamlet
View file

@ -28,7 +28,7 @@
<form .form-horizontal enctype=#{enctype}> <form .form-horizontal enctype=#{enctype}>
<fieldset> <fieldset>
^{form} ^{form}
^{authtoken} ^{webAppFormAuthToken}
<div .form-actions> <div .form-actions>
<button .btn .btn-primary type=submit onclick="$('#testmodal').modal('show');"> <button .btn .btn-primary type=submit onclick="$('#testmodal').modal('show');">
Use this rsync.net repository Use this rsync.net repository