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

store xmpp creds from form

Browse source
This commit is contained in:
Joey Hess 2012-10-26 17:13:30 -04:00
parent 1d04dff4f0
commit 6803667f00
3 changed files with 26 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Assistant/WebApp/Configurators.hs
View file

@ -16,6 +16,7 @@ import Assistant.WebApp.SideBar
import Assistant.WebApp.Utility import Assistant.WebApp.Utility
import Assistant.WebApp.Configurators.Local import Assistant.WebApp.Configurators.Local
import Assistant.DaemonStatus import Assistant.DaemonStatus
import Assistant.XMPP
import Utility.Yesod import Utility.Yesod
import qualified Remote import qualified Remote
import qualified Types.Remote as Remote import qualified Types.Remote as Remote
@ -33,6 +34,7 @@ getConfigR :: Handler RepHtml
getConfigR = ifM (inFirstRun) getConfigR = ifM (inFirstRun)
( getFirstRepositoryR ( getFirstRepositoryR
, bootstrap (Just Config) $ do , bootstrap (Just Config) $ do
xmppconfigured <- lift $ runAnnex False $ isJust <$> getXMPPCreds
sideBarDisplay sideBarDisplay
setTitle "Configuration" setTitle "Configuration"
$(widgetFile "configurators/main") $(widgetFile "configurators/main")

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

@ -31,8 +31,10 @@ import qualified Data.Text as T
getXMPPR :: Handler RepHtml getXMPPR :: Handler RepHtml
#ifdef WITH_XMPP #ifdef WITH_XMPP
getXMPPR = xmppPage $ do getXMPPR = xmppPage $ do
((result, form), enctype) <- lift $ ((result, form), enctype) <- lift $ do
runFormGet $ renderBootstrap $ xmppAForm Nothing oldcreds <- runAnnex Nothing getXMPPCreds
runFormGet $ renderBootstrap $ xmppAForm $
creds2Form <$> oldcreds
let showform problem = do let showform problem = do
let authtoken = webAppFormAuthToken let authtoken = webAppFormAuthToken
$(widgetFile "configurators/xmpp") $(widgetFile "configurators/xmpp")
@ -41,7 +43,9 @@ getXMPPR = xmppPage $ do
=<< liftIO (validateForm f) =<< liftIO (validateForm f)
_ -> showform False _ -> showform False
where where
storecreds = error "TODO store" storecreds creds = do
void $ runAnnex undefined $ setXMPPCreds creds
redirect ConfigR
#else #else
getXMPPR = xmppPage $ getXMPPR = xmppPage $
$(widgetFile "configurators/xmpp/disabled") $(widgetFile "configurators/xmpp/disabled")
@ -53,6 +57,9 @@ data XMPPForm = XMPPForm
{ formJID :: Text { formJID :: Text
, formPassword :: Text } , formPassword :: Text }
creds2Form :: XMPPCreds -> XMPPForm
creds2Form c = XMPPForm (xmppJID c) (xmppPassword c)
xmppAForm :: (Maybe XMPPForm) -> AForm WebApp WebApp XMPPForm xmppAForm :: (Maybe XMPPForm) -> AForm WebApp WebApp XMPPForm
xmppAForm def = XMPPForm xmppAForm def = XMPPForm
<$> areq jidField "Jabber address" (formJID <$> def) <$> areq jidField "Jabber address" (formJID <$> def)

20
templates/configurators/main.hamlet
View file

@ -8,9 +8,17 @@
Distribute the files in this repository to other devices, # Distribute the files in this repository to other devices, #
make backups, and more, by adding repositories. make backups, and more, by adding repositories.
<div .span4> <div .span4>
<h3> $if xmppconfigured
<a href="@{XMPPR}"> <h3>
Configure jabber account <a href="@{XMPPR}">
<p> Re-configure jabber account
Allow devices that are not in direct contact to keep in touch, # <p>
by configuring a jabber account. Your jabber account is set up, and will be used to keep #
in touch with remote devices, and with your friends.
$else
<h3>
<a href="@{XMPPR}">
Configure jabber account
<p>
Keep in touch with remote devices, and with your friends, #
by configuring a jabber account.