~singpolyma/cheogram

ref: c2f88151d793595d77e2596db78ff39def888d96 cheogram/Util.hs -rw-r--r-- 4.0 KiB
c2f88151Stephen Paul Weber Seperate out mapping for SIP URIs so SMS targets don't get caught 2 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
module Util where

import Prelude ()
import BasicPrelude
import Data.Char (isDigit)
import Control.Applicative (many)
import Control.Error (hush)
import Data.Time (getCurrentTime)
import Data.XML.Types (Name, Element(..), Node(NodeElement), isNamed, elementText, elementChildren, attributeText)
import Crypto.Random (getSystemDRG, withRandomBytes)
import Data.ByteString.Base58 (bitcoinAlphabet, encodeBase58)
import Data.Void (absurd)
import UnexceptionalIO (Unexceptional)
import qualified UnexceptionalIO       as UIO
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Network.Protocol.XMPP as XMPP
import qualified Data.Attoparsec.Text as Atto

instance Unexceptional XMPP.XMPP where
	lift = liftIO . UIO.lift

log :: (Show a, Unexceptional m) => String -> a -> m ()
log tag x = fromIO_ $ do
	time <- getCurrentTime
	putStr (tshow time ++ s" " ++ fromString tag ++ s" :: ") >> print x >> putStrLn mempty

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

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

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 T.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 =
		fmap (s"\\5c"++) $
		Atto.char '\\' *> Atto.choice escapes
	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", '\\')
		]

sanitizeSipLocalpart :: Text -> Maybe Text
sanitizeSipLocalpart localpart
	| Just ('+', tel) <- T.uncons candidate,
	  T.all isDigit tel = Just candidate
	| T.length candidate < 3 =
		Just $ s"13;phone-context=anonymous.phone-context.soprani.ca"
	| candidate == s"Restricted" =
		Just $ s"14;phone-context=anonymous.phone-context.soprani.ca"
	| candidate == s"anonymous" =
		Just $ s"15;phone-context=anonymous.phone-context.soprani.ca"
	| candidate == s"Anonymous" =
		Just $ s"16;phone-context=anonymous.phone-context.soprani.ca"
	| candidate == s"unavailable" =
		Just $ s"17;phone-context=anonymous.phone-context.soprani.ca"
	| candidate == s"Unavailable" =
		Just $ s"18;phone-context=anonymous.phone-context.soprani.ca"
	| otherwise = Nothing
	where
	candidate = fst $ T.breakOn (s"@") $ unescapeJid localpart

parsePhoneContext :: Text -> Maybe (Text, Text)
parsePhoneContext txt = hush $ Atto.parseOnly (
		(,) <$> Atto.takeWhile isDigit <* Atto.string (s";phone-context=") <*> Atto.takeTill (Atto.inClass " ;")
		<* Atto.endOfInput
	) txt

bareTxt (XMPP.JID (Just node) domain _) = mconcat [XMPP.strNode node, s"@", XMPP.strDomain domain]
bareTxt (XMPP.JID Nothing domain _) = XMPP.strDomain domain

getFormField form var =
		listToMaybe $ mapMaybe (\node ->
			case node of
				NodeElement el
					| elementName el == s"{jabber:x:data}field" &&
					  (attributeText (s"{jabber:x:data}var") el == Just var ||
					  attributeText (s"var") el == Just var) ->
						Just $ mconcat $
						elementText =<< isNamed (s"{jabber:x:data}value") =<< elementChildren el
				_ -> Nothing
		) (elementNodes form)

genToken :: Int -> IO Text
genToken n = do
	g <- getSystemDRG
	return $ fst $ withRandomBytes g n (T.decodeUtf8 . encodeBase58 bitcoinAlphabet)

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