module Main (main) where

import Prelude ()
import BasicPrelude
import System.IO
	(stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
import Control.Error                   (exceptT, justZ)
import Control.Concurrent              (threadDelay)
import Control.Concurrent.STM          (STM)
import qualified Database.SQLite.Simple as DB
import qualified Data.Text             as T
import qualified Data.XML.Types        as XML
import qualified Network.Protocol.XMPP as XMPP

import qualified Config
import qualified Session
import Router
import Util
import IQManager

hasMucCode :: Int -> XMPP.Presence -> Bool
hasMucCode code XMPP.Presence { XMPP.presencePayloads = p } =
	elem (tshow code) $
	maybeToList . XML.attributeText (s"code")
	=<< XML.isNamed (s"{http://jabber.org/protocol/muc#user}status")
	=<< XML.elementChildren
	=<< XML.isNamed (s"{http://jabber.org/protocol/muc#user}x") =<< p

fullTargets :: Config.Config -> XMPP.JID -> [(Config.MUC, Text)]
fullTargets config from = concatMap (\bridge ->
		case find ((bareTxt from ==) . bareTxt . Config.jid) bridge of
			Just sourceMuc ->
				map (\muc -> (muc, Config.tag sourceMuc)) $
				filter ((bareTxt from /=) . bareTxt . Config.jid) bridge
			Nothing -> []
	) (Config.mucs config)

targets :: Config.Config -> XMPP.JID -> [XMPP.JID]
targets = map (Config.jid . fst) .: fullTargets

handlePresence :: Config.Config -> XMPP.Presence -> XMPP.XMPP ()
handlePresence config presence@XMPP.Presence {
	XMPP.presenceFrom = Just from,
	XMPP.presenceTo = Just to
}
	| bareTxt to /= bareTxt (Config.bridgeJid config) =
		-- This is to one of our ghosts, so just ignore it
		return ()
	| hasMucCode 110 presence = -- done joining room, clean up old data
		Session.cleanOld config from
	| otherwise = forM_ (fullTargets config from) $
			uncurry $ Session.sendPresenceToMUC config presence
handlePresence _ _ = return ()

handlePresenceError :: Config.Config -> XMPP.Presence -> XMPP.XMPP ()
handlePresenceError config XMPP.Presence {
	XMPP.presenceFrom = Just from@XMPP.JID {
		XMPP.jidResource = Just resource
	},
	XMPP.presenceTo = Just XMPP.JID { XMPP.jidNode = Just node },
	XMPP.presencePayloads = p
} |
	Just originalSource <- XMPP.parseJID $ unescapeJid $ XMPP.strNode node,
	[err] <- XML.isNamed (s"{jabber:component:accept}error") =<< p,
	[_] <- XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}conflict") =<<
		XML.elementChildren err =
			let
				toSend = (mucJoin muc (nick ++ s"_")) {
					XMPP.presenceFrom = Just originalSource
				}
				Just target = XMPP.presenceTo toSend
			in Session.sendPresence config toSend target
	where
	nick = XMPP.strResource resource
	Just muc = XMPP.parseJID $ bareTxt from
handlePresenceError _ _ = return ()

handleGroupChat :: Config.Config -> XMPP.Message -> XMPP.XMPP ()
handleGroupChat config message@XMPP.Message {
	XMPP.messageFrom = Just from,
	XMPP.messageTo = Just to
}
	| bareTxt to /= bareTxt (Config.bridgeJid config) =
		-- This is to one of our ghosts, so just ignore it
		return ()
	| otherwise = forM_ (targets config from) $
		Session.sendGroupChat config message
handleGroupChat _ _ = return ()

handleMessage :: Config.Config -> XMPP.Message -> XMPP.XMPP ()
handleMessage config message@XMPP.Message {
	XMPP.messageFrom = Just from@XMPP.JID { XMPP.jidNode = Just fromNode },
	XMPP.messageTo = Just XMPP.JID { XMPP.jidNode = Just node }
}
	| not $ null $ targets config from =
		XMPP.putStanza $ message {
			XMPP.messageFrom = Just (proxyJid config from),
			XMPP.messageTo = target
		}
	| Just fakeFrom <- maybeFakeFrom =
		XMPP.putStanza $ message {
			XMPP.messageFrom = Just (proxyJid config fakeFrom),
			XMPP.messageTo = target
		}
	where
	target = XMPP.parseJID $ unescapeJid $ XMPP.strNode node
	-- This is basically just for biboumi
	-- If we get a direct message from a non-MUC source
	-- check if there are any MUCs bridged to the given target
	-- with a domain matching the domain of the from
	-- and if so use the localpart (minus any %suffix) as a nick from that source
	maybeFakeFrom = (XMPP.parseJID =<<) $
		fmap ((++ s"/" ++ T.takeWhile (/='%') (XMPP.strNode fromNode)) . bareTxt) $
		find (\source -> XMPP.jidDomain source == XMPP.jidDomain from) $
		targets config =<< justZ target
