summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Presence/XMPPServer.hs56
-rw-r--r--xmppServer.hs45
2 files changed, 89 insertions, 12 deletions
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index af986645..eb680002 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -14,6 +14,7 @@ module XMPPServer
14 , peerKeyToText 14 , peerKeyToText
15 , peerKeyToResolvedName 15 , peerKeyToResolvedName
16 , addrToText 16 , addrToText
17 , sendModifiedStanzaToPeer
17 ) where 18 ) where
18import Debug.Trace 19import Debug.Trace
19import Control.Monad.Trans.Resource (runResourceT) 20import Control.Monad.Trans.Resource (runResourceT)
@@ -245,6 +246,38 @@ prettyPrint prefix =
245 =$= CB.lines 246 =$= CB.lines
246 =$ CL.mapM_ (wlogb . (prefix <>)) 247 =$ CL.mapM_ (wlogb . (prefix <>))
247 248
249swapNamespace old new = awaitForever swapit
250 where
251 swapit (EventBeginElement n as) | nameNamespace n==Just old =
252 yield $ EventBeginElement (n { nameNamespace = Just new }) as
253 swapit (EventEndElement n) | nameNamespace n==Just old =
254 yield $ EventEndElement (n { nameNamespace = Just new })
255 swapit x = yield x
256
257fixHeaders Stanza { stanzaTo=mto, stanzaFrom=mfrom } = do
258 x <- await
259 maybe (return ()) f x
260 where
261 f (EventBeginElement n as) = do yield $ EventBeginElement n (update as)
262 awaitForever yield
263 f x = yield x >> awaitForever yield
264 update as = as''
265 where
266 as' = maybe as (\to->attr "to" to:as) mto
267 as'' = maybe as' (\from->attr "from" from:as') mfrom
268
269
270sendModifiedStanzaToPeer stanza chan = do
271 (echan,clsrs,quitvar) <- conduitToChan c
272 ioWriteChan chan
273 stanza { stanzaChan = echan
274 , stanzaClosers = clsrs
275 , stanzaInterrupt = quitvar
276 -- TODO id? origin?
277 }
278 where
279 c = stanzaToConduit stanza =$= swapNamespace "jabber:client" "jabber:server" =$= fixHeaders stanza
280
248-- id,to, and from are taken as-is from reply list 281-- id,to, and from are taken as-is from reply list
249sendReply donevar stype reply replychan = do 282sendReply donevar stype reply replychan = do
250 if null reply then return () 283 if null reply then return ()
@@ -802,6 +835,15 @@ xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
802 else [] ) 835 else [] )
803 yield $ EventEndElement "{jabber:iq:roster}item" 836 yield $ EventEndElement "{jabber:iq:roster}item"
804 837
838conduitToChan c = do
839 chan <- atomically newTChan
840 clsrs <- atomically $ newTVar (Just [])
841 quitvar <- atomically $ newEmptyTMVar
842 forkIO $ do
843 c =$= copyToChannel id chan clsrs $$ awaitForever (const $ return ())
844 atomically $ writeTVar clsrs Nothing
845 return (chan,clsrs,quitvar)
846
805sendRoster query xmpp replyto = do 847sendRoster query xmpp replyto = do
806 let k = case stanzaOrigin query of 848 let k = case stanzaOrigin query of
807 NetworkOrigin k _ -> Just k 849 NetworkOrigin k _ -> Just k
@@ -834,12 +876,7 @@ sendRoster query xmpp replyto = do
834 xmlifyRosterItems solicited "none" subnone 876 xmlifyRosterItems solicited "none" subnone
835 yield $ EventEndElement "{jabber:iq:roster}query" 877 yield $ EventEndElement "{jabber:iq:roster}query"
836 yield $ EventEndElement "{jabber:client}iq" 878 yield $ EventEndElement "{jabber:client}iq"
837 chan <- atomically newTChan 879 (chan,clsrs,quitvar) <- conduitToChan roster
838 clsrs <- atomically $ newTVar (Just [])
839 quitvar <- atomically $ newEmptyTMVar
840 forkIO $ do
841 roster =$= copyToChannel id chan clsrs $$ awaitForever (const $ return ())
842 atomically $ writeTVar clsrs Nothing
843 ioWriteChan replyto 880 ioWriteChan replyto
844 Stanza { stanzaType = Roster 881 Stanza { stanzaType = Roster
845 , stanzaId = (stanzaId query) 882 , stanzaId = (stanzaId query)
@@ -904,7 +941,8 @@ monitor sv params xmpp = do
904 sendRoster stanza xmpp replyto 941 sendRoster stanza xmpp replyto
905 xmppSubscribeToRoster xmpp k 942 xmppSubscribeToRoster xmpp k
906 Message {} -> do 943 Message {} -> do
907 let fail = return () -- todo 944 let fail = wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO
945 stanza2 <- atomically $ cloneStanza stanza
908 xmppDeliverMessage xmpp fail stanza 946 xmppDeliverMessage xmpp fail stanza
909 PresenceStatus {} -> do 947 PresenceStatus {} -> do
910 xmppInformClientPresence xmpp k stanza 948 xmppInformClientPresence xmpp k stanza
@@ -914,13 +952,15 @@ monitor sv params xmpp = do
914 sendReply quitVar Error reply replyto 952 sendReply quitVar Error reply replyto
915 _ -> return () 953 _ -> return ()
916 _ -> return () 954 _ -> return ()
955 -- We need to clone in the case the stanza is passed on as for Message.
956 dup <- atomically $ cloneStanza stanza
917 let typ = Strict8.pack $ c ++ "->"++(concat . take 1 . words $ show (stanzaType stanza))++" " 957 let typ = Strict8.pack $ c ++ "->"++(concat . take 1 . words $ show (stanzaType stanza))++" "
918 c = case stanzaOrigin stanza of 958 c = case stanzaOrigin stanza of
919 LocalPeer -> "*" 959 LocalPeer -> "*"
920 NetworkOrigin (ClientKey {}) _ -> "C" 960 NetworkOrigin (ClientKey {}) _ -> "C"
921 NetworkOrigin (PeerKey {}) _ -> "P" 961 NetworkOrigin (PeerKey {}) _ -> "P"
922 wlog "" 962 wlog ""
923 stanzaToConduit stanza $$ prettyPrint typ 963 stanzaToConduit dup $$ prettyPrint typ
924 964
925 ] 965 ]
926 action 966 action
diff --git a/xmppServer.hs b/xmppServer.hs
index 8f13e2d8..69b6cec5 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -28,12 +28,17 @@ import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,E
28import System.Posix.User (getUserEntryForID,userName) 28import System.Posix.User (getUserEntryForID,userName)
29import qualified Data.ByteString.Lazy.Char8 as L 29import qualified Data.ByteString.Lazy.Char8 as L
30import qualified ConfigFiles 30import qualified ConfigFiles
31import Data.Maybe (listToMaybe)
31 32
32import UTmp (ProcessID,users) 33import UTmp (ProcessID,users)
33import LocalPeerCred 34import LocalPeerCred
34import XMPPServer 35import XMPPServer
35-- import Server 36-- import Server
36 37
38unsplitJID (n,h,r) = jid
39 where
40 jid0 = maybe h (\n->n<>"@"<>h) n
41 jid = maybe jid0 (\r->jid0<>"/"<>r) r
37 42
38splitJID :: Text -> (Maybe Text,Text,Maybe Text) 43splitJID :: Text -> (Maybe Text,Text,Maybe Text)
39splitJID bjid = 44splitJID bjid =
@@ -68,6 +73,7 @@ data PresenceState = PresenceState
68 { clients :: TVar (Map ConnectionKey ClientState) 73 { clients :: TVar (Map ConnectionKey ClientState)
69 , associatedPeers :: TVar (Map SockAddr ()) 74 , associatedPeers :: TVar (Map SockAddr ())
70 , server :: TMVar XMPPServer 75 , server :: TMVar XMPPServer
76 , writeTos :: TVar (Map ConnectionKey (TChan Stanza))
71 } 77 }
72 78
73 79
@@ -83,7 +89,7 @@ resolvePeer addrtext = do
83 89
84 90
85getConsolePids :: PresenceState -> IO [(Text,ProcessID)] 91getConsolePids :: PresenceState -> IO [(Text,ProcessID)]
86getConsolePids state = do -- return [("tty7", 23)] -- todo 92getConsolePids state = do
87 us <- UTmp.users 93 us <- UTmp.users
88 return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us 94 return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us
89 95
@@ -168,15 +174,44 @@ rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited
168rosterGetOthers = rosterGetStuff ConfigFiles.getOthers 174rosterGetOthers = rosterGetStuff ConfigFiles.getOthers
169rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers 175rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
170 176
177newConn state k outchan =
178 atomically $ modifyTVar' (writeTos state) $ Map.insert k outchan
179
180eofConn state k = atomically $ modifyTVar' (writeTos state) $ Map.delete k
181
182rewriteJIDForPeer :: Text -> IO (Maybe (Text,SockAddr))
183rewriteJIDForPeer jid = do
184 let (n,h,r) = splitJID jid
185 maddr <- fmap listToMaybe $ resolvePeer h
186 return $ flip fmap maddr $ \addr ->
187 let h' = addrToText addr
188 to' = unsplitJID (n,h',r)
189 in (to',addr)
190
191deliverMessage state fail msg = do
192 mto <- do
193 flip (maybe $ return Nothing) (stanzaTo msg) $ \to -> do
194 rewriteJIDForPeer to
195 flip (maybe fail) mto $ \(to',addr) -> do
196 from' <- do
197 flip (maybe $ return Nothing) (stanzaFrom msg) $ \from -> do
198 m <- rewriteJIDForPeer from
199 return $ fmap fst m
200 let k = PeerKey addr
201 chans <- atomically $ readTVar (writeTos state)
202 flip (maybe fail) (Map.lookup k chans) $ \chan -> do
203 sendModifiedStanzaToPeer (msg { stanzaTo=Just to', stanzaFrom=from' }) chan
171 204
172main = runResourceT $ do 205main = runResourceT $ do
173 state <- liftIO . atomically $ do 206 state <- liftIO . atomically $ do
174 clients <- newTVar Map.empty 207 clients <- newTVar Map.empty
175 associatedPeers <- newTVar Map.empty 208 associatedPeers <- newTVar Map.empty
176 xmpp <- newEmptyTMVar 209 xmpp <- newEmptyTMVar
210 writeTos <- newTVar Map.empty
177 return PresenceState 211 return PresenceState
178 { clients = clients 212 { clients = clients
179 , associatedPeers = associatedPeers 213 , associatedPeers = associatedPeers
214 , writeTos = writeTos
180 , server = xmpp 215 , server = xmpp
181 } 216 }
182 sv <- xmppServer 217 sv <- xmppServer
@@ -187,20 +222,22 @@ main = runResourceT $ do
187 , xmppTellMyNameToPeer = \addr -> return $ addrToText addr 222 , xmppTellMyNameToPeer = \addr -> return $ addrToText addr
188 , xmppTellPeerHisName = return . peerKeyToText 223 , xmppTellPeerHisName = return . peerKeyToText
189 , xmppTellClientNameOfPeer = peerKeyToResolvedName 224 , xmppTellClientNameOfPeer = peerKeyToResolvedName
190 , xmppNewConnection = \k outchan -> return () 225 , xmppNewConnection = newConn state
191 , xmppEOF = \k -> return () 226 , xmppEOF = eofConn state
192 , xmppRosterBuddies = rosterGetBuddies state 227 , xmppRosterBuddies = rosterGetBuddies state
193 , xmppRosterSubscribers = rosterGetSubscribers state 228 , xmppRosterSubscribers = rosterGetSubscribers state
194 , xmppRosterSolicited = rosterGetSolicited state 229 , xmppRosterSolicited = rosterGetSolicited state
195 , xmppRosterOthers = rosterGetOthers state 230 , xmppRosterOthers = rosterGetOthers state
196 , xmppSubscribeToRoster = \k -> return () 231 , xmppSubscribeToRoster = \k -> return ()
197 -- , xmppLookupClientJID = \k -> return $ "nobody@" <> hostname <> "/tty666" 232 -- , xmppLookupClientJID = \k -> return $ "nobody@" <> hostname <> "/tty666"
198 , xmppDeliverMessage = \fail msg -> do 233 , {- xmppDeliverMessage = \fail msg -> do
199 let msgs = msgLangMap (stanzaType msg) 234 let msgs = msgLangMap (stanzaType msg)
200 body = fmap (maybe "" id . msgBody . snd) $ take 1 msgs 235 body = fmap (maybe "" id . msgBody . snd) $ take 1 msgs
201 when (not $ null body) $ do 236 when (not $ null body) $ do
202 Text.putStrLn $ "MESSAGE " <> head body 237 Text.putStrLn $ "MESSAGE " <> head body
203 return () 238 return ()
239 -}
240 xmppDeliverMessage = deliverMessage state
204 , xmppInformClientPresence = \k stanza -> return () 241 , xmppInformClientPresence = \k stanza -> return ()
205 } 242 }
206 liftIO $ do 243 liftIO $ do