07494cbb4b
Currently relies on SRV being set, or the JID's hostname being the server hostname and the port being default. Future work: Allow manual configuration of user name, hostname, and port.
100 lines
2.6 KiB
Haskell
100 lines
2.6 KiB
Haskell
{- git-annex assistant XMPP configuration
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings #-}
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Assistant.WebApp.Configurators.XMPP where
|
|
|
|
import Assistant.WebApp
|
|
import Assistant.WebApp.Types
|
|
import Assistant.WebApp.SideBar
|
|
import Utility.Yesod
|
|
#ifdef WITH_XMPP
|
|
import Assistant.Common
|
|
import Assistant.Threads.PushNotifier
|
|
import Utility.SRV
|
|
#endif
|
|
|
|
import Yesod
|
|
#ifdef WITH_XMPP
|
|
import Network
|
|
import Network.Protocol.XMPP
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
#endif
|
|
|
|
getXMPPR :: Handler RepHtml
|
|
#ifdef WITH_XMPP
|
|
getXMPPR = xmppPage $ do
|
|
((result, form), enctype) <- lift $
|
|
runFormGet $ renderBootstrap $ xmppAForm Nothing
|
|
let showform problem = do
|
|
let authtoken = webAppFormAuthToken
|
|
$(widgetFile "configurators/xmpp")
|
|
case result of
|
|
FormSuccess f -> maybe (showform True) (lift . storecreds)
|
|
=<< liftIO (validateForm f)
|
|
_ -> showform False
|
|
where
|
|
storecreds = error "TODO store"
|
|
#else
|
|
getXMPPR = xmppPage $
|
|
$(widgetFile "configurators/xmpp/disabled")
|
|
#endif
|
|
|
|
#ifdef WITH_XMPP
|
|
|
|
data XMPPForm = XMPPForm
|
|
{ formJID :: Text
|
|
, formPassword :: Text }
|
|
|
|
xmppAForm :: (Maybe XMPPForm) -> AForm WebApp WebApp XMPPForm
|
|
xmppAForm def = XMPPForm
|
|
<$> areq jidField "Jabber address" (formJID <$> def)
|
|
<*> areq passwordField "Password" Nothing
|
|
|
|
jidField :: Field WebApp WebApp Text
|
|
jidField = checkBool (isJust . parseJID) bad textField
|
|
where
|
|
bad :: Text
|
|
bad = "This should look like an email address.."
|
|
|
|
validateForm :: XMPPForm -> IO (Maybe XMPPCreds)
|
|
validateForm f = do
|
|
let jid = fromMaybe (error "bad JID") $ parseJID (formJID f)
|
|
let domain = T.unpack $ strDomain $ jidDomain jid
|
|
hostports <- lookupSRV $ mkSRVTcp "xmpp-client" domain
|
|
let username = fromMaybe "" (strNode <$> jidNode jid)
|
|
case hostports of
|
|
((h, PortNumber p):_) -> testXMPP $ XMPPCreds
|
|
{ xmppUsername = username
|
|
, xmppPassword = formPassword f
|
|
, xmppHostname = h
|
|
, xmppPort = fromIntegral p
|
|
, xmppJID = formJID f
|
|
}
|
|
_ -> testXMPP $ XMPPCreds
|
|
{ xmppUsername = username
|
|
, xmppPassword = formPassword f
|
|
, xmppHostname = T.unpack $ strDomain $ jidDomain jid
|
|
, xmppPort = 5222
|
|
, xmppJID = formJID f
|
|
}
|
|
|
|
testXMPP :: XMPPCreds -> IO (Maybe XMPPCreds)
|
|
testXMPP creds = either (const $ return Nothing)
|
|
(const $ return $ Just creds)
|
|
=<< connectXMPP creds (const noop)
|
|
|
|
#endif
|
|
|
|
xmppPage :: Widget -> Handler RepHtml
|
|
xmppPage w = bootstrap (Just Config) $ do
|
|
sideBarDisplay
|
|
setTitle "Jabber"
|
|
w
|