{-# LANGUAGE PackageImports #-}
import Prelude (show, read)
import BasicPrelude hiding (show, read, forM, mapM, forM_, mapM_, getArgs, log)
import System.IO (stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
import Data.Char
import Control.Concurrent
import Control.Concurrent.STM
import Data.Foldable (forM_, mapM_, toList)
import Data.Traversable (forM, mapM)
import System.Environment (getArgs)
import Control.Error (readZ, syncIO, runEitherT, readMay, MaybeT(..), hoistMaybe)
import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Network (PortID(PortNumber))
import System.Random (Random(randomR), getStdRandom)
import System.Random.Shuffle (shuffleM)
import Data.Digest.Pure.SHA (sha1, bytestringDigest)

import "monads-tf" Control.Monad.Error (catchError) -- ick
import Data.XML.Types (Element(..), Node(NodeContent, NodeElement), Name(Name), Content(ContentText), isNamed, hasAttributeText, elementText, elementChildren, attributeText)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Map as Map
import qualified Data.UUID as UUID ( toString )
import qualified Data.UUID.V1 as UUID ( nextUUID )
import qualified Data.ByteString.Lazy as LZ
import qualified Data.ByteString.Base64 as Base64
import qualified Database.TokyoCabinet as TC
import Network.Protocol.XMPP -- should import qualified

import Util
import qualified ConfigureDirectMessageRoute

instance Ord JID where
	compare x y = compare (show x) (show y)

data StanzaRec = StanzaRec (Maybe JID) (Maybe JID) (Maybe Text) (Maybe Text) [Element] Element deriving (Show)
mkStanzaRec x = StanzaRec (stanzaTo x) (stanzaFrom x) (stanzaID x) (stanzaLang x) (stanzaPayloads x) (stanzaToElement x)
instance Stanza StanzaRec where
	stanzaTo (StanzaRec to _ _ _ _ _) = to
	stanzaFrom (StanzaRec _ from _ _ _ _) = from
	stanzaID (StanzaRec _ _ id _ _ _) = id
	stanzaLang (StanzaRec _ _ _ lang _ _) = lang
	stanzaPayloads (StanzaRec _ _ _ _ payloads _) = payloads
	stanzaToElement (StanzaRec _ _ _ _ _ element) = element

mkSMS from to txt = (emptyMessage MessageChat) {
	messageTo = Just to,
	messageFrom = Just from,
	messagePayloads = [Element (fromString "{jabber:component:accept}body") [] [NodeContent $ ContentText txt]]
}

tcKey jid key = fmap (\node -> (T.unpack $ strNode node) <> "\0" <> key) (jidNode jid)
tcGetJID db jid key = liftIO $ case tcKey jid key of
	Just tck -> (parseJID . fromString =<<) <$> TC.runTCM (TC.get db tck)
	Nothing -> return Nothing
tcPutJID db cheoJid key jid = tcPut db cheoJid key $ T.unpack $ formatJID jid
tcPut db cheoJid key val = liftIO $ do
	let Just tck = tcKey cheoJid key
	True <- TC.runTCM (TC.put db tck val)
	return ()

getBody ns = listToMaybe . fmap (mconcat . elementText) . (isNamed (Name (fromString "body") (Just $ fromString ns) Nothing) <=< messagePayloads)

queryDisco to from = do
	uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
	return [mkStanzaRec $ (emptyIQ IQGet) {
		iqTo = Just to,
		iqFrom = Just from,
		iqID = uuid,
		iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") [] []
	}]

queryCommandList to from = do
	uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
	return [mkStanzaRec $ (emptyIQ IQGet) {
		iqTo = Just to,
		iqFrom = Just from,
		iqID = uuid,
		iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#items}query") [
			(s"{http://jabber.org/protocol/disco#items}node", [ContentText $ s"http://jabber.org/protocol/commands"])
		] []
	}]

fillFormField var value form = form {
		elementNodes = map (\node ->
			case node of
				NodeElement el
					| elementName el == fromString "{jabber:x:data}field" &&
					  (attributeText (fromString "{jabber:x:data}var") el == Just var ||
					  attributeText (fromString "var") el == Just var) ->
						NodeElement $ el { elementNodes = [
							NodeElement $ Element (fromString "{jabber:x:data}value") []
								[NodeContent $ ContentText value]
						]}
				x -> x
		) (elementNodes form)
	}

data Invite = Invite {
	inviteMUC :: JID,
	inviteFrom :: JID,
	inviteText :: Maybe Text,
	invitePassword :: Maybe Text
} deriving (Show)

getMediatedInvitation m = do
	from <- messageFrom m
	x <- listToMaybe $ isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< messagePayloads m
	invite <- listToMaybe $ isNamed (fromString "{http://jabber.org/protocol/muc#user}invite") =<< elementChildren x
	inviteFrom <- parseJID =<< attributeText (fromString "from") invite
	return Invite {
		inviteMUC = from,
		inviteFrom = inviteFrom,
		inviteText = do
			txt <- mconcat . elementText <$> listToMaybe
				(isNamed (fromString "{http://jabber.org/protocol/muc#user}reason") =<< elementChildren invite)
			guard (not $ T.null txt)
			return txt,
		invitePassword =
			mconcat . elementText <$> listToMaybe
			(isNamed (fromString "{http://jabber.org/protocol/muc#user}password") =<< elementChildren x)
	}

getDirectInvitation m = do
	x <- listToMaybe $ isNamed (fromString "{jabber:x:conference}x") =<< messagePayloads m
	Invite <$>
		(parseJID =<< attributeText (fromString "jid") x) <*>
		messageFrom m <*>
		Just (do
			txt <- attributeText (fromString "reason") x
			guard (not $ T.null txt)
			return txt
		) <*>
		Just (attributeText (fromString "password") x)

forkXMPP :: XMPP () -> XMPP ThreadId
forkXMPP kid = do
	session <- getSession
	liftIO $ forkIO $ void $ runXMPP session kid

nickFor db jid existingRoom
	| fmap bareTxt existingRoom == Just bareFrom = return $ fromMaybe (fromString "nonick") resourceFrom
	| Just tel <- normalizeTel =<< strNode <$> jidNode jid = do
		mnick <- maybe (return Nothing) (TC.runTCM .TC.get db) (tcKey jid "nick")
		case mnick of
			Just nick -> return (tel <> fromString " \"" <> fromString nick <> fromString "\"")
			Nothing -> return tel
	| otherwise = return bareFrom
	where
	bareFrom = bareTxt jid
	resourceFrom = strResource <$> jidResource jid

code str status =
	hasAttributeText (fromString "{http://jabber.org/protocol/muc#user}code") (== fromString str) status
	<>
	hasAttributeText (fromString "code") (== fromString str) status

cheogramAvailable from to =
	(emptyPresence PresenceAvailable) {
		presenceTo = Just to,
		presenceFrom = Just from,
		presencePayloads = [
			Element (s"{http://jabber.org/protocol/caps}c") [
				(s"{http://jabber.org/protocol/caps}hash", [ContentText $ fromString "sha-1"]),
				(s"{http://jabber.org/protocol/caps}node", [ContentText $ fromString "xmpp:cheogram.com"]),
				-- gateway/sms//Cheogram<jabber:iq:gateway<jabber:iq:register<urn:xmpp:ping<vcard-temp<
				(s"{http://jabber.org/protocol/caps}ver", [ContentText $ fromString "XCOs6r/FNTOQJwgYkKOjkktq8XI="])
			] []
		]
	}

telDiscoFeatures = [
		s"http://jabber.org/protocol/muc",
		s"jabber:x:conference",
		s"urn:xmpp:ping",
		s"urn:xmpp:receipts",
		s"vcard-temp"
	]

telCapsStr extraVars =
	s"client/sms//Cheogram<" ++ mconcat (intersperse (s"<") (sort (nub (telDiscoFeatures ++ extraVars)))) ++ s"<"

telAvailable from to disco =
	(emptyPresence PresenceAvailable) {
		presenceTo = Just to,
		presenceFrom = Just from,
		presencePayloads = [
			Element (s"{http://jabber.org/protocol/caps}c") [
				(s"{http://jabber.org/protocol/caps}hash", [ContentText $ fromString "sha-1"]),
				(s"{http://jabber.org/protocol/caps}node", [ContentText $ fromString "xmpp:cheogram.com"]),
				(s"{http://jabber.org/protocol/caps}ver", [ContentText hash])
			] []
		]
	}
	where
	hash = T.decodeUtf8 $ Base64.encode $ LZ.toStrict $ bytestringDigest $ sha1 $ LZ.fromStrict $ T.encodeUtf8 $ telCapsStr disco

telDiscoInfo id from to disco =
	(emptyIQ IQResult) {
		iqTo = Just to,
		iqFrom = Just from,
		iqID = Just id,
		iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/disco#info}query") [] $
			[
				NodeElement $ Element (s"{http://jabber.org/protocol/disco#info}identity") [
					(s"{http://jabber.org/protocol/disco#info}category", [ContentText $ s"client"]),
					(s"{http://jabber.org/protocol/disco#info}type", [ContentText $ s"sms"]),
					(s"{http://jabber.org/protocol/disco#info}name", [ContentText $ s"Cheogram"])
				] []
			] ++ map (\var ->
				NodeElement $ Element (fromString "{http://jabber.org/protocol/disco#info}feature") [
					(fromString "{http://jabber.org/protocol/disco#info}var", [ContentText var])
				] []
			) (sort $ nub $ telDiscoFeatures ++ disco)
	}

commandList componentJid id from to extras =
	(emptyIQ IQResult) {
		iqTo = Just to,
		iqFrom = Just from,
		iqID = id,
		iqPayload = Just $ Element (s"{http://jabber.org/protocol/disco#items}query")
			[(s"{http://jabber.org/protocol/disco#items}node", [ContentText $ s"http://jabber.org/protocol/commands"])]
			([
				NodeElement $ Element (s"{http://jabber.org/protocol/disco#items}item") [
						(s"{http://jabber.org/protocol/disco#items}jid", [ContentText $ formatJID componentJid ++ s"/" ++ ConfigureDirectMessageRoute.nodeName]),
						(s"{http://jabber.org/protocol/disco#items}node", [ContentText $ ConfigureDirectMessageRoute.nodeName]),
						(s"{http://jabber.org/protocol/disco#items}name", [ContentText $ s"Configure direct message route"])
				] []
			] ++ extraItems)
	}
	where
	extraItems = map (\el ->
			NodeElement $ el {
				elementAttributes = map (\(aname, acontent) ->
					if aname == s"{http://jabber.org/protocol/disco#items}jid" || aname == s"jid" then
						(aname, [ContentText $ formatJID componentJid ++ s"/route-command"])
					else
						(aname, acontent)
				) (elementAttributes el)
			}
		) extras

routeQueryOrReply db componentJid from smsJid resource query reply = do
	maybeRoute <- TC.runTCM $ TC.get db (T.unpack (bareTxt from) ++ "\0direct-message-route")
	case (fmap fromString maybeRoute, maybeRouteFrom) of
		(Just route, Just routeFrom) ->
				let routeTo = fromMaybe componentJid $ parseJID $ (maybe mempty (++ s"@") $ strNode <$> jidNode smsJid) ++ route in
				query routeTo routeFrom
		_ -> return [mkStanzaRec $ reply]
	where
	maybeRouteFrom = parseJID $ escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid ++ s"/" ++ (fromString resource)

routeDiscoOrReply db componentJid from smsJid resource reply =
	routeQueryOrReply db componentJid from smsJid resource queryDisco reply

deliveryReceipt id from to =
	(emptyMessage MessageNormal) {
		messageFrom = Just from,
		messageTo = Just to,
		messagePayloads = [
			Element (s"{urn:xmpp:receipts}received")
				[(s"{urn:xmpp:receipts}id", [ContentText id])] []
		]
	}

iqNotImplemented iq =
	iq {
		iqTo = iqFrom iq,
		iqFrom = iqTo iq,
		iqType = IQError,
		iqPayload = Just $ Element (s"{jabber:component:accept}error")
			[(s"{jabber:component:accept}type", [ContentText $ fromString "cancel"])]
			[NodeElement $ Element (s"{urn:ietf:params:xml:ns:xmpp-stanzas}feature-not-implemented") [] []]
	}

unregisterDirectMessageRoute db componentJid userJid route = do
	maybeCheoJid <- (parseJID . fromString =<<) <$> TC.runTCM (TC.get db (T.unpack (bareTxt userJid) ++ "\0cheoJid"))
	forM_ maybeCheoJid $ \cheoJid -> do
		TC.runTCM $ TC.out db (T.unpack (bareTxt userJid) ++ "\0cheoJid")

		owners <- (fromMaybe [] . (readZ =<<)) <$>
			maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "owners")
		tcPut db cheoJid "owners" (show $ (filter (/= bareTxt userJid)) owners)

	uuid <- (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
	return $ (emptyIQ IQSet) {
			iqTo = Just route,
			iqFrom = parseJID $ escapeJid (bareTxt userJid) ++ s"@" ++ formatJID componentJid ++ s"/CHEOGRAM%removed",
			iqID = uuid,
			iqPayload = Just $ Element (s"{jabber:iq:register}query") [] [
				NodeElement $ Element (s"{jabber:iq:register}remove") [] []
			]
		}

toRouteOrFallback db componentJid bareFrom resourceFrom smsJid m fallback = do
	maybeRoute <- TC.runTCM $ TC.get db (T.unpack bareFrom ++ "\0direct-message-route")
	case (fmap fromString maybeRoute, parseJID $ escapeJid bareFrom ++ s"@" ++ formatJID componentJid ++ resourceSuffix) of
		(Just route, Just routeFrom) -> do
			log "TO DIRECT ROUTE" route
			return [mkStanzaRec $ m {
				messageFrom = Just routeFrom,
				messageTo = parseJID $ (fromMaybe mempty $ strNode <$> jidNode smsJid) ++ s"@" ++ route
			}]
		_ -> fallback
	where
	resourceSuffix = maybe mempty (s"/"++) resourceFrom

componentMessage db componentJid (m@Message { messageType = MessageError }) _ bareFrom resourceFrom smsJid body = do
	log "MESSAGE ERROR"  m
	toRouteOrFallback db componentJid bareFrom resourceFrom smsJid m $ do
		log "DIRECT FROM GATEWAY" smsJid
		return [mkStanzaRec $ m { messageTo = Just smsJid, messageFrom = Just componentJid }]
componentMessage db componentJid m@(Message { messageTo = Just to }) existingRoom _ _ smsJid _
	| Just invite <- getMediatedInvitation m <|> getDirectInvitation m = do
		log "GOT INVITE" (invite, m)
		forM_ (invitePassword invite) $ \password ->
			tcPut db to (T.unpack (formatJID $ inviteMUC invite) <> "\0muc_roomsecret") (T.unpack password)
		existingInvite <- tcGetJID db to "invited"
		nick <- nickFor db (inviteFrom invite) existingRoom
		let txt = mconcat [
				fromString "* ",
				nick,
				fromString " has invited you to a group",
				maybe mempty (\t -> fromString ", saying \"" <> t <> fromString "\"") (inviteText invite),
				fromString "\nYou can switch to this group by replying with /join"
			]
		if (existingRoom /= Just (inviteMUC invite) && existingInvite /= Just (inviteMUC invite)) then do
			tcPutJID db to "invited" (inviteMUC invite)
			regJid <- tcGetJID db to "registered"
			fmap (((mkStanzaRec $ mkSMS componentJid smsJid txt):) . concat . toList)
				(forM regJid $ \jid -> sendInvite db jid (invite { inviteFrom = to }))
		else
			return []
componentMessage _ componentJid (m@Message { messageType = MessageGroupChat }) existingRoom bareFrom resourceFrom smsJid (Just body) = do
	log "MESSAGE FROM GROUP" (existingRoom, body)
	if fmap bareTxt existingRoom == Just bareFrom && (
	   existingRoom /= parseJID (bareFrom <> fromString "/" <> fromMaybe mempty resourceFrom) ||
	   not (fromString "CHEOGRAM%" `T.isPrefixOf` fromMaybe mempty (messageID m))) then
		return [mkStanzaRec $ mkSMS componentJid smsJid txt]
	else do
		log "MESSAGE FROM WRONG GROUP" (fmap bareTxt existingRoom, bareFrom, m)
		return []
	where
	txt = mconcat [fromString "(", fromMaybe (fromString "nonick") resourceFrom, fromString ") ", body]
componentMessage db componentJid m@(Message { messageFrom = Just from, messageTo = Just to }) existingRoom bareFrom resourceFrom smsJid (Just body) = do
	log "WHISPER" (from, smsJid, body)

	ack <- case isNamed (fromString "{urn:xmpp:receipts}request") =<< messagePayloads m of
		(_:_) ->
			routeDiscoOrReply db componentJid from smsJid ("CHEOGRAM%query-then-send-ack%" ++ extra)
				(deliveryReceipt (fromMaybe mempty $ messageID m) to from)
		[] -> return []

	fmap (++ack) $ toRouteOrFallback db componentJid bareFrom resourceFrom smsJid m $ do
		nick <- nickFor db from existingRoom
		let txt = mconcat [fromString "(", nick, fromString " whispers) ", body]
		return [mkStanzaRec $ mkSMS componentJid smsJid txt]
	where
	extra = T.unpack $ escapeJid $ T.pack $ show (fromMaybe mempty (messageID m), fromMaybe mempty resourceFrom)
componentMessage _ _ m _ _ _ _ _ = do
	log "UNKNOWN MESSAGE" m
	return []

handleJoinPartRoom db toRoomPresences toRejoinManager toJoinPartDebouncer componentJid existingRoom from to smsJid payloads join
	| join,
	  [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads,
	  not $ null $ code "110" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do
		log "JOINED" (to, from)
		existingInvite <- tcGetJID db to "invited"
		when (existingInvite == parseJID bareMUC) $ do
			let Just invitedKey = tcKey to "invited"
			True <- TC.runTCM $ TC.out db invitedKey
			log "JOINED" (to, from, "INVITE CLEARED")
			return ()
		tcPutJID db to "joined" from
		let Just bookmarksKey = tcKey to "bookmarks"
		bookmarks <- fmap (fromMaybe [] . (readZ =<<)) (TC.runTCM $ TC.get db bookmarksKey)
		tcPut db to "bookmarks" (show $ sort $ nub $ T.unpack bareMUC : bookmarks)

		presences <- syncCall toRoomPresences $ GetRoomPresences to from
		atomically $ writeTChan toRoomPresences $ RecordSelfJoin to from (Just to)

		atomically $ writeTChan toRejoinManager $ Joined from

		case presences of
			[] -> do -- No one in the room, so we "created"
				log "JOINED" (to, from, "CREATED")
				uuid <- fromMaybe "UUIDFAIL" <$> (fmap.fmap) (fromString . UUID.toString) UUID.nextUUID
				let fullid = if (T.unpack resourceFrom `elem` map fst presences) then uuid else "CHEOGRAMCREATE%" <> uuid
				return [mkStanzaRec $ (emptyIQ IQGet) {
					iqTo = Just room,
					iqFrom = Just to,
					iqID = Just $ fromString fullid,
					iqPayload = Just $ Element (fromString "{http://jabber.org/protocol/muc#owner}query") [] []
				}]
			(_:_) | isNothing (lookup (T.unpack resourceFrom) presences) -> do
				log "JOINED" (to, from, resourceFrom, presences, "YOU HAVE JOINED")
				fmap ((mkStanzaRec $ mkSMS componentJid smsJid $ mconcat [
						fromString "* You have joined ", bareMUC,
						fromString " as ", resourceFrom,
						fromString " along with\n",
						fromString $ intercalate ", " (filter (/= T.unpack resourceFrom) $ map fst presences)
					]):)
					(queryDisco room to)
			_ -> do
				log "JOINED" (to, from, "FALSE PRESENCE")
				queryDisco room to
	| not join,
	  [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads,
	  (_:_) <- code "303" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do
		log "CHANGED NICK" (to, x)
		let mnick = attributeText (fromString "nick") =<<
			listToMaybe (isNamed (fromString "{http://jabber.org/protocol/muc#user}item") =<< elementChildren x)
		toList <$> forM mnick (\nick -> do
			atomically $ writeTChan toRoomPresences $ RecordNickChanged to from nick
			return $ mkStanzaRec $ mkSMS componentJid smsJid $ mconcat [
					fromString "* ",
					resourceFrom,
					fromString " has changed their nick to ",
					nick
				]
			)
	| not join,
	  [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads,
	  (_:_) <- code "332" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do
		log "SERVER RESTART, rejoin in 5s" (to, from)
		void $ forkIO $ threadDelay 5000000 >> atomically (writeTChan toRejoinManager $ ForceRejoin from to)
		return []
	| not join && existingRoom == Just from = do
		log "YOU HAVE LEFT" (to, existingRoom)
		let Just joinedKey = tcKey to "joined"
		True <- TC.runTCM $ TC.out db joinedKey
		atomically $ writeTChan toRoomPresences $ RecordPart to from
		atomically $ writeTChan toRoomPresences $ Clear to from
		return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "* You have left " <> bareMUC)]
	| fmap bareTxt existingRoom == Just bareMUC && join = do
		atomically $ writeTChan toJoinPartDebouncer $ DebounceJoin to from (participantJid payloads)
		return []
	| fmap bareTxt existingRoom == Just bareMUC && not join = do
		atomically $ writeTChan toJoinPartDebouncer $ DebouncePart to from
		return []
	| join = do
		log "UNKNOWN JOIN" (existingRoom, from, to, payloads, join)
		atomically $ writeTChan toRoomPresences $ RecordJoin to from (participantJid payloads)
		return []
	| otherwise = do
		log "UNKNOWN NOT JOIN" (existingRoom, from, to, payloads, join)
		atomically $ writeTChan toRoomPresences $ RecordPart to from
		return []
	where
	resourceFrom = fromMaybe mempty (strResource <$> jidResource from)
	Just room = parseJID bareMUC
	bareMUC = bareTxt from

verificationResponse =
	Element (fromString "{jabber:iq:register}query") []
		[
			NodeElement $ Element (fromString "{jabber:iq:register}instructions") [] [
				NodeContent $ ContentText $ fromString "Enter the verification code CheoGram texted you."
			],
			NodeElement $ Element (fromString "{jabber:iq:register}password") [] [],
			NodeElement $ Element (fromString "{jabber:x:data}x") [
				(fromString "{jabber:x:data}type", [ContentText $ fromString "form"])
			] [
				NodeElement $ Element (fromString "{jabber:x:data}title") [] [NodeContent $ ContentText $ fromString "Verify Phone Number"],
				NodeElement $ Element (fromString "{jabber:x:data}instructions") [] [
					NodeContent $ ContentText $ fromString "Enter the verification code CheoGram texted you."
				],
				NodeElement $ Element (fromString "{jabber:x:data}field") [
					(fromString "{jabber:x:data}type", [ContentText $ fromString "hidden"]),
					(fromString "{jabber:x:data}var", [ContentText $ fromString "FORM_TYPE"])
				] [
					NodeElement $ Element (fromString "{jabber:x:data}value") [] [NodeContent $ ContentText $ fromString "jabber:iq:register"]
				],
				NodeElement $ Element (fromString "{jabber:x:data}field") [
					(fromString "{jabber:x:data}type", [ContentText $ fromString "text-single"]),
					(fromString "{jabber:x:data}var", [ContentText $ fromString "password"]),
					(fromString "{jabber:x:data}label", [ContentText $ fromString "Verification code"])
				] []
			]
		]

data RegistrationCode = RegistrationCode { regCode :: Int, cheoJid :: Text, expires :: UTCTime } deriving (Show, Read)

registerVerification db componentJid to iq = do
	log "REGISTERVERIFIFCATION" (to, iq)
	code <- getStdRandom (randomR (123457::Int,987653))
	time <- getCurrentTime
	True <- TC.runTCM $ TC.put db ((maybe mempty T.unpack $ bareTxt <$> iqFrom iq) <> "\0registration_code") $ show $ RegistrationCode code (formatJID to) time
	return [
			mkStanzaRec $ mkSMS componentJid to $ fromString ("Enter this verification code to complete registration: " <> show code),
			mkStanzaRec $ iq {
				iqTo = iqFrom iq,
				iqFrom = iqTo iq,
				iqType = IQResult,
				iqPayload = Just verificationResponse
			}
		]

handleVerificationCode db componentJid password iq = do
	time <- getCurrentTime
	codeAndTime <- fmap (readZ =<<) $ TC.runTCM $ TC.get db regKey
	log "HANDLEVERIFICATIONCODE" (password, iq, time, codeAndTime)
	case codeAndTime of
		Just (RegistrationCode { regCode = code, cheoJid = cheoJidT })
			| fmap expires codeAndTime > Just ((-300) `addUTCTime` time) ->
				case (show code == T.unpack password, iqTo iq, iqFrom iq, parseJID cheoJidT) of
					(True, Just to, Just from, Just cheoJid) -> do
						bookmarks <- fmap (fromMaybe [] . (readZ =<<)) (maybe (return Nothing) (TC.runTCM . TC.get db) (tcKey cheoJid "bookmarks"))
						invites <- fmap concat $ forM (mapMaybe parseJID bookmarks) $ \bookmark ->
							sendInvite db from (Invite bookmark cheoJid (Just $ fromString "Cheogram registration") Nothing)

						let Just tel = T.unpack . strNode <$> jidNode cheoJid
						True <- TC.runTCM $ TC.put db (T.unpack (bareTxt from) <> "\0registered") tel
						tcPutJID db cheoJid "registered" from

						stuff <- runMaybeT $ do
							-- If there is a nick that doesn't end in _sms, add _sms
							nick <- MaybeT . TC.runTCM . TC.get db =<< (hoistMaybe $ tcKey cheoJid "nick")
							let nick' = (fromMaybe (fromString nick) $ T.stripSuffix (fromString "_sms") (fromString nick)) <> fromString "_sms"
							tcPut db cheoJid "nick" (T.unpack nick')

							room <- MaybeT ((parseJID <=< fmap bareTxt) <$> tcGetJID db cheoJid "joined")
							toJoin <- hoistMaybe $ parseJID (bareTxt room <> fromString "/" <> nick')
							liftIO $ joinRoom db cheoJid toJoin

						return ((mkStanzaRec $ iq {
								iqTo = iqFrom iq,
								iqFrom = iqTo iq,
								iqType = IQResult,
								iqPayload = Just $ Element (fromString "{jabber:iq:register}query") [] []
							}):invites)
					_ ->
						return [mkStanzaRec $ iq {
							iqTo = iqFrom iq,
							iqFrom = iqTo iq,
							iqType = IQError,
							iqPayload = Just $ Element (fromString "{jabber:component:accept}error")
								[(fromString "{jabber:component:accept}type", [ContentText $ fromString "auth"])]
								[NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}not-authorized") [] []]
						}]
		_ -> do
			void $ TC.runTCM $ TC.out db regKey
			return []
	where
	regKey = (maybe mempty T.unpack $ bareTxt <$> iqFrom iq) <> "\0registration_code"

handleRegister db componentJid iq@(IQ { iqType = IQGet }) _ = do
	time <- getCurrentTime
	codeAndTime <- fmap (readZ =<<) $ TC.runTCM $ TC.get db ((maybe mempty T.unpack $ bareTxt <$> iqFrom iq) <> "\0registration_code")
	log "HANDLEREGISTER IQGet" (time, codeAndTime, iq)
	if fmap expires codeAndTime > Just ((-300) `addUTCTime` time) then
		return [mkStanzaRec $ iq {
			iqTo = iqFrom iq,
			iqFrom = iqTo iq,
			iqType = IQResult,
			iqPayload = Just verificationResponse
		}]
	else
		return [mkStanzaRec $ iq {
			iqTo = iqFrom iq,
			iqFrom = iqTo iq,
			iqType = IQResult,
			iqPayload = Just $ Element (fromString "{jabber:iq:register}query") []
				[
					NodeElement $ Element (fromString "{jabber:iq:register}instructions") [] [
						NodeContent $ ContentText $ fromString "CheoGram can verify your phone number and add you to the private groups you previously texted."
					],
					NodeElement $ Element (fromString "{jabber:iq:register}phone") [] [],
					NodeElement $ Element (fromString "{jabber:x:data}x") [
						(fromString "{jabber:x:data}type", [ContentText $ fromString "form"])
					] [
						NodeElement $ Element (fromString "{jabber:x:data}title") [] [NodeContent $ ContentText $ fromString "Associate Phone Number"],
						NodeElement $ Element (fromString "{jabber:x:data}instructions") [] [
							NodeContent $ ContentText $ fromString "CheoGram can verify your phone number and add you to the private groups you previously texted."
						],
						NodeElement $ Element (fromString "{jabber:x:data}field") [
							(fromString "{jabber:x:data}type", [ContentText $ fromString "hidden"]),
							(fromString "{jabber:x:data}var", [ContentText $ fromString "FORM_TYPE"])
						] [
							NodeElement $ Element (fromString "{jabber:x:data}value") [] [NodeContent $ ContentText $ fromString "jabber:iq:register"]
						],
						NodeElement $ Element (fromString "{jabber:x:data}field") [
							(fromString "{jabber:x:data}type", [ContentText $ fromString "text-single"]),
							(fromString "{jabber:x:data}var", [ContentText $ fromString "phone"]),
							(fromString "{jabber:x:data}label", [ContentText $ fromString "Phone number"])
						] []
					]
				]
		}]
handleRegister db componentJid iq@(IQ { iqType = IQSet }) query
	| [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren query,
	  Just to <- ((`telToJid` formatJID componentJid) . T.filter isDigit) =<< getFormField form (fromString "phone") = do
		log "HANDLEREGISTER IQSet jabber:x:data phone" iq
		registerVerification db componentJid to iq
handleRegister db componentJid iq@(IQ { iqType = IQSet }) query
	| [phoneEl] <- isNamed (fromString "{jabber:iq:register}phone") =<< elementChildren query,
	  Just to <- (`telToJid` formatJID componentJid) $ T.filter isDigit $ mconcat (elementText phoneEl) = do
		log "HANDLEREGISTER IQSet jabber:iq:register phone" iq
		registerVerification db componentJid to iq
handleRegister db componentJid iq@(IQ { iqType = IQSet }) query
	| [form] <- isNamed (fromString "{jabber:x:data}x") =<< elementChildren query,
	  Just password <- getFormField form (fromString "password") = do
		log "HANDLEREGISTER IQSet jabber:x:data password" iq
		handleVerificationCode db componentJid password iq
handleRegister db componentJid iq@(IQ { iqType = IQSet, iqPayload = Just payload }) query
	| [passwordEl] <- isNamed (fromString "{jabber:iq:register}password") =<< elementChildren query = do
		log "HANDLEREGISTER IQSet jabber:iq:register password" iq
		handleVerificationCode db componentJid (mconcat $ elementText passwordEl) iq
handleRegister db componentJid iq@(IQ { iqType = IQSet }) query
	| [_] <- isNamed (fromString "{jabber:iq:register}remove") =<< elementChildren query = do
		log "HANDLEREGISTER IQSet jabber:iq:register remove" iq
		tel <- maybe mempty T.pack <$> TC.runTCM (TC.get db $ T.unpack (maybe mempty bareTxt $ iqFrom iq) <> "\0registered")
		forM_ (telToJid tel (formatJID componentJid) >>= \cheoJid -> tcKey cheoJid "registered") $ \regKey ->
			TC.runTCM $ TC.out db regKey
		void $ TC.runTCM $ TC.out db $ T.unpack (maybe mempty bareTxt $ iqFrom iq) <> "\0registered"
		return [mkStanzaRec $ iq {
			iqTo = iqFrom iq,
			iqFrom = iqTo iq,
			iqType = IQResult,
			iqPayload = Just $ Element (fromString "{jabber:iq:register}query") [] []
		}]
handleRegister _ _ iq@(IQ { iqType = typ }) _
	| typ `elem` [IQGet, IQSet] = do
		log "HANDLEREGISTER return error" iq
		return [mkStanzaRec $ iq {
			iqTo = iqFrom iq,
			iqFrom = iqTo iq,
			iqType = IQError,
			iqPayload = Just $ Element (fromString "{jabber:component:accept}error")
				[(fromString "{jabber:component:accept}type", [ContentText $ fromString "cancel"])]
				[NodeElement $ Element (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}feature-not-implemented") [] []]
		}]
handleRegister _ _ iq _ = do
	log "HANDLEREGISTER UNKNOWN" iq
	return []

componentStanza db _ _ _ _ _ _ componentJid (ReceivedMessage (m@Message { messageTo = Just (JID { jidNode = Nothing }), messageFrom = Just from}))
	| Just _ <- getBody "jabber:component:accept" m = return [
			mkStanzaRec $ mkSMS componentJid from (s"Instead of sending messages to " ++ formatJID componentJid ++ s" directly, you can SMS your contacts by sending messages to +1<phone-number>@" ++ formatJID componentJid ++ s" Jabber IDs.  Or, for support, come talk to us in xmpp:discuss@conference.soprani.ca?join")
		]
	| otherwise = log "WEIRD BODYLESS MESSAGE DIRECT TO COMPONENT" m >> return []
componentStanza _ _ _ _ _ _ _ _ (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from}))
	| [x] <- isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< messagePayloads m,
	  not $ null $ code "104" =<< isNamed (fromString "{http://jabber.org/protocol/muc#user}status") =<< elementChildren x = do
		log "CODE104" (to, from)
		queryDisco from to
componentStanza db (Just smsJid) _ _ _ _ _ componentJid (ReceivedMessage (m@Message { messageTo = Just to, messageFrom = Just from})) = do
	log "RECEIVEDMESSAGE" m
	existingRoom <- tcGetJID db to "joined"
	componentMessage db componentJid m existingRoom (bareTxt from) resourceFrom smsJid $
		getBody "jabber:component:accept" m
	where
	resourceFrom = strResource <$> jidResource from
componentStanza _ (Just smsJid) _ _ toRejoinManager _ _ componentJid (ReceivedPresence p@(Presence { presenceType = PresenceError, presenceFrom = Just from, presenceTo = Just to, presenceID = Just id }))
	| fromString "CHEOGRAMREJOIN%" `T.isPrefixOf` id = do
		log "FAILED TO REJOIN, try again in 10s" p
		void $ forkIO $ threadDelay 10000000 >> atomically (writeTChan toRejoinManager $ ForceRejoin from to)
		return []
	| otherwise = do
		log "FAILED TO JOIN" p
		let errorText = maybe mempty (mconcat . (fromString "\n":) . elementText) $ listToMaybe $
			isNamed (fromString "{urn:ietf:params:xml:ns:xmpp-stanzas}text") =<<
			elementChildren =<< isNamed (fromString "{jabber:component:accept}error") =<< presencePayloads p
		return [mkStanzaRec $ mkSMS componentJid smsJid (fromString "* Failed to join " <> bareTxt from <> errorText)]
componentStanza db (Just smsJid) _ toRoomPresences toRejoinManager toJoinPartDebouncer _ componentJid (ReceivedPresence (Presence {
		presenceType = typ,
		presenceFrom = Just from,
		presenceTo = Just to,
		presencePayloads = payloads
	})) | typ `elem` [PresenceAvailable, PresenceUnavailable] = do
		existingRoom <- tcGetJID db to "joined"
		log "JOIN PART ROOM" (from, to, typ, existingRoom, payloads)
		handleJoinPartRoom db toRoomPresences toRejoinManager toJoinPartDebouncer componentJid existingRoom from to smsJid payloads (typ == PresenceAvailable)
componentStanza _ _ _ _ _ _ _ _ (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Nothing } })) = do
	log "SUBSCRIBE GATEWAY" (from, to)
	return [
			mkStanzaRec $ (emptyPresence PresenceSubscribed) {
				presenceTo = Just from,
				presenceFrom = Just to
			},
			mkStanzaRec $ (emptyPresence PresenceSubscribe) {
				presenceTo = Just from,
				presenceFrom = Just to
			},
			mkStanzaRec $ cheogramAvailable to from
		]
componentStanza db (Just smsJid) _ _ _ _ _ componentJid (ReceivedPresence (Presence { presenceType = PresenceSubscribe, presenceFrom = Just from, presenceTo = Just to@JID { jidNode = Just _ } })) = do
	log "SUBSCRIBE TEL" (from, to)
	stanzas <- routeDiscoOrReply db componentJid from smsJid "CHEOGRAM%query-then-send-presence" $ telAvailable to from []
	return $ [
			mkStanzaRec $ (emptyPresence PresenceSubscribed) {
				presenceTo = Just from,
				presenceFrom = Just to
			},
			mkStanzaRec $ (emptyPresence PresenceSubscribe) {
				presenceTo = Just from,
				presenceFrom = Just to
			}
		] ++ stanzas
componentStanza _ _ _ _ _ _ _ _ (ReceivedPresence (</