From 86e16f72783bcb546dd3ac447237f729e68c710d Mon Sep 17 00:00:00 2001 From: joe Date: Thu, 27 Jun 2013 22:38:53 -0400 Subject: Started conduits-based XMPP module (will replace XMPPServer) --- Presence/ServerC.hs | 7 +++++ Presence/XMPP.hs | 36 ++++++++++++++++++++++ Presence/XMPPServer.hs | 69 ++--------------------------------------- Presence/XMPPTypes.hs | 84 ++++++++++++++++++++++++++++++++++++++++++++++++++ Presence/main.hs | 4 +++ 5 files changed, 133 insertions(+), 67 deletions(-) create mode 100644 Presence/XMPP.hs create mode 100644 Presence/XMPPTypes.hs diff --git a/Presence/ServerC.hs b/Presence/ServerC.hs index 3933c812..36e2d7bf 100644 --- a/Presence/ServerC.hs +++ b/Presence/ServerC.hs @@ -7,6 +7,7 @@ module ServerC , ConnId(..) , ServerHandle , quitListening + , dummyServerHandle ) where import Network.Socket as Socket @@ -39,6 +40,7 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.ByteString as S (ByteString) import System.IO (Handle) +import Control.Concurrent.MVar (newMVar) import ByteStringOperators import SocketLike @@ -50,6 +52,11 @@ newtype ConnId = ConnId Int newtype ServerHandle = ServerHandle Socket +dummyServerHandle = do + mvar <- newMVar Closed + let sock = MkSocket 0 AF_UNSPEC NoSocketType 0 mvar + return (ServerHandle sock) + quitListening :: ServerHandle -> IO () quitListening (ServerHandle socket) = sClose socket diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs new file mode 100644 index 00000000..f361641e --- /dev/null +++ b/Presence/XMPP.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts #-} +module XMPP + ( module XMPP + , module XMPPTypes + , quitListening + ) where + +import ServerC +import XMPPTypes + +import Data.HList +import Network.Socket (Family) +import Network.BSD (PortNumber) +import Control.Concurrent.STM + +listenForXmppClients + :: (HList t1, HExtend e l (HCons PortNumber t1), XMPPSession t) => + Family -> XMPPClass t -> e -> l -> IO ServerHandle +listenForXmppClients addr_family session_factory port st = do + putStrLn "unimplemented: listenForXmppClients" + dummyServerHandle + -- TODO + +listenForRemotePeers + :: (HList t1, HExtend e l (HCons PortNumber t1), XMPPSession t) => + Family -> XMPPClass t -> e -> l -> IO ServerHandle +listenForRemotePeers addrfamily session_factory port st = do + putStrLn "unimplemented: listenForRemotePeers" + dummyServerHandle + -- TODO + +seekRemotePeers :: XMPPConfig config => + config -> TChan Presence -> IO () +seekRemotePeers config chan = do + putStrLn "unimplemented: seekRemotePeers" + return () diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index e8ab5490..813c7c7b 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs @@ -6,6 +6,7 @@ -- {-# LANGUAGE GADTs #-} module XMPPServer ( module XMPPServer + , module XMPPTypes , quitListening ) where @@ -58,39 +59,13 @@ import Control.Concurrent.STM import Control.Concurrent import Control.Exception as Exception import Text.Show.ByteString as L -import Data.Binary.Builder as B -import Data.Binary.Put import qualified Data.Map as Map import GHC.Conc import Network.BSD hiding (getHostByAddr) import Control.Concurrent.Async import qualified Data.Set as Set import GetHostByAddr - -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 - --- | Jabber ID (JID) datatype -data JID = JID { name :: Maybe ByteString - , peer :: Peer - , resource :: Maybe ByteString - } - deriving (Eq,Ord) +import XMPPTypes is_remote (RemotePeer _) = True is_remote _ = False @@ -110,37 +85,10 @@ getNamesForPeer peer@(RemotePeer addr) = do return . map pack $ names -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 - peerAddr :: Peer -> SockAddr peerAddr (RemotePeer addr) = addr -- peerAddr LocalHost = throw exception -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) - -data JabberShow = Offline - | Away - | Available - deriving (Prelude.Show,Enum,Ord,Eq,Read) - -data Presence = Presence JID JabberShow - deriving Prelude.Show xmlifyPresenceForPeer sock (Presence jid stat) = do -- TODO: accept socket argument and determine local ip address @@ -184,19 +132,6 @@ instance NFData Presence where rnf (Presence jid stat) = rnf jid `seq` stat `seq` () -class XMPPSession session where - data XMPPClass session - newSession :: XMPPClass session -> Socket -> Handle -> IO session - setResource :: session -> ByteString -> IO () - getJID :: session -> IO JID - closeSession :: session -> IO () - subscribe :: session -> Maybe JID -> IO (TChan Presence) - announcePresence :: session -> Presence -> IO () - -class XMPPConfig config where - getBuddies :: config -> ByteString -> IO [ByteString] - getSubscribers :: config -> ByteString -> IO [ByteString] - greet host = L.unlines [ "" , " Socket -> Handle -> IO session + setResource :: session -> ByteString -> IO () + getJID :: session -> IO JID + closeSession :: session -> IO () + subscribe :: session -> Maybe JID -> IO (TChan Presence) + announcePresence :: session -> Presence -> IO () + +class XMPPConfig config where + getBuddies :: config -> ByteString -> IO [ByteString] + getSubscribers :: config -> ByteString -> IO [ByteString] + +-- | Jabber ID (JID) datatype +data JID = JID { name :: Maybe ByteString + , peer :: Peer + , resource :: Maybe ByteString + } + deriving (Eq,Ord) + +data JabberShow = Offline + | Away + | Available + deriving (Prelude.Show,Enum,Ord,Eq,Read) + +data Presence = Presence JID JabberShow + 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 + + diff --git a/Presence/main.hs b/Presence/main.hs index a0a80569..403a6ac7 100644 --- a/Presence/main.hs +++ b/Presence/main.hs @@ -25,7 +25,11 @@ import UTmp -- #endif import FGConsole +#ifdef HAXML import XMPPServer +#else +import XMPP +#endif import Data.HList import Control.Exception import LocalPeerCred -- cgit v1.2.3