webapp: Switch all forms to POST.

This commit is contained in:
Joey Hess 2013-03-16 18:48:23 -04:00
parent 26374f40a9
commit 140774a8c8
25 changed files with 122 additions and 75 deletions

View file

@ -108,10 +108,13 @@ datacenterField service = areq (selectFieldList list) "Datacenter" defregion
defregion = Just $ AWS.defaultRegion service
getAddS3R :: Handler RepHtml
getAddS3R = postAddS3R
postAddS3R :: Handler RepHtml
#ifdef WITH_S3
getAddS3R = awsConfigurator $ do
postAddS3R = awsConfigurator $ do
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap s3InputAForm
runFormPost $ renderBootstrap s3InputAForm
case result of
FormSuccess input -> lift $ do
let name = T.unpack $ repoName input
@ -126,13 +129,16 @@ getAddS3R = awsConfigurator $ do
setgroup r = liftAnnex $
setStandardGroup (Remote.uuid r) TransferGroup
#else
getAddS3R = error "S3 not supported by this build"
postAddS3R = error "S3 not supported by this build"
#endif
getAddGlacierR :: Handler RepHtml
getAddGlacierR = glacierConfigurator $ do
getAddGlacierR = postAddGlacierR
postAddGlacierR :: Handler RepHtml
postAddGlacierR = glacierConfigurator $ do
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap glacierInputAForm
runFormPost $ renderBootstrap glacierInputAForm
case result of
FormSuccess input -> lift $ do
let name = T.unpack $ repoName input
@ -147,19 +153,25 @@ getAddGlacierR = glacierConfigurator $ do
setStandardGroup (Remote.uuid r) SmallArchiveGroup
getEnableS3R :: UUID -> Handler RepHtml
getEnableS3R = postEnableS3R
postEnableS3R :: UUID -> Handler RepHtml
#ifdef WITH_S3
getEnableS3R = awsConfigurator . enableAWSRemote S3.remote
postEnableS3R = awsConfigurator . enableAWSRemote S3.remote
#else
getEnableS3R _ = error "S3 not supported by this build"
postEnableS3R _ = error "S3 not supported by this build"
#endif
getEnableGlacierR :: UUID -> Handler RepHtml
getEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote
getEnableGlacierR = postEnableGlacierR
postEnableGlacierR :: UUID -> Handler RepHtml
postEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote
enableAWSRemote :: RemoteType -> UUID -> Widget
enableAWSRemote remotetype uuid = do
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap awsCredsAForm
runFormPost $ renderBootstrap awsCredsAForm
case result of
FormSuccess creds -> lift $ do
m <- liftAnnex readRemoteLog

View file

