~singpolyma/cheogram

703de46360da6f35b3a3b1cc04c2c83f1fcbf42a — Stephen Paul Weber 7 years ago 6b94f5b
Change nick to add _sms after register
1 files changed, 26 insertions(+), 13 deletions(-)

M Main.hs
M Main.hs => Main.hs +26 -13
@@ 308,7 308,7 @@ sendRegisterVerification db toVitelity toComponent tel iq = do
			iqPayload = Just verificationResponse
		}

handleVerificationCode db toComponent password iq = do
handleVerificationCode db toComponent componentHost password iq = do
	time <- getCurrentTime
	codeAndTime <- fmap (readZ =<<) $ TC.runTCM $ TC.get db regKey
	if (fmap expires codeAndTime > Just ((-300) `addUTCTime` time)) then


@@ 328,6 328,19 @@ handleVerificationCode db toComponent password iq = do

				True <- TC.runTCM $ TC.put db (T.unpack (bareTxt from) <> "\0registered") (T.unpack tel)
				tcPutJID db tel "registered" from

				-- If there is a nick that doesn't end in _sms, add _sms
				nick <- TC.runTCM (TC.get db $ tcKey tel "nick")
				forM_ nick $ \nick -> do
					let nick' = (fromMaybe (fromString nick) $ T.stripSuffix (fromString "_sms") (fromString nick)) <> fromString "_sms"

					existingRoom <- (parseJID <=< fmap bareTxt) <$> tcGetJID db tel "joined"
					forM_ existingRoom $ \room -> do
						let toJoin = parseJID (bareTxt room <> fromString "/" <> nick')
						forM_ toJoin $ joinRoom db toComponent componentHost tel

					True <- TC.runTCM (TC.put db (tcKey tel "nick") (T.unpack nick'))
					return ()
			_ ->
				writeStanzaChan toComponent $ iq {
					iqTo = iqFrom iq,


@@ 342,7 355,7 @@ handleVerificationCode db toComponent password iq = do
	where
	regKey = (maybe mempty T.unpack $ bareTxt <$> iqFrom iq) <> "\0registration_code"

handleRegister db _ toComponent iq@(IQ { iqType = IQGet }) _ = do
handleRegister db _ toComponent _ iq@(IQ { iqType = IQGet }) _ = do
	time <- getCurrentTime
	codeAndTime <- fmap (readZ =<<) $ TC.runTCM $ TC.get db ((maybe mempty T.unpack $ bareTxt <$> iqFrom iq) <> "\0registration_code")
	if fmap expires codeAndTime > Just ((-300) `addUTCTime` time) then


@@ 384,22 397,22 @@ handleRegister db _ toComponent iq@(IQ { iqType = IQGet }) _ = do
					]
				]
		}
handleRegister db toVitelity toComponent iq@(IQ { iqType = IQSet }) query
handleRegister db toVitelity toComponent _ iq@(IQ { iqType = IQSet }) query
	| [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren query,
	  Just tel <- (normalizeTel . T.filter isDigit) =<< getFormField form (fromString "phone") =
		sendRegisterVerification db toVitelity toComponent tel iq
handleRegister db toVitelity toComponent iq@(IQ { iqType = IQSet }) query
handleRegister db toVitelity toComponent _ iq@(IQ { iqType = IQSet }) query
	| [phoneEl] <- isNamed (fromString "{jabber:iq:register}phone") =<< elementChildren query,
	  Just tel <- normalizeTel $ T.filter (not . isDigit) $ mconcat (elementText phoneEl) =
		sendRegisterVerification db toVitelity toComponent tel iq
handleRegister db toVitelity toComponent iq@(IQ { iqType = IQSet }) query
handleRegister db toVitelity toComponent componentHost iq@(IQ { iqType = IQSet }) query
	| [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren query,
	  Just password <- getFormField form (fromString "password") =
		handleVerificationCode db toComponent password iq
handleRegister db toVitelity toComponent iq@(IQ { iqType = IQSet, iqPayload = Just payload }) query
		handleVerificationCode db toComponent componentHost password iq
handleRegister db toVitelity toComponent componentHost iq@(IQ { iqType = IQSet, iqPayload = Just payload }) query
	| [passwordEl] <- isNamed (fromString "{jabber:iq:register}password") =<< elementChildren query =
		handleVerificationCode db toComponent (mconcat $ elementText passwordEl) iq
handleRegister db _ toComponent iq@(IQ { iqType = IQSet }) query
		handleVerificationCode db toComponent componentHost (mconcat $ elementText passwordEl) iq
handleRegister db _ toComponent _ iq@(IQ { iqType = IQSet }) query
	| [_] <- isNamed (fromString "{jabber:iq:register}remove") =<< elementChildren query = do
		tel <- maybe mempty T.pack <$> TC.runTCM (TC.get db $ T.unpack (maybe mempty bareTxt $ iqFrom iq) <> "\0registered")
		_ <- TC.runTCM $ TC.out db $ tcKey tel "registered"


@@ 410,7 423,7 @@ handleRegister db _ toComponent iq@(IQ { iqType = IQSet }) query
			iqType = IQResult,
			iqPayload = Just $ Element (fromString "{jabber:iq:register}query") [] []
		}
handleRegister _ _ toComponent iq@(IQ { iqType = typ }) _
handleRegister _ _ toComponent _ iq@(IQ { iqType = typ }) _
	| typ `elem` [IQGet, IQSet] =
		writeStanzaChan toComponent $ iq {
			iqTo = iqFrom iq,


@@ 420,7 433,7 @@ handleRegister _ _ toComponent iq@(IQ { iqType = typ }) _
				[(fromString "{jabber:component:accept}type", [ContentText $ fromString "cancel"])]
				[NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}feature-not-implemented") [] []]
		}
handleRegister _ _ _ _ _ = return ()
handleRegister _ _ _ _ _ _ = return ()

componentStanza _ _ toComponent _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from}))
	| [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< messagePayloads m,


@@ 498,10 511,10 @@ componentStanza _ _ toComponent _ (ReceivedPresence (Presence { presenceType = P
			] []
		]
	}
componentStanza db toVitelity toComponent _ (ReceivedIQ iq@(IQ { iqFrom = Just _, iqTo = Just (JID { jidNode = Nothing }), iqPayload = Just p }))
componentStanza db toVitelity toComponent componentHost (ReceivedIQ iq@(IQ { iqFrom = Just _, iqTo = Just (JID { jidNode = Nothing }), iqPayload = Just p }))
	| iqType iq `elem` [IQGet, IQSet],
	  [query] <- isNamed (fromString "{jabber:iq:register}query") p =
		handleRegister db toVitelity toComponent iq query
		handleRegister db toVitelity toComponent componentHost iq query
componentStanza _ _ toComponent _ (ReceivedIQ (IQ { iqType = IQGet, iqFrom = Just from, iqTo = Just to, iqID = id, iqPayload = Just p }))
	| Nothing <- jidNode to,
	  [_] <- isNamed (fromString "{http://jabber.org/protocol/disco#info}query") p =