module Session where

import Prelude ()
import BasicPrelude
import Control.Applicative (many)
import qualified Data.Attoparsec.Text  as Atto hiding (Parser)
import qualified Data.Attoparsec.Internal.Types as Atto
import qualified Data.Text             as T
import qualified Database.SQLite.Simple as DB
import qualified Data.XML.Types        as XML
import qualified Network.Protocol.XMPP as XMPP

import qualified Config
import Util

cleanOld :: Config.Config -> XMPP.JID -> XMPP.XMPP ()
cleanOld config source = do
	old <- liftIO $ DB.query (Config.db config)
		(s"SELECT target_muc, target_nick, source_nick FROM sessions WHERE version < ? AND source_muc = ?")
		(Config.dbVersion config, bareTxt source)
	forM_ old $ \(muc, nick, source_nick) ->
		let Just target = XMPP.parseJID $ muc  ++ s"/" ++ nick in
		sendPresence config ((XMPP.emptyPresence XMPP.PresenceUnavailable) {
			XMPP.presenceFrom = XMPP.parseJID $ bareTxt source ++ s"/" ++ source_nick
		}) target

mkSession :: (MonadIO m) =>
	   Config.Config
	-> XMPP.PresenceType
	-> Maybe XMPP.JID
	-> XMPP.JID
	-> m ()
mkSession config typ source target
	| typ == XMPP.PresenceUnavailable =
		liftIO $ DB.execute (Config.db config)
			(s"DELETE FROM sessions WHERE source_muc=? AND source_nick=? AND target_muc=? AND target_nick=?")
			(sourceMuc, sourceNick, targetMuc, targetNick)
	| otherwise =
		liftIO $ DB.execute (Config.db config)
			(s"INSERT INTO sessions VALUES (?,?,?,?,?) ON CONFLICT(source_muc,source_nick,target_muc,target_nick) DO UPDATE SET version=?")
			(
				sourceMuc, sourceNick, targetMuc, targetNick,
				Config.dbVersion config, Config.dbVersion config
			)
	where
	sourceMuc = fromMaybe mempty (bareTxt <$> source)
	sourceNick = fromMaybe mempty (XMPP.strResource <$> (XMPP.jidResource =<< source))
	targetMuc = bareTxt target
	targetNick = fromMaybe mempty (XMPP.strResource <$> XMPP.jidResource target)

maybeAddNick :: XMPP.JID -> Text -> XMPP.JID
maybeAddNick jid@XMPP.JID { XMPP.jidResource = Just _ } _ = jid
maybeAddNick muc nick = jid
	where
	Just jid = XMPP.parseJID $ bareTxt muc ++ s"/" ++ nick

sendPresence :: Config.Config -> XMPP.Presence -> XMPP.JID -> XMPP.XMPP ()
sendPresence config presence targetMuc =
	sendPresenceToMUC config presence
		(Config.MUC targetMuc (s"XMPP") Nothing Nothing) (s"XMPP")

isGhost :: (MonadIO m) => Config.Config -> XMPP.JID -> m Bool
isGhost config from = do
	ghost <- liftIO $ DB.query (Config.db config)
		(s"SELECT COUNT(1) FROM sessions WHERE target_muc = ? AND target_nick = ? LIMIT 1")
		(bareTxt from, nick)
	return (ghost /= [DB.Only (0::Int)])
	where
	nick = fromMaybe mempty $ XMPP.strResource <$> XMPP.jidResource from

sendPresenceToMUC :: Config.Config -> XMPP.Presence -> Config.MUC -> Text -> XMPP.XMPP ()
sendPresenceToMUC config presence@XMPP.Presence {
	XMPP.presenceFrom = Just from@XMPP.JID {
		XMPP.jidResource = Just fromResource
	},
	XMPP.presenceType = typ,
	XMPP.presencePayloads = payloads
} targetMuc tag = do
	ghost <- isGhost config from
	when (not ghost) $ do
		mkSession config typ (Just from) target

		XMPP.putStanza $ presence {
				XMPP.presenceFrom = Just (proxyJid config from),
				XMPP.presenceTo = Just target,
				XMPP.presencePayloads = map (\payload ->
					case XML.isNamed (s"{http://jabber.org/protocol/muc#user}x") payload of
						[_] -> mucJoinX
						_ -> payload
				) payloads
			}
	where
	nickReplacement = maybe id replaceNotInClass (Config.nickChars targetMuc)
	target = maybeAddNick (Config.jid targetMuc) $ nickReplacement $
		(maybeTruncate nickLength fromNick) ++ subscript
	subscript = s"[" ++ tag ++ s"]"
	nickLength = fmap (subtract 2 . subtract (T.length tag) . fromIntegral) $
		Config.nickLength targetMuc
	fromNick = XMPP.strResource fromResource
sendPresenceToMUC _ _ _ _ = return ()

startOfInput :: Atto.Parser t ()
startOfInput = Atto.Parser $ \t pos more lose suc ->
	if pos == 0 then
		suc t pos more ()
	else
		lose t pos more [] "startOfInput"

maybeTruncate :: Maybe Int -> Text -> Text
maybeTruncate Nothing t = t
maybeTruncate (Just l) t = T.take l t

replaceNotInClass :: String -> Text -> Text
replaceNotInClass klass txt = mconcat result
	where
	Right result = Atto.parseOnly (many (
			Atto.takeWhile1 (Atto.inClass klass) <|>
			(Atto.takeWhile1 (Atto.notInClass klass) *> pure (s"_"))
		) <* Atto.endOfInput) txt

replaceWords :: [(Text, Text)] -> Text -> Text
replaceWords replacements txt = mconcat result
	where
	wordClass = "A-Za-z0-9_"
	boundary =
		(startOfInput *> pure mempty) <|>
		(Atto.endOfInput *> pure mempty) <|>
		(T.singleton <$> Atto.satisfy (Atto.notInClass wordClass))
	replacement word newWord = mconcat <$> (
		(:) <$> boundary <*> (
			(:) <$> (Atto.string word *> pure newWord) <*>
			((:) <$> boundary <*> pure [])
		))
	Right result = Atto.parseOnly (many (
			foldr (<|>) (T.singleton <$> Atto.anyChar) (uncurry replacement <$> replacements)
		) <* Atto.endOfInput) txt

sendGroupChat :: Config.Config -> XMPP.Message -> XMPP.JID -> XMPP.XMPP ()
sendGroupChat config message@XMPP.Message {
	XMPP.messageFrom = Just from,
	XMPP.messagePayloads = payloads
} target = do
		nickSwaps1 <- liftIO $ DB.query (Config.db config) (s"SELECT target_nick, source_nick FROM sessions WHERE source_muc=?") (DB.Only $ bareTxt target)
		nickSwaps2 <- liftIO $ DB.query (Config.db config) (s"SELECT source_nick, target_nick FROM sessions WHERE target_muc=? AND source_muc <> ''") (DB.Only $ bareTxt target)
		let nickSwap = replaceWords (nickSwaps1 ++ nickSwaps2)
		XMPP.putStanza $ message {
			XMPP.messageFrom = Just (proxyJid config from),
			XMPP.messageTo = Just target,
			XMPP.messagePayloads = map (\el ->
				case XML.isNamed (s"{jabber:component:accept}body") el of
					[body] ->
						body { XML.elementNodes = [
							XML.NodeContent $ XML.ContentText $
								nickSwap (mconcat (XML.elementText body))
						]}
					_ -> el
			) payloads
		}
sendGroupChat _ _ _ = return ()