path: root/Presence/XMPPTypes.hs

{-# 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
        L.putUTF8Str . L.unpack $ 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 = SockAddrInet6 0 (0 {- FlowInfo -}) (0,0,0,1) (0 {- ScopeID -})

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,
                -- msgType
                -- msgId
                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
                        | Pong JID JID (Maybe Content)
                        | Unsupported JID JID (Maybe Content) XML.Name
                        | Disconnect
                        | ActivityBump Thunk
 deriving Prelude.Show

newtype Thunk = Thunk { runThunk :: IO () }

instance Show Thunk where
    show s = "thunk"

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)