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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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