{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module XMPPTypes ( module XMPPTypes , module SocketLike ) where import Network.Socket ( Family(..) , getAddrInfo , addrCanonName , addrAddress , defaultHints , AddrInfo(..) , AddrInfoFlag(..) ) import Network.BSD ( getHostName , hostName , hostAliases ) import Control.Concurrent.STM (TChan) import qualified Data.ByteString.Char8 as S ( ByteString , pack ) import Data.ByteString.Lazy.Char8 as L ( ByteString , unpack , pack , splitWith , uncons , takeWhile , fromChunks ) import qualified Text.Show.ByteString as L import qualified Data.Text as S hiding (pack) import Data.Binary.Builder as B import Data.Binary.Put import Data.Set as Set (Set) import Data.Map as Map (Map) import Control.DeepSeq import ByteStringOperators import SocketLike import GetHostByAddr import Data.Maybe (listToMaybe) import Data.XML.Types as XML (Event,Name,Content) data ClientCommands = Send [XML.Event] | BoundToResource | InterestedInRoster | Chat Message | QuitThread deriving Prelude.Show class JabberClientSession session where data XMPPClass session newSession :: SocketLike sock => XMPPClass session -> sock -> IO session setResource :: session -> ByteString -> IO () setPresence :: session -> JabberShow -> IO () getJID :: session -> IO JID closeSession :: session -> IO () subscribe :: session -> Maybe JID -> IO (TChan Presence) subscribeToRoster :: session -> IO (TChan RosterEvent) clientChannel :: session -> TChan ClientCommands forCachedPresence :: session -> (Presence -> IO ()) -> IO () sendPending :: session -> IO () getMyBuddies :: session -> IO [ByteString] getMySubscribers :: session -> IO [ByteString] getMyOthers :: session -> IO [ByteString] getMyPending :: session -> IO [ByteString] getMySolicited :: session -> IO [ByteString] addSolicited :: session -> ByteString -> JID -> IO () isSubscribed :: session -> ByteString -> IO Bool isBuddy :: session -> ByteString -> IO Bool approveSubscriber :: session -> ByteString -> IO () rejectSubscriber :: session -> ByteString -> IO () sendChat :: session -> Message -> IO () class JabberPeerSession session where data XMPPPeerClass session newPeerSession :: SocketLike sock => XMPPPeerClass session -> sock -> IO session closePeerSession :: session -> IO () peerAddress :: session -> Peer userStatus :: session -> ByteString -> IO [Presence] announcePresence :: session -> Presence -> IO () peerSessionFactory :: session -> XMPPPeerClass session sendPeerMessage :: session -> OutBoundMessage -> IO () getBuddies :: XMPPPeerClass session -> ByteString -> IO [ByteString] getSubscribers :: XMPPPeerClass session -> ByteString -> IO [ByteString] processApproval :: session -> ByteString -> JID -> IO () processRejection :: session -> ByteString -> JID -> IO () processRequest :: session -> ByteString -> JID -> IO () sendChatToClient :: session -> Message -> IO () -- | Jabber ID (JID) datatype data JID = JID { name :: Maybe ByteString , peer :: Peer , resource :: Maybe ByteString } deriving (Eq,Ord) data JabberShow = Offline | ExtendedAway | Away | DoNotDisturb | Available | Chatty deriving (Prelude.Show,Enum,Ord,Eq,Read) withResource (JID n p _) rsc = JID n p rsc data Presence = Presence JID JabberShow deriving Prelude.Show data RosterEvent = RequestedSubscription {- user: -} ByteString {- contact: -} ByteString | NewBuddy {- user: -} ByteString {- contact: -} ByteString | RemovedBuddy {- user: -} ByteString {- contact: -} ByteString | PendingSubscriber {- user: -} ByteString {- contact: -} ByteString | NewSubscriber {- user: -} ByteString {- contact: -} ByteString | RejectSubscriber {- user: -} ByteString {- contact: -} ByteString deriving Prelude.Show data Peer = LocalHost | RemotePeer SockAddr deriving (Eq,Prelude.Show) instance Ord Peer where LocalHost <= _ = True RemotePeer (SockAddrUnix a) <= RemotePeer (SockAddrUnix b) = a <= b RemotePeer (SockAddrUnix _) <= _ = True RemotePeer (SockAddrInet aport a) <= RemotePeer (SockAddrInet bport b) = (a,aport) <= (b,bport) RemotePeer (SockAddrInet aport a) <= _ = True RemotePeer (SockAddrInet6 aport aflow a ascope) <= RemotePeer (SockAddrInet6 bport bflow b bscope) = (a,aport,ascope,aflow) <= (b,bport,bscope,bflow) a <= b = False instance L.Show JID where showp (JID n s r ) = putBuilder . B.fromLazyByteString $ n <$++> "@" showPeer s <++?> "/" <++$> r instance Prelude.Show JID where show jid = L.unpack $ L.show jid instance NFData JID where rnf v@(JID n s r) = n `seq` s `seq` r `seq` () jid user host rsrc = JID (Just user) host (Just rsrc) showPeer :: Peer -> ByteString showPeer LocalHost = "localhost" showPeer (RemotePeer addr@(SockAddrInet _ _)) = pack $ stripColon (Prelude.show addr) where stripColon s = pre where (pre,port) = break (==':') s showPeer (RemotePeer addr@(SockAddrInet6 _ _ _ _)) = pack $ stripColon (Prelude.show addr) where stripColon s = if null bracket then pre else pre ++ "]" where (pre,bracket) = break (==']') s is_remote (RemotePeer _) = True is_remote _ = False discardPort (RemotePeer addr) = RemotePeer (withoutPort addr) discardPort x = x parseHostNameJID :: ByteString -> IO JID parseHostNameJID jid = do let (name,peer_string,rsc) = splitJID jid hints = Just $ defaultHints { addrFlags = [ AI_CANONNAME ] } peer <- do if peer_string=="localhost" then return LocalHost else do -- putStrLn $ "getAddrInfo 3 " ++ Prelude.show ( Just (unpack peer_string)) info <- getAddrInfo hints (Just (unpack peer_string)) Nothing -- (Just "xmpp-server") let info0 = head info cname = addrCanonName info0 if cname==Just "localhost" then return LocalHost else do self <- getHostName return $ if Just self==cname then LocalHost else RemotePeer (addrAddress info0) return $ JID name peer rsc splitJID :: ByteString -> (Maybe ByteString,ByteString,Maybe ByteString) splitJID bjid = let xs = L.splitWith (=='@') bjid ys = L.splitWith (=='/') (last xs) server = head ys name = case xs of (n:s:_) -> Just n (s:_) -> Nothing rsrc = case ys of (s:_:_) -> Just $ last ys _ -> Nothing in (name,server,rsrc) strip_brackets s = case L.uncons s of Just ('[',t) -> L.takeWhile (/=']') t _ -> s parseAddressJID :: ByteString -> IO JID parseAddressJID jid = do let (name,peer_string,rsc) = splitJID jid hints = Just $ defaultHints { addrFlags = [ {- AI_NUMERICHOST, -} AI_CANONNAME ] } peer_string' = unpack . strip_brackets $ peer_string peer <- do -- putStrLn $ "getAddrInfo 2 " ++ Prelude.show ( Just (unpack peer_string)) info <- getAddrInfo hints (Just peer_string') Nothing -- (Just "xmpp-server") let info0 = head info return . RemotePeer . addrAddress $ info0 return $ JID name peer rsc peerAddr :: Peer -> SockAddr peerAddr (RemotePeer addr) = addr -- peerAddr LocalHost = throw exception socketFamily (SockAddrInet _ _) = AF_INET socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6 socketFamily (SockAddrUnix _) = AF_UNIX withPort (SockAddrInet _ a) port = SockAddrInet (toEnum port) a withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c withoutPort = (`withPort` 0) data MessageThread = MessageThread { msgThreadParent :: Maybe S.Text, msgThreadContent :: S.Text } deriving (Show,Eq) data LangSpecificMessage = LangSpecificMessage { msgBody :: Maybe S.Text, msgSubject :: Maybe S.Text, msgElements :: Set (XML.Name, [(Name, [Content])], S.Text ) } deriving (Show,Eq) data Message = Message { msgTo :: JID, msgFrom :: JID, msgThread :: Maybe MessageThread, msgLangMap :: Map S.Text (LangSpecificMessage) } deriving (Show,Eq) data OutBoundMessage = OutBoundPresence Presence | PresenceProbe JID JID | Solicitation JID JID | Approval JID JID | Rejection JID JID | OutBoundMessage Message | Disconnect deriving Prelude.Show getNamesForPeer :: Peer -> IO [S.ByteString] getNamesForPeer LocalHost = fmap ((:[]) . S.pack) getHostName getNamesForPeer peer@(RemotePeer addr) = do ent <- getHostByAddr addr -- AF_UNSPEC addr let names = hostName ent : hostAliases ent return . map S.pack $ names asHostNameJID :: JID -> IO (Maybe ByteString) asHostNameJID jid = do let n = name jid rsc = resource jid names <- getNamesForPeer (peer jid) let tostr p = n <$++> "@" L.fromChunks [p] <++?> "/" <++$> rsc jidstrs = fmap tostr names return (listToMaybe jidstrs)