summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Presence/XMPP.hs122
1 files changed, 69 insertions, 53 deletions
diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs
index 248d1ffb..7e513212 100644
--- a/Presence/XMPP.hs
+++ b/Presence/XMPP.hs
@@ -20,22 +20,83 @@ import Control.Concurrent.STM
20import Data.Conduit 20import Data.Conduit
21import qualified Data.Conduit.List as CL 21import qualified Data.Conduit.List as CL
22import Data.ByteString (ByteString) 22import Data.ByteString (ByteString)
23import Data.ByteString.Char8 (pack)
23import qualified Data.ByteString.Lazy.Char8 as L 24import qualified Data.ByteString.Lazy.Char8 as L
24 ( putStrLn 25 ( putStrLn
26 , fromChunks
25 ) 27 )
26import Control.Concurrent (forkIO,killThread) 28import Control.Concurrent (forkIO,killThread)
29import Control.Concurrent.Async
27import Control.Exception (handle,SomeException(..),finally) 30import Control.Exception (handle,SomeException(..),finally)
28import Control.Monad.IO.Class 31import Control.Monad.IO.Class
29import Control.Monad.Trans.Maybe 32import Control.Monad.Trans.Maybe
30import Todo 33import Todo
31import Control.Monad as Monad 34import Control.Monad as Monad
32import Text.XML.Stream.Parse 35import Text.XML.Stream.Parse
36import Text.XML.Stream.Render
37import Data.XML.Types as XML
38import Network.BSD (getHostName,hostName,hostAliases)
39import Data.Text.Lazy.Encoding (decodeUtf8)
40import Data.Text.Lazy (toStrict)
41import GetHostByAddr
33 42
34data Commands x = Send [x] | QuitThread 43data Commands = Send [XML.Event] | QuitThread
35 deriving Prelude.Show 44 deriving Prelude.Show
36 45
37xmlifyPresenceForClient :: Presence -> IO [x] 46getNamesForPeer :: Peer -> IO [ByteString]
38xmlifyPresenceForClient presence = todo 47getNamesForPeer LocalHost = fmap ((:[]) . pack) getHostName
48getNamesForPeer peer@(RemotePeer addr) = do
49 ent <- getHostByAddr addr -- AF_UNSPEC addr
50 let names = hostName ent : hostAliases ent
51 return . map pack $ names
52
53
54xmlifyPresenceForClient :: Presence -> IO [XML.Event]
55xmlifyPresenceForClient (Presence jid stat) = do
56 let n = name jid
57 rsc = resource jid
58 names <- getNamesForPeer (peer jid)
59 let tostr p = decodeUtf8 $ n <$++> "@" <?++> L.fromChunks [p] <++?> "/" <++$> rsc
60 jidstrs = fmap (toStrict . tostr) names
61 return (concatMap presenceEvents jidstrs)
62 where
63 presenceEvents jidstr =
64 [ EventBeginElement "presence" (("from",[ContentText jidstr]):typ stat)
65 , EventBeginElement "show" []
66 , EventContent (ContentText . shw $ stat)
67 , EventEndElement "show"
68 , EventEndElement "presence"
69 ]
70 typ Offline = [("type",[ContentText "unavailable"])]
71 typ _ = []
72 shw Available = "chat"
73 shw Away = "away"
74 shw Offline = "away" -- Is this right?
75
76
77
78fromClient :: MonadIO m => TChan Commands -> Sink XML.Event m ()
79fromClient cmdChan = fix $ \loop -> do
80 mb <- await
81 maybe (return ())
82 (\packet -> do
83 liftIO (L.putStrLn $ "client-in: " <++> bshow packet)
84 loop)
85 mb
86
87toClient :: MonadIO m => TChan Presence -> TChan Commands -> Source m XML.Event
88toClient pchan cmdChan = fix $ \loop -> do
89 event <- liftIO . atomically $
90 orElse (fmap Left $ readTChan pchan)
91 (fmap Right $ readTChan cmdChan)
92 case event of
93 Right QuitThread ->
94 return ()
95 Left presence -> do
96 xs <- liftIO $ xmlifyPresenceForClient presence
97 Monad.mapM_ yield xs
98 loop
99
39 100
40handleClient 101handleClient
41 :: (SocketLike sock, HHead l (XMPPClass session), 102 :: (SocketLike sock, HHead l (XMPPClass session),
@@ -50,58 +111,12 @@ handleClient st src snk = do
50 pchan <- subscribe session Nothing 111 pchan <- subscribe session Nothing
51 cmdChan <- atomically newTChan 112 cmdChan <- atomically newTChan
52 113
53 114 writer <- async ( toClient pchan cmdChan $$ renderBytes def =$ snk )
54 {- 115 finally ( src $= parseBytes def $$ fromClient cmdChan )
55 reader <- forkIO $ do 116 $ do
56 flip ($$) snk $
57 handle (\(SomeException e) -> liftIO (L.putStrLn $ "quit reader via exception: "<++>bshow e) >> return ()) $
58 fix $ \loop -> do
59 event <- liftIO . atomically $
60 (fmap Left $ readTChan pchan)
61 `orElse`
62 (fmap Right $ readTChan cmdChan)
63 case event of
64 Left presence -> do
65 liftIO (L.putStrLn $ "PRESENCE: " <++> bshow presence)
66 -- TODO: it violates spec to send presence information before
67 -- a resource is bound.
68 -- r <- xmlifyPresenceForClient presence
69 -- yield r
70 -- -- hPutStrLn h r
71 -- liftIO (L.putStrLn $ "\nOUT client:\n" <++> r)
72 Right (Send r) ->
73 mapM_ yield r
74 -- yield r
75 -- -- hPutStrLn h r
76 loop
77 -}
78 let outgoing = do
79 event <- liftIO . atomically $
80 (fmap Left $ readTChan pchan)
81 `orElse`
82 (fmap Right $ readTChan cmdChan)
83 case event of
84 Right QuitThread -> return ()
85 Left presence -> do
86 xs <- liftIO $ xmlifyPresenceForClient presence
87 Monad.mapM_ yield xs
88 outgoing
89
90 incomming = do
91 mb <- await
92 maybe (return ())
93 (\packet -> do
94 liftIO (L.putStrLn $ "client-in: " <++> bshow packet)
95 incomming)
96 mb
97
98 sendingThread <- forkIO (outgoing $$ snk)
99 let quit = do
100 atomically $ writeTChan cmdChan QuitThread 117 atomically $ writeTChan cmdChan QuitThread
118 wait writer
101 closeSession session 119 closeSession session
102 -- killThread sendingThread
103 finally ( src $= parseBytes def $$ incomming )
104 quit
105 120
106listenForXmppClients :: 121listenForXmppClients ::
107 (HList l, HHead l (XMPPClass session), HExtend e1 l2 l1, 122 (HList l, HHead l (XMPPClass session), HExtend e1 l2 l1,
@@ -122,4 +137,5 @@ seekRemotePeers :: XMPPConfig config =>
122 config -> TChan Presence -> IO () 137 config -> TChan Presence -> IO ()
123seekRemotePeers config chan = do 138seekRemotePeers config chan = do
124 putStrLn "unimplemented: seekRemotePeers" 139 putStrLn "unimplemented: seekRemotePeers"
140 -- TODO
125 return () 141 return ()