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

switch to runFormPostNoToken to work around strange yesod bug

Browse source 
I am not happy about disabling yesod's XSRF tokens, but the webapp has two
guards of its own that should suffice: Listening only to localhost
(normally) and requiring its own auth token on every single request
(always).
This commit is contained in:
Joey Hess 2013-10-14 12:19:11 -04:00
parent ce2f461ec7
commit 267f8b0bb5
11 changed files with 20 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -121,7 +121,7 @@ postAddS3R :: Handler Html
postAddS3R = awsConfigurator $ do postAddS3R = awsConfigurator $ do
defcreds <- liftAnnex previouslyUsedAWSCreds defcreds <- liftAnnex previouslyUsedAWSCreds
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ s3InputAForm defcreds runFormPostNoToken $ renderBootstrap $ s3InputAForm defcreds
case result of case result of
FormSuccess input -> liftH $ do FormSuccess input -> liftH $ do
let name = T.unpack $ repoName input let name = T.unpack $ repoName input
@ -144,7 +144,7 @@ postAddGlacierR :: Handler Html
postAddGlacierR = glacierConfigurator $ do postAddGlacierR = glacierConfigurator $ do
defcreds <- liftAnnex previouslyUsedAWSCreds defcreds <- liftAnnex previouslyUsedAWSCreds
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ glacierInputAForm defcreds runFormPostNoToken $ renderBootstrap $ glacierInputAForm defcreds
case result of case result of
FormSuccess input -> liftH $ do FormSuccess input -> liftH $ do
let name = T.unpack $ repoName input let name = T.unpack $ repoName input
@ -187,7 +187,7 @@ enableAWSRemote :: RemoteType -> UUID -> Widget
enableAWSRemote remotetype uuid = do enableAWSRemote remotetype uuid = do
defcreds <- liftAnnex previouslyUsedAWSCreds defcreds <- liftAnnex previouslyUsedAWSCreds
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ awsCredsAForm defcreds runFormPostNoToken $ renderBootstrap $ awsCredsAForm defcreds
case result of case result of
FormSuccess creds -> liftH $ do FormSuccess creds -> liftH $ do
m <- liftAnnex readRemoteLog m <- liftAnnex readRemoteLog

2
Assistant/WebApp/Configurators/Delete.hs
View file

@ -81,7 +81,7 @@ deleteCurrentRepository = dangerPage $ do
havegitremotes <- haveremotes syncGitRemotes havegitremotes <- haveremotes syncGitRemotes
havedataremotes <- haveremotes syncDataRemotes havedataremotes <- haveremotes syncDataRemotes
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ sanityVerifierAForm $ runFormPostNoToken $ renderBootstrap $ sanityVerifierAForm $
SanityVerifier magicphrase SanityVerifier magicphrase
case result of case result of
FormSuccess _ -> liftH $ do FormSuccess _ -> liftH $ do

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

@ -181,7 +181,7 @@ editForm new uuid = page "Edit repository" (Just Configuration) $ do
curr <- liftAnnex $ getRepoConfig uuid mremote curr <- liftAnnex $ getRepoConfig uuid mremote
liftAnnex $ checkAssociatedDirectory curr mremote liftAnnex $ checkAssociatedDirectory curr mremote
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ editRepositoryAForm (isNothing mremote) curr runFormPostNoToken $ renderBootstrap $ editRepositoryAForm (isNothing mremote) curr
case result of case result of
FormSuccess input -> liftH $ do FormSuccess input -> liftH $ do
setRepoConfig uuid mremote curr input setRepoConfig uuid mremote curr input

4
Assistant/WebApp/Configurators/IA.hs
View file

