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.

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
+		Nothing -> return () -- no creds? exit thread
-			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)

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

Assistant/WebApp/Configurators/XMPP.hs

@@ -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

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

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"

templates/configurators/main.hamlet

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

templates/configurators/xmpp.hamlet

@@ -2,22 +2,21 @@
   <h2>
     Configuring jabber account
   <p>
-    A jabber account is used by git-annex to communicate changes between #
+    A jabber account is used to communicate between #
-    repositories. It can also be used to pair up with a friend's repository, #
+    devices that are not in direct contact. #
-    if you want to. It's fine to reuse an existing account; git-annex won't #
+    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 #
+    $if problem
-    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>
       <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>

templates/configurators/xmpp/disabled.hamlet

@@ -0,0 +1,5 @@
+<div .span9 .hero-unit>
+  <h2>
+    Jabber not supported
+  <p>
+    This build of git-annex does not support Jabber. Sorry!