@ -109,13 +109,22 @@ editRepositoryAForm def = RepoConfig
help = [whamlet|<a href="@{RepoGroupR}">What's this?</a>|]
getEditRepositoryR :: UUID -> Handler RepHtml
getEditRepositoryR = editForm False
getEditRepositoryR = postEditRepositoryR
postEditRepositoryR :: UUID -> Handler RepHtml
postEditRepositoryR = editForm False
getEditNewRepositoryR :: UUID -> Handler RepHtml
getEditNewRepositoryR = editForm True
getEditNewRepositoryR = postEditNewRepositoryR
postEditNewRepositoryR :: UUID -> Handler RepHtml
postEditNewRepositoryR = editForm True
getEditNewCloudRepositoryR :: UUID -> Handler RepHtml
getEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid
getEditNewCloudRepositoryR = postEditNewCloudRepositoryR
postEditNewCloudRepositoryR :: UUID -> Handler RepHtml
postEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid
editForm :: Bool -> UUID -> Handler RepHtml
editForm new uuid = page "Configure repository" (Just Configuration) $ do
@ -123,7 +132,7 @@ editForm new uuid = page "Configure repository" (Just Configuration) $ do
curr <- liftAnnex $ getRepoConfig uuid mremote
lift $ checkarchivedirectory curr
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap $ editRepositoryAForm curr
runFormPost $ renderBootstrap $ editRepositoryAForm curr
case result of
FormSuccess input -> lift $ do
checkarchivedirectory input

View file

@ -127,9 +127,11 @@ newRepositoryForm defpath msg = do
{- Making the first repository, when starting the webapp for the first time. -}
getFirstRepositoryR :: Handler RepHtml
getFirstRepositoryR = page "Getting started" (Just Configuration) $ do
getFirstRepositoryR = postFirstRepositoryR
postFirstRepositoryR :: Handler RepHtml
postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
path <- liftIO . defaultRepositoryPath =<< lift inFirstRun
((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm path
((res, form), enctype) <- lift $ runFormPost $ newRepositoryForm path
case res of
FormSuccess (RepositoryPath p) -> lift $
startFullAssistant $ T.unpack p
@ -138,9 +140,11 @@ getFirstRepositoryR = page "Getting started" (Just Configuration) $ do
{- Adding a new local repository, which may be entirely separate, or may
- be connected to the current repository. -}
getNewRepositoryR :: Handler RepHtml
getNewRepositoryR = page "Add another repository" (Just Configuration) $ do
getNewRepositoryR = postNewRepositoryR
postNewRepositoryR :: Handler RepHtml
postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
home <- liftIO myHomeDir
((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm home
((res, form), enctype) <- lift $ runFormPost $ newRepositoryForm home
case res of
FormSuccess (RepositoryPath p) -> do
let path = T.unpack p
@ -193,11 +197,13 @@ selectDriveForm drives def = renderBootstrap $ RemovableDrive
- that has already been used elsewhere.
-}
getAddDriveR :: Handler RepHtml
getAddDriveR = page "Add a removable drive" (Just Configuration) $ do
getAddDriveR = postAddDriveR
postAddDriveR :: Handler RepHtml
postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
removabledrives <- liftIO $ driveList
writabledrives <- liftIO $
filterM (canWrite . T.unpack . mountPoint) removabledrives
((res, form), enctype) <- lift $ runFormGet $
((res, form), enctype) <- lift $ runFormPost $
selectDriveForm (sort writabledrives) Nothing
case res of
FormSuccess (RemovableDrive { mountPoint = d }) -> lift $

View file

@ -125,11 +125,13 @@ sendXMPPPairRequest _ = noXMPPPairing
{- Starts local pairing. -}
getStartLocalPairR :: Handler RepHtml
getStartLocalPairR = postStartLocalPairR
postStartLocalPairR :: Handler RepHtml
#ifdef WITH_PAIRING
getStartLocalPairR = promptSecret Nothing $
postStartLocalPairR = promptSecret Nothing $
startLocalPairing PairReq noop pairingAlert Nothing
#else
getStartLocalPairR = noLocalPairing
postStartLocalPairR = noLocalPairing
noLocalPairing :: Handler RepHtml
noLocalPairing = noPairing "local"
@ -139,8 +141,10 @@ noLocalPairing = noPairing "local"
- authorized key first so that the originating host can immediately sync
- with us. -}
getFinishLocalPairR :: PairMsg -> Handler RepHtml
getFinishLocalPairR = postFinishLocalPairR
postFinishLocalPairR :: PairMsg -> Handler RepHtml
#ifdef WITH_PAIRING
getFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
repodir <- lift $ repoPath <$> liftAnnex gitRepo
liftIO $ setup repodir
startLocalPairing PairAck (cleanup repodir) alert uuid "" secret
@ -151,7 +155,7 @@ getFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
remoteSshPubKey $ pairMsgData msg
uuid = Just $ pairUUID $ pairMsgData msg
#else
getFinishLocalPairR _ = noLocalPairing
postFinishLocalPairR _ = noLocalPairing
#endif
getConfirmXMPPPairFriendR :: PairKey -> Handler RepHtml
@ -260,7 +264,7 @@ data InputSecret = InputSecret { secretText :: Maybe Text }
promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler RepHtml
promptSecret msg cont = pairPage $ do
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap $
runFormPost $ renderBootstrap $
InputSecret <$> aopt textField "Secret phrase" Nothing
case result of
FormSuccess v -> do

View file

@ -8,7 +8,8 @@
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Configurators.Preferences (
getPreferencesR
getPreferencesR,
postPreferencesR
) where
import Assistant.WebApp.Common
@ -82,10 +83,12 @@ storePrefs p = do
if debugEnabled p then DEBUG else WARNING
getPreferencesR :: Handler RepHtml
getPreferencesR = page "Preferences" (Just Configuration) $ do
getPreferencesR = postPreferencesR
postPreferencesR :: Handler RepHtml
postPreferencesR = page "Preferences" (Just Configuration) $ do
((result, form), enctype) <- lift $ do
current <- liftAnnex getPrefs
runFormGet $ renderBootstrap $ prefsAForm current
runFormPost $ renderBootstrap $ prefsAForm current
case result of
FormSuccess new -> lift $ do
liftAnnex $ storePrefs new

View file

@ -97,10 +97,12 @@ usable UsableRsyncServer = True
usable UsableSshInput = True
getAddSshR :: Handler RepHtml
getAddSshR = sshConfigurator $ do
getAddSshR = postAddSshR
postAddSshR :: Handler RepHtml
postAddSshR = sshConfigurator $ do
u <- liftIO $ T.pack <$> myUserName
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap $ sshInputAForm textField $
runFormPost $ renderBootstrap $ sshInputAForm textField $
SshInput Nothing (Just u) Nothing 22
case result of
FormSuccess sshinput -> do
@ -124,12 +126,14 @@ sshTestModal = $(widgetFile "configurators/ssh/testmodal")
- remotes, and so their configuration is not shared between repositories.
-}
getEnableRsyncR :: UUID -> Handler RepHtml
getEnableRsyncR u = do
getEnableRsyncR = postEnableRsyncR
postEnableRsyncR :: UUID -> Handler RepHtml
postEnableRsyncR u = do
m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog
case (parseSshRsyncUrl =<< M.lookup "rsyncurl" m, M.lookup "name" m) of
(Just sshinput, Just reponame) -> sshConfigurator $ do
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap $ sshInputAForm textField sshinput
runFormPost $ renderBootstrap $ sshInputAForm textField sshinput
case result of
FormSuccess sshinput'
| isRsyncNet (inputHostname sshinput') ->
@ -300,8 +304,10 @@ makeSshRepo forcersync setup sshdata = do
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
getAddRsyncNetR :: Handler RepHtml
getAddRsyncNetR = do
((result, form), enctype) <- runFormGet $
getAddRsyncNetR = postAddRsyncNetR
postAddRsyncNetR :: Handler RepHtml
postAddRsyncNetR = do
((result, form), enctype) <- runFormPost $
renderBootstrap $ sshInputAForm hostnamefield $
SshInput Nothing Nothing Nothing 22
let showform status = page "Add a Rsync.net repository" (Just Configuration) $

View file

@ -59,10 +59,12 @@ webDAVCredsAForm = WebDAVInput
<*> pure NoEncryption -- not used!
getAddBoxComR :: Handler RepHtml
getAddBoxComR = postAddBoxComR
postAddBoxComR :: Handler RepHtml
#ifdef WITH_WEBDAV
getAddBoxComR = boxConfigurator $ do
postAddBoxComR = boxConfigurator $ do
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap boxComAForm
runFormPost $ renderBootstrap boxComAForm
case result of
FormSuccess input -> lift $
makeWebDavRemote "box.com" (toCredPair input) setgroup $ M.fromList
@ -80,12 +82,14 @@ getAddBoxComR = boxConfigurator $ do
setgroup r = liftAnnex $
setStandardGroup (Remote.uuid r) TransferGroup
#else
getAddBoxComR = error "WebDAV not supported by this build"
postAddBoxComR = error "WebDAV not supported by this build"
#endif
getEnableWebDAVR :: UUID -> Handler RepHtml
getEnableWebDAVR = postEnableWebDAVR
postEnableWebDAVR :: UUID -> Handler RepHtml
#ifdef WITH_WEBDAV
getEnableWebDAVR uuid = do
postEnableWebDAVR uuid = do
m <- liftAnnex readRemoteLog
let c = fromJust $ M.lookup uuid m
let name = fromJust $ M.lookup "name" c
@ -103,7 +107,7 @@ getEnableWebDAVR uuid = do
where
showform name url = do
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap webDAVCredsAForm
runFormPost $ renderBootstrap webDAVCredsAForm
case result of
FormSuccess input -> lift $
makeWebDavRemote name (toCredPair input) (const noop) M.empty
@ -112,7 +116,7 @@ getEnableWebDAVR uuid = do
T.pack . concat <$> Remote.prettyListUUIDs [uuid]
$(widgetFile "configurators/enablewebdav")
#else
getEnableWebDAVR _ = error "WebDAV not supported by this build"
postEnableWebDAVR _ = error "WebDAV not supported by this build"
#endif
#ifdef WITH_WEBDAV

View file

@ -93,11 +93,13 @@ needCloudRepoR = xmppPage $
#endif
getXMPPR :: Handler RepHtml
getXMPPR = postXMPPR
postXMPPR :: Handler RepHtml
#ifdef WITH_XMPP
getXMPPR = xmppPage $ do
postXMPPR = xmppPage $ do
((result, form), enctype) <- lift $ do
oldcreds <- liftAnnex getXMPPCreds
runFormGet $ renderBootstrap $ xmppAForm $
runFormPost $ renderBootstrap $ xmppAForm $
creds2Form <$> oldcreds
let showform problem = $(widgetFile "configurators/xmpp")
case result of

View file

@ -14,36 +14,36 @@
/log LogR GET
/config ConfigurationR GET
/config/preferences PreferencesR GET
/config/xmpp XMPPR GET
/config/preferences PreferencesR GET POST
/config/xmpp XMPPR GET POST
/config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET
/config/addrepository AddRepositoryR GET
/config/repository/new/first FirstRepositoryR GET
/config/repository/new NewRepositoryR GET
/config/repository/new/first FirstRepositoryR GET POST
/config/repository/new NewRepositoryR GET POST
/config/repository/switcher RepositorySwitcherR GET
/config/repository/switchto/#FilePath SwitchToRepositoryR GET
/config/repository/combine/#FilePathAndUUID CombineRepositoryR GET
/config/repository/edit/#UUID EditRepositoryR GET
/config/repository/edit/new/#UUID EditNewRepositoryR GET
/config/repository/edit/new/cloud/#UUID EditNewCloudRepositoryR GET
/config/repository/edit/#UUID EditRepositoryR GET POST
/config/repository/edit/new/#UUID EditNewRepositoryR GET POST
/config/repository/edit/new/cloud/#UUID EditNewCloudRepositoryR GET POST
/config/repository/sync/disable/#UUID DisableSyncR GET
/config/repository/sync/enable/#UUID EnableSyncR GET
/config/repository/add/drive AddDriveR GET
/config/repository/add/ssh AddSshR GET
/config/repository/add/drive AddDriveR GET POST
/config/repository/add/ssh AddSshR GET POST
/config/repository/add/ssh/confirm/#SshData ConfirmSshR GET
/config/repository/add/ssh/retry/#SshData RetrySshR GET
/config/repository/add/ssh/make/git/#SshData MakeSshGitR GET
/config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET
/config/repository/add/cloud/rsync.net AddRsyncNetR GET
/config/repository/add/cloud/S3 AddS3R GET
/config/repository/add/cloud/glacier AddGlacierR GET
/config/repository/add/cloud/box.com AddBoxComR GET
/config/repository/add/cloud/rsync.net AddRsyncNetR GET POST
/config/repository/add/cloud/S3 AddS3R GET POST
/config/repository/add/cloud/glacier AddGlacierR GET POST
/config/repository/add/cloud/box.com AddBoxComR GET POST
/config/repository/pair/local/start StartLocalPairR GET
/config/repository/pair/local/start StartLocalPairR GET POST
/config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET
/config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET
/config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET POST
/config/repository/pair/xmpp/self/start StartXMPPPairSelfR GET
/config/repository/pair/xmpp/self/running RunningXMPPPairSelfR GET
@ -53,11 +53,11 @@
/config/repository/pair/xmpp/friend/accept/#PairKey ConfirmXMPPPairFriendR GET
/config/repository/pair/xmpp/friend/finish/#PairKey FinishXMPPPairFriendR GET
/config/repository/enable/rsync/#UUID EnableRsyncR GET
/config/repository/enable/rsync/#UUID EnableRsyncR GET POST
/config/repository/enable/directory/#UUID EnableDirectoryR GET
/config/repository/enable/S3/#UUID EnableS3R GET
/config/repository/enable/glacier/#UUID EnableGlacierR GET
/config/repository/enable/webdav/#UUID EnableWebDAVR GET
/config/repository/enable/S3/#UUID EnableS3R GET POST
/config/repository/enable/glacier/#UUID EnableGlacierR GET POST
/config/repository/enable/webdav/#UUID EnableWebDAVR GET POST
/config/repository/reorder RepositoriesReorderR GET

1
debian/changelog vendored
View file

@ -16,6 +16,7 @@ git-annex (4.20130315) UNRELEASED; urgency=low
messages to clients.
* map: Combine duplicate repositories, for a nicer looking map.
* Fix several bugs caused by a bad Ord instance for Remote.
* webapp: Switch all forms to POST.
-- Joey Hess <joeyh@debian.org> Fri, 15 Mar 2013 00:10:07 -0400

View file

@ -8,7 +8,7 @@
Even a small amount of free storage is useful, as a transfer point #
between your repositories.
<p>
<form .form-horizontal enctype=#{enctype}>
<form method="post" .form-horizontal enctype=#{enctype}>
<fieldset>
^{form}
^{webAppFormAuthToken}

View file

@ -22,7 +22,7 @@
<a .btn .btn-primary href="@{AddDriveR}">
Rescan for removable drives
$else
<form enctype=#{enctype}>
<form method="post" enctype=#{enctype}>
<fieldset>
^{form}
^{webAppFormAuthToken}

View file

@ -16,7 +16,7 @@
<a href="http://aws.amazon.com/glacier/pricing/">
Pricing details
<p>
<form .form-horizontal enctype=#{enctype}>
<form method="post" .form-horizontal enctype=#{enctype}>
<fieldset>
^{form}
^{webAppFormAuthToken}

View file

@ -17,7 +17,7 @@
<div>
Your data will be encrypted before it is sent to Rsync.net.
<p>
<form .form-horizontal enctype=#{enctype}>
<form method="post" .form-horizontal enctype=#{enctype}>
<fieldset>
^{form}
^{webAppFormAuthToken}

View file

@ -12,7 +12,7 @@
<a href="http://aws.amazon.com/s3/pricing/">
Pricing details, including one year Free Usage Tier promotion
<p>
<form .form-horizontal enctype=#{enctype}>
<form method="post" .form-horizontal enctype=#{enctype}>
<fieldset>
^{form}
^{webAppFormAuthToken}

View file

@ -13,7 +13,7 @@
right choice if you'll use it to shuttle data back and forth #
between other repositories. Otherwise, pick one of the other groups.
<p>
<form .form-horizontal enctype=#{enctype}>
<form method="post" .form-horizontal enctype=#{enctype}>
<fieldset>
^{form}
^{webAppFormAuthToken}

View file

@ -14,7 +14,7 @@
<a href="https://console.aws.amazon.com/iam/home">
IAM Management Console.
<p>
<form .form-horizontal enctype=#{enctype}>
<form method="post" .form-horizontal enctype=#{enctype}>
<fieldset>
^{form}
^{webAppFormAuthToken}

View file

@ -6,7 +6,7 @@
<a href="#{url}">
#{url}
<p>
<form .form-horizontal enctype=#{enctype}>
<form method="post" .form-horizontal enctype=#{enctype}>
<fieldset>
^{form}
^{webAppFormAuthToken}

View file

@ -3,5 +3,5 @@
Add another local repository
<p>
Where do you want to put this new repository?
<form .form-inline enctype=#{enctype}>
<form method="post" .form-inline enctype=#{enctype}>
^{form}

View file

@ -10,5 +10,5 @@
Files in this repository will managed by git-annex, #
and kept in sync with your repositories on other devices.
<p>
<form .form-inline enctype=#{enctype}>
<form method="post" .form-inline enctype=#{enctype}>
^{form}

View file

@ -26,7 +26,7 @@
<div .alert .alert-error>
<i .icon-warning-sign></i> #{problem}
<p>
<form .form-horizontal enctype=#{enctype}>
<form method="post" .form-horizontal enctype=#{enctype}>
<fieldset>
^{form}
^{webAppFormAuthToken}

View file

@ -2,7 +2,7 @@
<h2>
Preferences
<p>
<form .form-horizontal enctype=#{enctype}>
<form method="post" .form-horizontal enctype=#{enctype}>
<fieldset>
^{form}
^{webAppFormAuthToken}

View file

@ -13,7 +13,7 @@
<i .icon-warning-sign></i> #{msg}
$of _
<p>
<form .form-horizontal enctype=#{enctype}>
<form method="post" .form-horizontal enctype=#{enctype}>
<fieldset>
^{form}
^{webAppFormAuthToken}

View file

@ -7,7 +7,7 @@
usable here.
<p>
<p>
<form .form-horizontal enctype=#{enctype}>
<form method="post" .form-horizontal enctype=#{enctype}>
<fieldset>
<div .form-actions>
<button .btn .btn-primary type=submit onclick="$('#testmodal').modal('show');">

View file

@ -18,7 +18,7 @@
<small>(<tt>you@gmail.com</tt>)</small> #
and password below.
<p>
<form .form-horizontal enctype=#{enctype}>
<form method="post" .form-horizontal enctype=#{enctype}>
<fieldset>
^{form}
^{webAppFormAuthToken}