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