XMPP configuration form
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.
This commit is contained in:
Joey Hess
parent
a11fb94c65
commit
07494cbb4b
8 changed files with 130 additions and 16 deletions
|
|
@ -35,8 +35,7 @@ pushNotifierThread :: ThreadState -> DaemonStatusHandle -> PushNotifier -> Named
|
|||
pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $ do
|
||||
v <- runThreadState st $ getXMPPCreds
|
||||
case v of
|
||||
Nothing -> do
|
||||
return () -- no creds? exit thread
|
||||
Nothing -> return () -- no creds? exit thread
|
||||
Just c -> void $ connectXMPP c $ \jid -> do
|
||||
fulljid <- bindJID jid
|
||||
liftIO $ debug thisThread ["XMPP connected", show fulljid]
|
||||
|
|
@ -83,7 +82,8 @@ connectXMPP c a = case parseJID (xmppJID c) of
|
|||
connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO (Either SomeException ())
|
||||
connectXMPP' jid c a = go =<< lookupSRV srvrecord
|
||||
where
|
||||
srvrecord = mkSRVTcp "xmpp-client" (T.unpack $ strDomain $ jidDomain jid)
|
||||
srvrecord = mkSRVTcp "xmpp-client" $
|
||||
T.unpack $ strDomain $ jidDomain jid
|
||||
serverjid = JID Nothing (jidDomain jid) Nothing
|
||||
|
||||
go [] = run (xmppHostname c)
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ import Assistant.WebApp.Configurators.Pairing
|
|||
#ifdef WITH_S3
|
||||
import Assistant.WebApp.Configurators.S3
|
||||
#endif
|
||||
import Assistant.WebApp.Configurators.XMPP
|
||||
import Assistant.WebApp.Documentation
|
||||
import Assistant.WebApp.OtherRepos
|
||||
import Assistant.ThreadedMonad
|
||||
|
|
|
|||
100
Assistant/WebApp/Configurators/XMPP.hs
Normal file
100
Assistant/WebApp/Configurators/XMPP.hs
Normal file
|
|
@ -0,0 +1,100 @@
|
|||
{- 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
|
||||
|
|
@ -6,6 +6,7 @@
|
|||
|
||||
/config ConfigR GET
|
||||
/config/repository RepositoriesR GET
|
||||
/config/xmpp XMPPR GET
|
||||
|
||||
/config/repository/new/first FirstRepositoryR GET
|
||||
/config/repository/new NewRepositoryR GET
|
||||
|
|
|
|||
|
|
@ -33,12 +33,13 @@ import Data.Either
|
|||
#endif
|
||||
|
||||
newtype SRV = SRV String
|
||||
deriving (Show, Eq)
|
||||
|
||||
type HostPort = (HostName, PortID)
|
||||
|
||||
mkSRV :: String -> String -> HostName -> SRV
|
||||
mkSRV transport protocol host = SRV $ concat
|
||||
["_", protocol, ".", transport, ".", host]
|
||||
["_", protocol, "._", transport, ".", host]
|
||||
|
||||
mkSRVTcp :: String -> HostName -> SRV
|
||||
mkSRVTcp = mkSRV "tcp"
|
||||
|
|
|
|||
|
|
@ -7,3 +7,10 @@
|
|||
<p>
|
||||
Distribute the files in this repository to other devices, #
|
||||
make backups, and more, by adding repositories.
|
||||
<div .span4>
|
||||
<h3>
|
||||
<a href="@{XMPPR}">
|
||||
Configure jabber account
|
||||
<p>
|
||||
Allow devices that are not in direct contact to keep in touch, #
|
||||
by configuring a jabber account.
|
||||
|
|
|
|||
|
|
@ -2,22 +2,21 @@
|
|||
<h2>
|
||||
Configuring jabber account
|
||||
<p>
|
||||
A jabber account is used by git-annex to communicate changes between #
|
||||
repositories. It can also be used to pair up with a friend's repository, #
|
||||
if you want to. It's fine to reuse an existing account; git-annex won't #
|
||||
A jabber account is used to communicate between #
|
||||
devices that are not in direct contact. #
|
||||
It can also be used to pair up with a friend's repository, if desired.
|
||||
<p>
|
||||
It's fine to reuse an existing jabber account; git-annex won't #
|
||||
post any messages to it.
|
||||
<p>
|
||||
<i .icon-info-sign></I> If you have a Gmail account, you can use #
|
||||
Google Talk. Just enter your full Gmail address (<tt>you@gmail.com</tt>) #
|
||||
and password below.
|
||||
$if needserver
|
||||
<p>
|
||||
<i .icon-warning-sign></i> Unable to find a Jabber server for #
|
||||
<tt>#{jid}</tt>. Please enter the server name and port below.
|
||||
$if connectfail
|
||||
<p>
|
||||
$if problem
|
||||
<i .icon-warning-sign></i> Unable to connect to the Jabber server. #
|
||||
Maybe you entered the wrong password?
|
||||
$else
|
||||
<i .icon-user></I> If you have a Gmail account, you can use #
|
||||
Google Talk. Just enter your full Gmail address #
|
||||
<small>(<tt>you@gmail.com</tt>)</small> #
|
||||
and password below.
|
||||
<p>
|
||||
<form .form-horizontal enctype=#{enctype}>
|
||||
<fieldset>
|
||||
|
|
|
|||
5
templates/configurators/xmpp/disabled.hamlet
Normal file
5
templates/configurators/xmpp/disabled.hamlet
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
<div .span9 .hero-unit>
|
||||
<h2>
|
||||
Jabber not supported
|
||||
<p>
|
||||
This build of git-annex does not support Jabber. Sorry!
|
||||
Loading…
Add table
Reference in a new issue