handleMessage _ _ = return ()

handleIq :: Config.Config -> XMPP.IQ -> XMPP.XMPP ()
handleIq config iq@XMPP.IQ {
	XMPP.iqFrom = Just from@XMPP.JID { XMPP.jidNode = Just _ },
	XMPP.iqTo = Just XMPP.JID { XMPP.jidNode = Just node }
}
	| not $ null $ targets config from =
		XMPP.putStanza $ iq {
			XMPP.iqFrom = Just (proxyJid config from),
			XMPP.iqTo = target
		}
	where
	target = XMPP.parseJID $ unescapeJid $ XMPP.strNode node
handleIq _ _ = return ()

joinFromBridge :: Config.Config -> XMPP.JID -> XMPP.XMPP ()
joinFromBridge config muc = do
	Session.mkSession config XMPP.PresenceAvailable Nothing target
	XMPP.putStanza presence
	where
	Just target = XMPP.presenceTo presence
	presence = (mucJoin muc (Config.nick config)) {
			XMPP.presenceFrom = Just $ Config.bridgeJid config
		}

pingSuccessError :: XML.Element -> [XML.Element]
pingSuccessError = uncurry (<|>) . (uncurry (<|>) . (
	XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavaliable")
	&&&
	XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}feature-not-implemented")
	) &&&
	XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}item-not-found")
	)

selfPings :: Config.Config -> (XMPP.IQ -> XMPP.XMPP (STM (Maybe XMPP.IQ))) -> XMPP.XMPP ()
selfPings config sendIQ = forever $ do
	liftIO $ threadDelay 60000000
	sessions <- liftIO $ DB.query_ (Config.db config) (s"SELECT source_muc, source_nick, target_muc, target_nick FROM sessions")
	forM_ sessions $ \(sourceMuc, sourceNick, targetMuc, targetNick) -> void $ forkXMPP $ do
		let Just target = XMPP.parseJID (targetMuc ++ s"/" ++ targetNick)
		reply <- (atomicUIO =<<) $ sendIQ $ (XMPP.emptyIQ XMPP.IQGet) {
				XMPP.iqFrom = sourceJid sourceMuc sourceNick,
				XMPP.iqTo = Just target,
				XMPP.iqPayload = Just $ XML.Element (s"{urn:xmpp:ping}ping") [] []
			}
		if (XMPP.iqType <$> reply) == Just XMPP.IQResult then return () else
			case pingSuccessError =<< XML.elementChildren =<< justZ (XMPP.iqPayload =<< reply) of
				(_:_) -> return ()
				_ | sourceMuc == mempty -> joinFromBridge config target
				_ ->
					Session.sendPresence config ((mucJoin target targetNick) {
							XMPP.presenceFrom = XMPP.parseJID (sourceMuc ++ s"/" ++ sourceNick)
						}) target
	where
	sourceJid muc nick
		| muc == mempty = Just $ Config.bridgeJid config
		| otherwise = proxyJid config <$> XMPP.parseJID (muc ++ s"/" ++ nick)

main :: IO ()
main = do
	hSetBuffering stdout LineBuffering
	hSetBuffering stderr LineBuffering

	config <- Config.setup =<< fmap head getArgs

	let server = XMPP.Server
		(Config.componentJid config)
		(Config.host $ Config.server config)
		(Config.port $ Config.server config)

	exceptT print return $
		runRoutedComponent server (Config.secret config) $ do
			(sendIQ, iqReceiver) <- iqManager XMPP.putStanza
			forM_ (Config.mucs config) $ mapM_ $ \muc ->
				joinFromBridge config (Config.jid muc)
			void $ forkXMPP $ selfPings config sendIQ
			return $ defaultRoutes {
				presenceRoute = handlePresence config,
				presenceErrorRoute = handlePresenceError config,
				messageGroupChatRoute = handleGroupChat config,
				messageRoute = handleMessage config,
				iqRoute = \iq -> do
					maybeIq <- iqReceiver iq
					forM_ maybeIq $ handleIq config
			}