M Main.hs => Main.hs +20 -5
@@ 42,6 42,7 @@ import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Builder as Builder
import qualified Database.TokyoCabinet as TC
import qualified Database.Redis as Redis
+import qualified Text.Regex.PCRE.Light as PCRE
import Network.Protocol.XMPP as XMPP -- should import qualified
import Network.Protocol.XMPP.Internal -- should import qualified
@@ 414,10 415,24 @@ componentMessage db componentJid m@(Message { messageFrom = Just from, messageTo
(deliveryReceipt (fromMaybe mempty $ messageID m) to from)
[] -> return []
- fmap (++ack) $ toRouteOrFallback db componentJid bareFrom resourceFrom smsJid strippedM $ do
- nick <- nickFor db from existingRoom
- let txt = mconcat [fromString "(", nick, fromString " whispers) ", strippedBody]
- return [mkStanzaRec $ mkSMS componentJid smsJid txt]
+ fmap (++ack) $ toRouteOrFallback db componentJid bareFrom resourceFrom smsJid strippedM $
+ case PCRE.match autolinkRegex (encodeUtf8 body) [] of
+ Just _ -> do
+ log "WHISPER URL" m
+ return [mkStanzaRec $ m {
+ messageFrom = Just to,
+ messageTo = Just from,
+ messageType = MessageError,
+ messagePayloads = messagePayloads m ++ [
+ Element (fromString "{jabber:component:accept}error")
+ [(fromString "{jabber:component:accept}type", [ContentText $ fromString "auth"])]
+ [NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}forbidden") [] []]
+ ]
+ }]
+ Nothing -> do
+ nick <- nickFor db from existingRoom
+ let txt = mconcat [fromString "(", nick, fromString " whispers) ", strippedBody]
+ return [mkStanzaRec $ mkSMS componentJid smsJid txt]
where
strippedM = mapBody (const strippedBody) m
strippedBody = stripOtrWhitespace body
@@ 1816,7 1831,7 @@ joinPartDebouncer db backendHost sendToComponent componentJid toRoomPresences to
adhocBotRunCommand :: (UIO.Unexceptional m) => JID -> JID -> (XMPP.Message -> STM ()) -> (XMPP.IQ -> UIO.UIO (STM (Maybe XMPP.IQ))) -> JID -> Text -> [Element] -> m ()
adhocBotRunCommand componentJid routeFrom sendMessage sendIQ from body cmdEls = do
let (nodes, cmds) = unzip $ mapMaybe (\el -> (,) <$> attributeText (s"node") el <*> pure el) cmdEls
- case snd <$> (find (\(prefixes, _) -> Set.member body prefixes) $ traceShowId $ zip (uniquePrefix nodes) cmds) of
+ case snd <$> (find (\(prefixes, _) -> Set.member body prefixes) $ zip (uniquePrefix nodes) cmds) of
Just cmd -> do
let cmdIQ = (emptyIQ IQSet) {
iqFrom = Just routeFrom,
M Util.hs => Util.hs +4 -0
@@ 21,6 21,7 @@ import qualified Data.Text.Encoding as T
import qualified Network.Protocol.XMPP as XMPP
import qualified Data.Attoparsec.Text as Atto
import qualified Data.ByteString.Lazy as LZ
+import qualified Text.Regex.PCRE.Light as PCRE
instance Unexceptional XMPP.XMPP where
lift = liftIO . UIO.lift
@@ 75,6 76,9 @@ unescapeJid txt = fromString result
("20", ' '), ("22", '"'), ("26", '&'), ("27", '\''), ("2f", '/'), ("3a", ':'), ("3c", '<'), ("3e", '>'), ("40", '@'), ("5c", '\\')
]
+autolinkRegex :: PCRE.Regex
+autolinkRegex = PCRE.compile (encodeUtf8 $ s"((http|https)://)?([a-z0-9-]+\\.)?[a-z0-9-]+(\\.[a-z]{2,6}){1,3}(/[a-z0-9.,_/~#&=;%+?-]*)?") [PCRE.caseless, PCRE.dotall]
+
sanitizeSipLocalpart :: Text -> Maybe Text
sanitizeSipLocalpart localpart
| Just ('+', tel) <- T.uncons candidate,
M cheogram.cabal => cheogram.cabal +1 -0
@@ 48,6 48,7 @@ executable cheogram
network,
network-uri,
network-protocol-xmpp >= 0.4.9,
+ pcre-light,
random,
random-shuffle,
SHA,