module Util where

import Prelude ()
import BasicPrelude
import Control.Concurrent
	(ThreadId, forkFinally, myThreadId, throwTo)
import Data.Void                       (absurd)
import qualified Control.Exception     as Ex
import qualified Data.XML.Types        as XML
import qualified Network.Protocol.XMPP as XMPP
import           UnexceptionalIO       (Unexceptional)
import qualified UnexceptionalIO       as UIO

newtype JingleSID = JingleSID Text deriving (Show, Ord, Eq)
newtype JingleTSID = JingleTSID Text deriving (Show, Ord, Eq)

s :: (IsString s) => String -> s
s = fromString

fromIO_ :: (Unexceptional m) => IO a -> m a
fromIO_ = fmap (either absurd id) . UIO.fromIO' (error . show)

castException :: (Ex.Exception e1, Ex.Exception e2) => e1 -> Maybe e2
castException = Ex.fromException . Ex.toException

-- Re-throws all by ThreadKilled async to parent thread
-- Makes sync child exceptions async in parent, which is a bit sloppy
forkXMPP :: XMPP.XMPP () -> XMPP.XMPP ThreadId
forkXMPP kid = do
	parent <- liftIO myThreadId
	session <- XMPP.getSession
	liftIO $ forkFinally
		(void $ XMPP.runXMPP session kid)
		(either (handler parent) (const $ return ()))
	where
	handler parent e
		| Just Ex.ThreadKilled <- castException e = return ()
		| otherwise = throwTo parent e

iqReply :: Maybe XML.Element -> XMPP.IQ -> XMPP.IQ
iqReply payload iq = iq {
	XMPP.iqType = XMPP.IQResult,
	XMPP.iqFrom = XMPP.iqTo iq,
	XMPP.iqTo = XMPP.iqFrom iq,
	XMPP.iqPayload = payload
}

iqError :: XML.Element -> XMPP.IQ -> XMPP.IQ
iqError payload iq = (iqReply (Just payload) iq) {
	XMPP.iqType = XMPP.IQError
}

iqNewRequest :: XMPP.IQ -> XMPP.IQType -> Text -> XML.Element -> XMPP.IQ
iqNewRequest iq iqtype iqid payload = (XMPP.emptyIQ iqtype) {
		XMPP.iqTo = XMPP.iqFrom iq,
		XMPP.iqFrom = XMPP.iqTo iq,
		XMPP.iqID = Just iqid,
		XMPP.iqPayload = Just payload
	}

messageError :: XML.Element -> XMPP.Message -> XMPP.Message
messageError payload message = message {
	XMPP.messageType = XMPP.MessageError,
	XMPP.messageFrom = XMPP.messageTo message,
	XMPP.messageTo = XMPP.messageFrom message,
	XMPP.messagePayloads = payload : XMPP.messagePayloads message
}

notImplemented :: XML.Element
notImplemented =
	errorPayload "cancel" "feature-not-implemented" (s"Unknown request") []

overChildrenOf :: (XML.Element -> [a]) -> [XML.Element] -> [a]
overChildrenOf f el = f =<< XML.elementChildren =<< el

elementAttributeText :: XML.Name -> XML.Name -> XML.Element -> [Text]
elementAttributeText = (.: XML.isNamed) . mapMaybe . XML.attributeText

child :: (XMPP.Stanza s) => XML.Name -> s -> Maybe XML.Element
child name = listToMaybe .
	(XML.isNamed name <=< XMPP.stanzaPayloads)

errorChild :: (XMPP.Stanza s) => s -> Maybe XML.Element
errorChild = child (s"{jabber:component:accept}error")

errorPayload :: String -> String -> Text -> [XML.Node] -> XML.Element
errorPayload typ definedCondition english morePayload =
	XML.Element (s"{jabber:component:accept}error")
	[(s"type", [XML.ContentText $ fromString typ])]
	(
		(
			XML.NodeElement $ XML.Element definedConditionName [] []
		) :
		(
			XML.NodeElement $ XML.Element
				(s"{urn:ietf:params:xml:ns:xmpp-stanzas}text")
				[(s"xml:lang", [XML.ContentText $ s"en"])]
				[XML.NodeContent $ XML.ContentText english]
		) :
		morePayload
	)
	where
	definedConditionName = fromString $
		"{urn:ietf:params:xml:ns:xmpp-stanzas}" ++ definedCondition

mkDiscoIdentity :: Text -> Text -> Text -> XML.Element
mkDiscoIdentity category typ name =
	XML.Element (s"{http://jabber.org/protocol/disco#info}identity") [
		(s"category", [XML.ContentText category]),
		(s"type", [XML.ContentText typ]),
		(s"name", [XML.ContentText name])
	] []

mkDiscoFeature :: Text -> XML.Element
mkDiscoFeature var =
	XML.Element (s"{http://jabber.org/protocol/disco#info}feature") [
		(s"var", [XML.ContentText var])
	] []

infixr 9 .:
(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) = (.) . (.)