203 lines
6.3 KiB
Haskell
203 lines
6.3 KiB
Haskell
module Util where
|
|
|
|
import Prelude ()
|
|
import BasicPrelude
|
|
import Control.Applicative (many)
|
|
import Control.Concurrent
|
|
(ThreadId, forkFinally, myThreadId, throwTo)
|
|
import Control.Concurrent.STM (STM, atomically)
|
|
import Data.Time.Clock (UTCTime)
|
|
import Data.Time.Format (parseTimeM, defaultTimeLocale)
|
|
import Data.Void (absurd)
|
|
import UnexceptionalIO (Unexceptional)
|
|
import qualified UnexceptionalIO as UIO
|
|
import qualified Control.Exception as Ex
|
|
import qualified Data.Attoparsec.Text as Atto
|
|
import qualified Data.Text as Text
|
|
import qualified Data.XML.Types as XML
|
|
import qualified Network.Protocol.XMPP as XMPP
|
|
|
|
import qualified Config
|
|
|
|
instance Unexceptional XMPP.XMPP where
|
|
lift = liftIO . UIO.lift
|
|
|
|
s :: (IsString s) => String -> s
|
|
s = fromString
|
|
|
|
fromIO_ :: (Unexceptional m) => IO a -> m a
|
|
fromIO_ = fmap (either absurd id) . UIO.fromIO' (error . show)
|
|
|
|
atomicUIO :: (Unexceptional m) => STM a -> m a
|
|
atomicUIO = fromIO_ . atomically
|
|
|
|
escapeJid :: Text -> Text
|
|
escapeJid txt = mconcat result
|
|
where
|
|
Right result = Atto.parseOnly (many (
|
|
slashEscape <|>
|
|
replace ' ' "\\20" <|>
|
|
replace '"' "\\22" <|>
|
|
replace '&' "\\26" <|>
|
|
replace '\'' "\\27" <|>
|
|
replace '/' "\\2f" <|>
|
|
replace ':' "\\3a" <|>
|
|
replace '<' "\\3c" <|>
|
|
replace '>' "\\3e" <|>
|
|
replace '@' "\\40" <|>
|
|
fmap Text.singleton Atto.anyChar
|
|
) <* Atto.endOfInput) txt
|
|
replace c str = Atto.char c *> pure (fromString str)
|
|
|
|
-- XEP-0106 says to only escape \ when absolutely necessary
|
|
slashEscape :: Atto.Parser Text
|
|
slashEscape =
|
|
fmap (s"\\5c"++) $
|
|
Atto.char '\\' *> Atto.choice escapes
|
|
where
|
|
escapes = map (Atto.string . fromString) [
|
|
"20", "22", "26", "27", "2f", "3a", "3c", "3e", "40",
|
|
"5c"
|
|
]
|
|
|
|
unescapeJid :: Text -> Text
|
|
unescapeJid txt = fromString result
|
|
where
|
|
Right result = Atto.parseOnly (many (
|
|
(Atto.char '\\' *> Atto.choice unescapes) <|>
|
|
Atto.anyChar
|
|
) <* Atto.endOfInput) txt
|
|
unescapes = map (\(str, c) -> Atto.string (fromString str) *> pure c) [
|
|
("20", ' '), ("22", '"'), ("26", '&'), ("27", '\''),
|
|
("2f", '/'), ("3a", ':'), ("3c", '<'), ("3e", '>'),
|
|
("40", '@'), ("5c", '\\')
|
|
]
|
|
|
|
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
|
|
}
|
|
|
|
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") []
|
|
|
|
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")
|
|
|
|
getBody :: (XMPP.Stanza s) => s -> Maybe Text
|
|
getBody = fmap (mconcat . XML.elementText) .
|
|
child (s"{jabber:component:accept}body")
|
|
|
|
getSubject :: (XMPP.Stanza s) => s -> Maybe Text
|
|
getSubject = fmap (mconcat . XML.elementText) .
|
|
child (s"{jabber:component:accept}subject")
|
|
|
|
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
|
|
|
|
bareJid :: XMPP.JID -> XMPP.JID
|
|
bareJid (XMPP.JID node domain _) = XMPP.JID node domain Nothing
|
|
|
|
bareTxt :: XMPP.JID -> Text
|
|
bareTxt (XMPP.JID (Just node) domain _) =
|
|
mconcat [XMPP.strNode node, s"@", XMPP.strDomain domain]
|
|
bareTxt (XMPP.JID Nothing domain _) = XMPP.strDomain domain
|
|
|
|
parseXMPPTime :: Text -> Maybe UTCTime
|
|
parseXMPPTime =
|
|
parseTimeM False defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" . textToString
|
|
|
|
mkElement :: XML.Name -> Text -> XML.Element
|
|
mkElement name content = XML.Element name []
|
|
[XML.NodeContent $ XML.ContentText content]
|
|
|
|
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])
|
|
] []
|
|
|
|
(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
|
|
(.:) = (.) . (.)
|
|
|
|
proxyJid :: Config.Config -> XMPP.JID -> XMPP.JID
|
|
proxyJid config from = jid
|
|
where
|
|
Just jid = XMPP.parseJID $ escapeJid (XMPP.formatJID from)
|
|
++ s"@" ++ XMPP.formatJID (Config.componentJid config) ++ s"/bridge"
|
|
|
|
mucJoin :: XMPP.JID -> Text -> XMPP.Presence
|
|
mucJoin muc nick = (XMPP.emptyPresence XMPP.PresenceAvailable) {
|
|
XMPP.presenceTo = XMPP.parseJID $ bareTxt muc ++ s"/" ++ nick,
|
|
XMPP.presencePayloads = [mucJoinX]
|
|
}
|
|
|
|
mucJoinX :: XML.Element
|
|
mucJoinX = XML.Element (s"{http://jabber.org/protocol/muc}x") [] [
|
|
XML.NodeElement $ XML.Element (s"{http://jabber.org/protocol/muc}history")
|
|
[(s"maxchars", [XML.ContentText $ s"0"])] []
|
|
]
|