~singpolyma/cheogram

73fa676d6be8d4f10f317869394e12eab2ff6a7b — Stephen Paul Weber 1 year, 11 months ago 8f9ebf5
Better URL block for whispers
3 files changed, 25 insertions(+), 5 deletions(-)

M Main.hs
M Util.hs
M cheogram.cabal
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,