diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs index 0686aac7b7..4ba8d677b4 100644 --- a/Assistant/Threads/PushNotifier.hs +++ b/Assistant/Threads/PushNotifier.hs @@ -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) diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index c33dc21036..5eda88d369 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -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 diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs new file mode 100644 index 0000000000..6b38caeae2 --- /dev/null +++ b/Assistant/WebApp/Configurators/XMPP.hs @@ -0,0 +1,100 @@ +{- git-annex assistant XMPP configuration + - + - Copyright 2012 Joey Hess + - + - 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 diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 0991f221de..b9885f9e5c 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -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 diff --git a/Utility/SRV.hs b/Utility/SRV.hs index 38ac287870..4f2db680b5 100644 --- a/Utility/SRV.hs +++ b/Utility/SRV.hs @@ -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" diff --git a/templates/configurators/main.hamlet b/templates/configurators/main.hamlet index b0fdcc2820..134e56f598 100644 --- a/templates/configurators/main.hamlet +++ b/templates/configurators/main.hamlet @@ -7,3 +7,10 @@

Distribute the files in this repository to other devices, # make backups, and more, by adding repositories. +

+

+ + Configure jabber account +

+ Allow devices that are not in direct contact to keep in touch, # + by configuring a jabber account. diff --git a/templates/configurators/xmpp.hamlet b/templates/configurators/xmpp.hamlet index 564b161ed4..f8388bba61 100644 --- a/templates/configurators/xmpp.hamlet +++ b/templates/configurators/xmpp.hamlet @@ -2,22 +2,21 @@

Configuring jabber account

- 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. +

+ It's fine to reuse an existing jabber account; git-annex won't # post any messages to it.

- If you have a Gmail account, you can use # - Google Talk. Just enter your full Gmail address (you@gmail.com) # - and password below. - $if needserver -

- Unable to find a Jabber server for # - #{jid}. Please enter the server name and port below. - $if connectfail -

+ $if problem Unable to connect to the Jabber server. # Maybe you entered the wrong password? + $else + If you have a Gmail account, you can use # + Google Talk. Just enter your full Gmail address # + (you@gmail.com) # + and password below.

diff --git a/templates/configurators/xmpp/disabled.hamlet b/templates/configurators/xmpp/disabled.hamlet new file mode 100644 index 0000000000..2f28b96340 --- /dev/null +++ b/templates/configurators/xmpp/disabled.hamlet @@ -0,0 +1,5 @@ +
+

+ Jabber not supported +

+ This build of git-annex does not support Jabber. Sorry!