@ -126,7 +126,7 @@ postAddIAR :: Handler Html
postAddIAR = iaConfigurator $ do postAddIAR = iaConfigurator $ do
defcreds <- liftAnnex previouslyUsedIACreds defcreds <- liftAnnex previouslyUsedIACreds
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ iaInputAForm defcreds runFormPostNoToken $ renderBootstrap $ iaInputAForm defcreds
case result of case result of
FormSuccess input -> liftH $ do FormSuccess input -> liftH $ do
let name = escapeBucket $ T.unpack $ itemName input let name = escapeBucket $ T.unpack $ itemName input
@ -165,7 +165,7 @@ enableIARemote :: UUID -> Widget
enableIARemote uuid = do enableIARemote uuid = do
defcreds <- liftAnnex previouslyUsedIACreds defcreds <- liftAnnex previouslyUsedIACreds
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ iaCredsAForm defcreds runFormPostNoToken $ renderBootstrap $ iaCredsAForm defcreds
case result of case result of
FormSuccess creds -> liftH $ do FormSuccess creds -> liftH $ do
m <- liftAnnex readRemoteLog m <- liftAnnex readRemoteLog

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

@ -155,7 +155,7 @@ postFirstRepositoryR = page "Getting started" (Just Configuration) $ do
let androidspecial = False let androidspecial = False
path <- liftIO . defaultRepositoryPath =<< liftH inFirstRun path <- liftIO . defaultRepositoryPath =<< liftH inFirstRun
#endif #endif
((res, form), enctype) <- liftH $ runFormPost $ newRepositoryForm path ((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm path
case res of case res of
FormSuccess (RepositoryPath p) -> liftH $ FormSuccess (RepositoryPath p) -> liftH $
startFullAssistant (T.unpack p) ClientGroup Nothing startFullAssistant (T.unpack p) ClientGroup Nothing
@ -178,7 +178,7 @@ getNewRepositoryR = postNewRepositoryR
postNewRepositoryR :: Handler Html postNewRepositoryR :: Handler Html
postNewRepositoryR = page "Add another repository" (Just Configuration) $ do postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
home <- liftIO myHomeDir home <- liftIO myHomeDir
((res, form), enctype) <- liftH $ runFormPost $ newRepositoryForm home ((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm home
case res of case res of
FormSuccess (RepositoryPath p) -> do FormSuccess (RepositoryPath p) -> do
let path = T.unpack p let path = T.unpack p
@ -233,7 +233,7 @@ postAddDriveR = page "Add a removable drive" (Just Configuration) $ do
removabledrives <- liftIO driveList removabledrives <- liftIO driveList
writabledrives <- liftIO $ writabledrives <- liftIO $
filterM (canWrite . T.unpack . mountPoint) removabledrives filterM (canWrite . T.unpack . mountPoint) removabledrives
((res, form), enctype) <- liftH $ runFormPost $ ((res, form), enctype) <- liftH $ runFormPostNoToken $
selectDriveForm (sort writabledrives) selectDriveForm (sort writabledrives)
case res of case res of
FormSuccess drive -> liftH $ redirect $ ConfirmAddDriveR drive FormSuccess drive -> liftH $ redirect $ ConfirmAddDriveR drive

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

@ -265,7 +265,7 @@ data InputSecret = InputSecret { secretText :: Maybe Text }
promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler Html promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler Html
promptSecret msg cont = pairPage $ do promptSecret msg cont = pairPage $ do
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ runFormPostNoToken $ renderBootstrap $
InputSecret <$> aopt textField "Secret phrase" Nothing InputSecret <$> aopt textField "Secret phrase" Nothing
case result of case result of
FormSuccess v -> do FormSuccess v -> do

2
Assistant/WebApp/Configurators/Preferences.hs
View file

@ -90,7 +90,7 @@ postPreferencesR :: Handler Html
postPreferencesR = page "Preferences" (Just Configuration) $ do postPreferencesR = page "Preferences" (Just Configuration) $ do
((result, form), enctype) <- liftH $ do ((result, form), enctype) <- liftH $ do
current <- liftAnnex getPrefs current <- liftAnnex getPrefs
runFormPost $ renderBootstrap $ prefsAForm current runFormPostNoToken $ renderBootstrap $ prefsAForm current
case result of case result of
FormSuccess new -> liftH $ do FormSuccess new -> liftH $ do
liftAnnex $ storePrefs new liftAnnex $ storePrefs new

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

@ -116,7 +116,7 @@ postAddSshR :: Handler Html
postAddSshR = sshConfigurator $ do postAddSshR = sshConfigurator $ do
username <- liftIO $ T.pack <$> myUserName username <- liftIO $ T.pack <$> myUserName
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ sshInputAForm textField $ runFormPostNoToken $ renderBootstrap $ sshInputAForm textField $
SshInput Nothing (Just username) Nothing 22 SshInput Nothing (Just username) Nothing 22
case result of case result of
FormSuccess sshinput -> do FormSuccess sshinput -> do
@ -168,7 +168,7 @@ enableSpecialSshRemote getsshinput rsyncnetsetup genericsetup u = do
case (mkSshInput . unmangle <$> getsshinput m, M.lookup "name" m) of case (mkSshInput . unmangle <$> getsshinput m, M.lookup "name" m) of
(Just sshinput, Just reponame) -> sshConfigurator $ do (Just sshinput, Just reponame) -> sshConfigurator $ do
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ sshInputAForm textField sshinput runFormPostNoToken $ renderBootstrap $ sshInputAForm textField sshinput
case result of case result of
FormSuccess sshinput' FormSuccess sshinput'
| isRsyncNet (inputHostname sshinput') -> | isRsyncNet (inputHostname sshinput') ->
@ -413,7 +413,7 @@ getAddRsyncNetR :: Handler Html
getAddRsyncNetR = postAddRsyncNetR getAddRsyncNetR = postAddRsyncNetR
postAddRsyncNetR :: Handler Html postAddRsyncNetR :: Handler Html
postAddRsyncNetR = do postAddRsyncNetR = do
((result, form), enctype) <- runFormPost $ ((result, form), enctype) <- runFormPostNoToken $
renderBootstrap $ sshInputAForm hostnamefield $ renderBootstrap $ sshInputAForm hostnamefield $
SshInput Nothing Nothing Nothing 22 SshInput Nothing Nothing Nothing 22
let showform status = inpage $ let showform status = inpage $

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

@ -67,7 +67,7 @@ postAddBoxComR :: Handler Html
postAddBoxComR = boxConfigurator $ do postAddBoxComR = boxConfigurator $ do
defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com" defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ boxComAForm defcreds runFormPostNoToken $ renderBootstrap $ boxComAForm defcreds
case result of case result of
FormSuccess input -> liftH $ FormSuccess input -> liftH $
makeWebDavRemote initSpecialRemote "box.com" (toCredPair input) $ M.fromList makeWebDavRemote initSpecialRemote "box.com" (toCredPair input) $ M.fromList
@ -110,7 +110,7 @@ postEnableWebDAVR uuid = do
maybe (pure Nothing) previouslyUsedWebDAVCreds $ maybe (pure Nothing) previouslyUsedWebDAVCreds $
urlHost url urlHost url
((result, form), enctype) <- liftH $ ((result, form), enctype) <- liftH $
runFormPost $ renderBootstrap $ webDAVCredsAForm defcreds runFormPostNoToken $ renderBootstrap $ webDAVCredsAForm defcreds
case result of case result of
FormSuccess input -> liftH $ FormSuccess input -> liftH $
makeWebDavRemote enableSpecialRemote name (toCredPair input) M.empty makeWebDavRemote enableSpecialRemote name (toCredPair input) M.empty

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

@ -112,7 +112,7 @@ xmppform :: Route WebApp -> Handler Html
xmppform next = xmppPage $ do xmppform next = xmppPage $ do
((result, form), enctype) <- liftH $ do ((result, form), enctype) <- liftH $ do
oldcreds <- liftAnnex getXMPPCreds oldcreds <- liftAnnex getXMPPCreds
runFormPost $ renderBootstrap $ xmppAForm $ runFormPostNoToken $ renderBootstrap $ xmppAForm $
creds2Form <$> oldcreds creds2Form <$> oldcreds
let showform problem = $(widgetFile "configurators/xmpp") let showform problem = $(widgetFile "configurators/xmpp")
case result of case result of

2
doc/bugs/Assistant_stalls_when_adding__47__creating_repo_on_ArchLinux.mdwn
View file

@ -71,3 +71,5 @@ git-annex: Nothing listed in /home/omehani/.config/git-annex/autostart
# End of transcript or log. # End of transcript or log.
"""]] """]]
> workaround is in place [[done]] --[[Joey]]