module Main (main) where

import Prelude ()
import BasicPrelude
import Network                            (PortID (PortNumber))
import qualified Control.Concurrent.STM   as STM
import qualified Data.XML.Types           as XML
import qualified Network.HTTP.Types       as HTTP
import qualified Network.Protocol.XMPP    as XMPP
import qualified Network.URI              as URI
import qualified Network.Wai              as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Parse        as Wai
import qualified Network.Wai.Util         as Wai
import qualified UnexceptionalIO.Trans    as UIO

import IQManager
import Router
import Util

runClient :: XMPP.JID -> Text -> XMPP.XMPP a -> IO (Either XMPP.Error a)
runClient jid =
	XMPP.runClient server jid jidStrNode
	where
	-- This is right unless there is an SRV record, which we don't check for
	Just jidStrNode = XMPP.strNode <$> XMPP.jidNode jid
	jidStrDomain = XMPP.strDomain $ XMPP.jidDomain jid
	Just domainJid = XMPP.parseJID jidStrDomain
	domainStr = textToString jidStrDomain
	server = XMPP.Server domainJid domainStr (PortNumber 5222)

webPost :: (XMPP.IQ -> IO (Maybe XMPP.IQ)) -> XMPP.JID -> Wai.Application
webPost sendIQ toJid req = (>>=) $ do
	(params, _) <- Wai.parseRequestBodyEx
		Wai.defaultParseRequestBodyOptions Wai.noStoreFileUploads req
	let prompt = fromMaybe mempty $ Wai.queryLookup "prompt" params
	result <- sendIQ $ (XMPP.emptyIQ XMPP.IQSet) {
			XMPP.iqTo = Just toJid,
			XMPP.iqPayload = Just $ XML.Element
				(s"{jabber:iq:gateway}query") [] [
					XML.NodeElement $ mkElement
						(s"{jabber:iq:gateway}prompt")
						prompt
				]
		}
	case result of
		Just iq |
			Just query <- child (s"{jabber:iq:gateway}query") iq,
			[jid] <- fmap (mconcat . XML.elementText) $
			         XML.isNamed (s"{jabber:iq:gateway}jid") =<<
			         XML.elementChildren query ->
				Wai.redirect' HTTP.status303 [] (xmppURI jid)
		_ -> Wai.string HTTP.status400 []
		     "No jabber:iq:gateway available."

xmppURI :: Text -> URI.URI
xmppURI jid = (URI.URI "xmpp:" Nothing (textToString jid) "" "")

css :: Text
css = s"<style>body { font-family: sans-serif; }</style>"

webGetPrompt :: (XMPP.IQ -> IO (Maybe XMPP.IQ)) -> XMPP.JID -> IO Wai.Response
webGetPrompt sendIQ toJid = do
	result <- sendIQ $ (XMPP.emptyIQ XMPP.IQGet) {
			XMPP.iqTo = Just toJid,
			XMPP.iqPayload = Just $
				XML.Element (s"{jabber:iq:gateway}query") [] []
		}
	case result of
		Just iq |
			Just query <- child (s"{jabber:iq:gateway}query") iq,
			[desc] <- fmap (mconcat . XML.elementText) $
			          XML.isNamed (s"{jabber:iq:gateway}desc") =<<
			          XML.elementChildren query,
			[prompt] <- fmap (mconcat . XML.elementText) $
			            XML.isNamed (s"{jabber:iq:gateway}prompt")
			            =<< XML.elementChildren query ->
				Wai.text HTTP.status200 (Wai.stringHeaders' [
					("Content-Type",
					"text/html; charset=utf-8")
				]) $ css ++ s"<form method=\"post\" action=\"\">\
				\<p>" ++ escapeXML desc ++ s"</p>\
				\<input type=\"text\" name=\"prompt\" \
				\placeholder=\"" ++ escapeXML prompt ++ s"\" />\
				\ <button type=\"submit\">Add Contact</button>\
				\</form>"
		_ -> Wai.string HTTP.status400 []
		     "No jabber:iq:gateway available."

web :: (XMPP.IQ -> IO (Maybe XMPP.IQ)) -> Wai.Application
web sendIQ req
	| method == HTTP.methodPost, Just toJid <- to =
		webPost sendIQ toJid req
	| method == HTTP.methodGet, Just toJid <- to =
		(>>=) $ webGetPrompt sendIQ toJid
	| otherwise = (>>=) $
		Wai.text HTTP.status200
		(Wai.stringHeaders' [
			("Content-Type", "text/html; charset=utf-8")
		])
		(css ++ s"<form method=\"get\" action=\"\">\
		\<input type=\"text\" name=\"to\"\
			\placeholder=\"JabberID to query\" />\
		\ <button type=\"submit\">Begin</button>\
		\</form>")

	where
	method = Wai.requestMethod req
	to = XMPP.parseJID =<< Wai.queryLookup "to" (Wai.queryString req)

main :: IO ()
main = do
	[rpcJidStr, rpcPassword] <- getArgs
	let Just rpcJid = XMPP.parseJID rpcJidStr
	sendIQChan <- atomicUIO STM.newTChan

	void $ UIO.fork $ do
		fmap (either (error . show) (const ())) $ fromIO_ $ runClient rpcJid rpcPassword $ do
			void $ XMPP.bindJID rpcJid
			(sendIQ, iqReceived) <- iqManager
			void $ forkXMPP $ runRouted $ defaultRoutes {
					iqResultRoute = iqReceived,
					iqErrorRoute = iqReceived
				}
			forever $ do
				(iq, rvar) <- atomicUIO $
					STM.readTChan sendIQChan
				result <- sendIQ iq
				atomicUIO $ STM.putTMVar rvar result
		return ()

	Warp.runEnv 3000 $ web $ \iq -> do
		rvar <- atomicUIO STM.newEmptyTMVar
		atomicUIO $ STM.writeTChan sendIQChan (iq, rvar)
		atomicUIO $ join $ STM.takeTMVar rvar