M Main.hs => Main.hs +69 -5
@@ 10,7 10,7 @@ import Control.Concurrent.STM
import Data.Foldable (forM_, mapM_, toList)
import Data.Traversable (forM, mapM)
import System.Environment (getArgs)
-import Control.Error (readZ, syncIO, runExceptT, MaybeT(..), hoistMaybe, headZ)
+import Control.Error (readZ, syncIO, runExceptT, MaybeT(..), hoistMaybe, headZ, hush)
import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Network (PortID(PortNumber))
import Network.URI (parseURI, uriPath)
@@ 34,12 34,16 @@ 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 as BS
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 Network.Protocol.XMPP as XMPP -- should import qualified
import Network.Protocol.XMPP.Internal -- should import qualified
import Util
+import qualified RedisURL
import qualified ConfigureDirectMessageRoute
instance Ord JID where
@@ 1054,7 1058,7 @@ participantJid payloads =
elementChildren =<<
isNamed (fromString "{http://jabber.org/protocol/muc#user}x") =<< payloads
-component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toComponent processDirectMessageRouteConfig jingleHandler componentJid registrationJids conferenceServers = do
+component db redis backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toComponent processDirectMessageRouteConfig jingleHandler componentJid registrationJids conferenceServers = do
thread <- forkXMPP $ forever $ flip catchError (log "component EXCEPTION") $ do
stanza <- liftIO $ atomically $ readTChan toComponent
@@ 1073,6 1077,56 @@ component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer toC
flip catchError (\e -> liftIO (log "component part 2 EXCEPTION" e >> killThread thread)) $ forever $ do
stanza <- getStanza
+ liftIO $ forkIO $ case stanza of
+ (ReceivedPresence p@(Presence { presenceType = PresenceAvailable, presenceFrom = Just from, presenceTo = Just to }))
+ | Just returnFrom <- parseJID (bareTxt to ++ s"/capsQuery") ->
+ let
+ cheogramBareJid = escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid
+ caps = child (s"{http://jabber.org/protocol/caps}c") p
+ show = maybe mempty mconcat $ elementText <$> child (s"{jabber:component:accept}show") p
+ priority = fromMaybe 0 $ (readZ . textToString . mconcat =<< elementText <$> child (s"{jabber:component:accept}priority") p)
+ pavailableness = availableness show priority
+ in
+ -- Caps?
+ case (XML.attributeText (s"ver") =<< caps, XML.attributeText (s"node") =<< caps) of
+ -- Yes: write ver to <barejid>/resource and <cheoagramjid>/resource
+ (Just ver, Just node) -> do
+ let bver = Base64.decodeLenient $ encodeUtf8 ver
+ let val = LZ.toStrict $ Builder.toLazyByteString (Builder.word16BE pavailableness ++ Builder.byteString bver)
+ Right exists <- Redis.runRedis redis $ do
+ Redis.hset (encodeUtf8 $ bareTxt from) (encodeUtf8 $ maybe mempty strResource $ jidResource from) val
+ Redis.hset (encodeUtf8 $ cheogramBareJid) (encodeUtf8 $ maybe mempty strResource $ jidResource from) val
+ -- ver in redis?
+ Redis.exists bver
+ -- Yes: done
+ -- No: send disco query, with node
+ when (not exists) $ mapM_ sendToComponent =<< queryDiscoWithNode (Just $ node ++ s"#" ++ ver) from returnFrom
+ -- No: write only availableness to redis. send disco query, no node
+ _ -> do
+ let val = LZ.toStrict $ Builder.toLazyByteString (Builder.word16BE pavailableness)
+ void $ Redis.runRedis redis $ do
+ Redis.hset (encodeUtf8 $ bareTxt from) (encodeUtf8 $ maybe mempty strResource $ jidResource from) val
+ Redis.hset (encodeUtf8 $ cheogramBareJid) (encodeUtf8 $ maybe mempty strResource $ jidResource from) val
+ mapM_ sendToComponent =<< queryDisco from returnFrom
+ (ReceivedPresence (Presence { presenceType = PresenceUnavailable, presenceFrom = Just from })) -> do
+ let cheogramBareJid = escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid
+ -- Delete <barejid>/resource and <cheogramjid>/resource
+ void $ Redis.runRedis redis $ do
+ Redis.hdel (encodeUtf8 $ bareTxt from) [encodeUtf8 $ maybe mempty strResource $ jidResource from]
+ Redis.hdel (encodeUtf8 $ cheogramBareJid) [encodeUtf8 $ maybe mempty strResource $ jidResource from]
+ (ReceivedIQ iq@(IQ { iqType = IQResult, iqFrom = Just from }))
+ | Just query <- child (s"{http://jabber.org/protocol/disco#info}query") iq -> do
+ let cheogramBareJid = escapeJid (bareTxt from) ++ s"@" ++ formatJID componentJid
+ let bver = discoToCapsHash query
+ -- Write <ver> with the list of features
+ void $ Redis.runRedis redis $ do
+ Redis.sadd bver (encodeUtf8 <$> discoVars query)
+ -- Write ver to <barejid>/resource and <cheogramjid>/resource
+ Right ravailableness <- (fmap . fmap) (maybe (BS.pack [0,0]) (BS.take 2)) $ Redis.hget (encodeUtf8 $ bareTxt from) (encodeUtf8 $ maybe mempty strResource $ jidResource from)
+ let val = ravailableness ++ bver
+ Redis.hset (encodeUtf8 $ bareTxt from) (encodeUtf8 $ maybe mempty strResource $ jidResource from) val
+ Redis.hset (encodeUtf8 $ cheogramBareJid) (encodeUtf8 $ maybe mempty strResource $ jidResource from) val
+ _ -> return ()
case (stanzaFrom $ receivedStanza stanza, stanzaTo $ receivedStanza stanza, mapToBackend backendHost =<< stanzaTo (receivedStanza stanza), fmap strNode . jidNode =<< stanzaTo (receivedStanza stanza), stanza) of
(Just from, Just to, _, _, _)
| strDomain (jidDomain from) == backendHost,
@@ 1751,7 1805,8 @@ data Config = Config {
s5bListenOn :: [Socket.SockAddr],
s5bAdvertise :: ServerConfig,
jingleStore :: FilePath,
- jingleStoreURL :: Text
+ jingleStoreURL :: Text,
+ redis :: Redis.ConnectInfo
} deriving (Dhall.Generic, Dhall.Interpret, Show)
instance Dhall.Interpret JID where
@@ 1776,6 1831,14 @@ instance Dhall.Interpret Socket.SockAddr where
Dhall.expected = Dhall.Text
}
+instance Dhall.Interpret Redis.ConnectInfo where
+ autoWith _ = Dhall.Type {
+ Dhall.extract = (\(Dhall.TextLit (Dhall.Chunks _ txt)) ->
+ hush $ RedisURL.parseConnectInfo $ textToString txt
+ ),
+ Dhall.expected = Dhall.Text
+ }
+
main :: IO ()
main = do
hSetBuffering stdout LineBuffering
@@ 1791,10 1854,11 @@ main = do
mapM_ putStanza =<< registerToGateway componentJid gatewayJid (fromString did) (fromString password)
liftIO $ threadDelay 1000000
[config] -> do
- (Config componentJid (ServerConfig host port) secret backendHost rawdid registrationJid conferences s5bListenOn (ServerConfig s5bhost s5bport) jingleStore jingleStoreURL) <- Dhall.input Dhall.auto (fromString config)
+ (Config componentJid (ServerConfig host port) secret backendHost rawdid registrationJid conferences s5bListenOn (ServerConfig s5bhost s5bport) jingleStore jingleStoreURL redisConnectInfo) <- Dhall.input Dhall.auto (fromString config)
log "" "Starting..."
let Just did = normalizeTel rawdid
db <- openTokyoCabinet "./db.tcdb" :: IO TC.HDB
+ redis <- Redis.checkedConnect redisConnectInfo
toJoinPartDebouncer <- atomically newTChan
sendToComponent <- atomically newTChan
toRoomPresences <- atomically newTChan
@@ 1869,5 1933,5 @@ main = do
(log "runComponent ENDED" <=< (runExceptT . syncIO)) $
runComponent (Server componentJid host (PortNumber port)) secret
- (component db backendHost toRoomPresences toRejoinManager toJoinPartDebouncer sendToComponent processDirectMessageRouteConfig jingleHandler componentJid [registrationJid] conferences)
+ (component db redis backendHost toRoomPresences toRejoinManager toJoinPartDebouncer sendToComponent processDirectMessageRouteConfig jingleHandler componentJid [registrationJid] conferences)
_ -> log "ERROR" "Bad arguments"
A RedisURL.hs => RedisURL.hs +95 -0
@@ 0,0 1,95 @@
+{-
+Copyright (c)2011, Falko Peters
+Some modifications by Stephen Paul Weber
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Falko Peters nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+-}
+module RedisURL (parseConnectInfo) where
+
+import Prelude ()
+import BasicPrelude
+import Control.Error.Util (note)
+import Control.Monad (guard)
+import Data.Monoid ((<>))
+import Database.Redis (ConnectInfo(..), defaultConnectInfo, PortID(..))
+import Network.HTTP.Base
+import Network.HTTP.Types (parseSimpleQuery)
+import Network.URI (URI, parseURI, uriPath, uriScheme, uriQuery)
+import Text.Read (readMaybe)
+
+import qualified Data.ByteString.Char8 as C8
+
+parseConnectInfo :: String -> Either String ConnectInfo
+parseConnectInfo url = do
+ uri <- note "Invalid URI" $ parseURI url
+ case uriScheme uri of
+ "redis:" -> parseRedisScheme uri
+ "unix:" -> parseUnixScheme uri
+ _ -> Left "Invalid scheme"
+
+parseUnixScheme :: URI -> Either String ConnectInfo
+parseUnixScheme uri =
+ return defaultConnectInfo
+ { connectHost = ""
+ , connectPort = UnixSocket path
+ , connectAuth = C8.pack <$> (password =<< uriAuth)
+ , connectDatabase = db
+ }
+ where
+ path = case uriPath uri of
+ ('/':_) -> uriPath uri
+ _ -> '/' : uriPath uri
+ db = fromMaybe 0 $ readMaybe . textToString . decodeUtf8 =<<
+ lookup (encodeUtf8 $ fromString "db") query
+ query = parseSimpleQuery (encodeUtf8 $ fromString $ uriQuery uri)
+ uriAuth = parseURIAuthority $ uriToAuthorityString uri
+
+parseRedisScheme :: URI -> Either String ConnectInfo
+parseRedisScheme uri = do
+ uriAuth <- note "Missing or invalid Authority"
+ $ parseURIAuthority
+ $ uriToAuthorityString uri
+
+ let h = host uriAuth
+ let dbNumPart = dropWhile (== '/') (uriPath uri)
+
+ db <- if null dbNumPart
+ then return $ connectDatabase defaultConnectInfo
+ else note ("Invalid port: " <> dbNumPart) $ readMaybe dbNumPart
+
+ return defaultConnectInfo
+ { connectHost = if null h
+ then connectHost defaultConnectInfo
+ else h
+ , connectPort = maybe (connectPort defaultConnectInfo)
+ (PortNumber . fromIntegral) $ port uriAuth
+ , connectAuth = C8.pack <$> password uriAuth
+ , connectDatabase = db
+ }
M Util.hs => Util.hs +81 -1
@@ 2,13 2,16 @@ module Util where
import Prelude ()
import BasicPrelude
+import Data.Word (Word16)
+import Data.Bits (shiftL, (.|.))
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 Data.XML.Types as XML (Name, Element(..), Node(NodeElement), isNamed, elementText, elementChildren, attributeText)
import Crypto.Random (getSystemDRG, withRandomBytes)
import Data.ByteString.Base58 (bitcoinAlphabet, encodeBase58)
+import Data.Digest.Pure.SHA (sha1, bytestringDigest)
import Data.Void (absurd)
import UnexceptionalIO (Unexceptional)
import qualified UnexceptionalIO as UIO
@@ 16,6 19,7 @@ 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
+import qualified Data.ByteString.Lazy as LZ
instance Unexceptional XMPP.XMPP where
lift = liftIO . UIO.lift
@@ 87,6 91,24 @@ sanitizeSipLocalpart localpart
where
candidate = fst $ T.breakOn (s"@") $ unescapeJid localpart
+showAvailableness :: String -> Word8
+showAvailableness "chat" = 4
+showAvailableness "away" = 3
+showAvailableness "dnd" = 2
+showAvailableness "xa" = 1
+showAvailableness _ = 0
+
+priorityAvailableness :: Integer -> Word8
+priorityAvailableness priority
+ | priority > 127 = 0xff
+ | priority < -128 = 0x00
+ | otherwise = fromIntegral (priority + 128)
+
+availableness :: Text -> Integer -> Word16
+availableness sshow priority =
+ (fromIntegral (showAvailableness (textToString sshow)) `shiftL` 8) .|.
+ (fromIntegral (priorityAvailableness priority))
+
parsePhoneContext :: Text -> Maybe (Text, Text)
parsePhoneContext txt = hush $ Atto.parseOnly (
(,) <$> Atto.takeWhile isDigit <* Atto.string (s";phone-context=") <*> Atto.takeTill (Atto.inClass " ;")
@@ 116,3 138,61 @@ genToken n = do
child :: (XMPP.Stanza s) => Name -> s -> Maybe Element
child name = listToMaybe .
(isNamed name <=< XMPP.stanzaPayloads)
+
+attrOrBlank :: XML.Name -> XML.Element -> Text
+attrOrBlank name el = fromMaybe mempty $ XML.attributeText name el
+
+discoCapsIdentities :: XML.Element -> [Text]
+discoCapsIdentities query =
+ sort $
+ map (\identity -> mconcat $ intersperse (s"/") [
+ attrOrBlank (s"category") identity,
+ attrOrBlank (s"type") identity,
+ attrOrBlank (s"xml:lang") identity,
+ attrOrBlank (s"name") identity
+ ]) $
+ XML.isNamed (s"{http://jabber.org/protocol/disco#info}identity") =<<
+ XML.elementChildren query
+
+discoVars :: XML.Element -> [Text]
+discoVars query =
+ mapMaybe (XML.attributeText (s"var")) $
+ XML.isNamed (s"{http://jabber.org/protocol/disco#info}feature") =<<
+ XML.elementChildren query
+
+data DiscoForm = DiscoForm Text [(Text, [Text])] deriving (Show, Ord, Eq)
+
+oneDiscoForm :: XML.Element -> DiscoForm
+oneDiscoForm form =
+ DiscoForm form_type (filter ((/= s"FORM_TYPE") . fst) fields)
+ where
+ form_type = mconcat $ fromMaybe [] $ lookup (s"FORM_TYPE") fields
+ fields = sort $ map (\field ->
+ (
+ attrOrBlank (s"var") field,
+ sort (map (mconcat . XML.elementText) $ XML.isNamed (s"{jabber:x:data}value") =<< XML.elementChildren form)
+ )
+ ) $
+ XML.isNamed (s"{jabber:x:data}field") =<<
+ XML.elementChildren form
+
+discoForms :: XML.Element -> [DiscoForm]
+discoForms query =
+ sort $
+ map oneDiscoForm $
+ XML.isNamed (s"{jabber:x:data}x") =<<
+ XML.elementChildren query
+
+discoCapsForms :: XML.Element -> [Text]
+discoCapsForms query =
+ concatMap (\(DiscoForm form_type fields) ->
+ form_type : concatMap (uncurry (:)) fields
+ ) (discoForms query)
+
+discoToCaps :: XML.Element -> Text
+discoToCaps query =
+ (mconcat $ intersperse (s"<") (discoCapsIdentities query ++ discoVars query ++ discoCapsForms query)) ++ s"<"
+
+discoToCapsHash :: XML.Element -> ByteString
+discoToCapsHash query =
+ LZ.toStrict $ bytestringDigest $ sha1 $ LZ.fromStrict $ T.encodeUtf8 $ discoToCaps query
M cheogram.cabal => cheogram.cabal +4 -1
@@ 21,7 21,7 @@ extra-source-files:
executable cheogram
main-is: Main.hs
- other-modules: ConfigureDirectMessageRoute, Util
+ other-modules: ConfigureDirectMessageRoute, Util, RedisURL
default-language: Haskell2010
ghc-options: -Wno-tabs -Wno-orphans
@@ 37,7 37,10 @@ executable cheogram
cryptonite,
dhall,
errors,
+ hedis,
HostAndPort,
+ HTTP,
+ http-types,
jingle,
monad-loops,
monads-tf,