summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Presence/AdaptServer.hs40
-rw-r--r--Presence/Server.hs97
-rw-r--r--Presence/XMPPServer.hs649
-rw-r--r--Presence/main.hs4
4 files changed, 0 insertions, 790 deletions
diff --git a/Presence/AdaptServer.hs b/Presence/AdaptServer.hs
deleted file mode 100644
index e4940331..00000000
--- a/Presence/AdaptServer.hs
+++ /dev/null
@@ -1,40 +0,0 @@
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE OverloadedStrings #-}
3module AdaptServer where
4
5import Data.IORef
6import Data.HList
7-- import Network.Socket (Socket)
8import qualified Data.ByteString.Lazy.Char8 as L
9import ByteStringOperators
10
11adaptStartCon start sock st = do
12 rsRef <- newIORef ""
13 st' <- start sock st
14 return (HCons rsRef st')
15
16adaptDoCon showlex (dropTill,lex,parse) g st bs cont = do
17 putStrLn $ "packet: " ++ show bs
18 let (HCons rsRef st') = st
19 rs <- readIORef rsRef
20
21 let contR rem v = do
22 writeIORef rsRef rem
23 cont v
24 let loop rem lexemes@(_:_) = do
25 let (e,rs') = parse lexemes
26 case e of
27 Left err -> if null rs'
28 then contR "" ()
29 else -- trace ("parse error "++show (err,bs,showlex lexemes,showlex rs')) $ do
30 contR rem ()
31 Right e -> do
32 -- writeIORef rsRef rs'
33 g st' e (\() -> do { {- putStrLn ("LOOP "++showlex rs'); -} loop (dropTill rem rs') rs' })
34 loop rem [] = contR "" ()
35 let buf = rs <++> bs
36 when (L.length buf < 8192)
37 (loop buf (lex buf))
38
39
40adaptServer showlex (dropTill,lex,parse) (startCon,doCon) = (adaptStartCon startCon, adaptDoCon showlex (dropTill,lex,parse) doCon)
diff --git a/Presence/Server.hs b/Presence/Server.hs
deleted file mode 100644
index 80a6e4ba..00000000
--- a/Presence/Server.hs
+++ /dev/null
@@ -1,97 +0,0 @@
1{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE TypeOperators #-}
3{-# LANGUAGE OverloadedStrings #-}
4module Server where
5
6import Network.Socket
7import Data.ByteString.Lazy.Char8 as L
8 ( fromChunks
9 , putStrLn )
10import Data.ByteString.Char8
11 ( hGetNonBlocking
12 )
13import System.IO
14 ( IOMode(..)
15 , hSetBuffering
16 , BufferMode(..)
17 , hWaitForInput
18 , hClose
19 , hIsEOF
20 )
21import Control.Monad
22import Control.Concurrent (forkIO)
23import Control.Exception (handle,SomeException(..))
24import Data.HList
25import Data.HList.TypeEqGeneric1()
26import Data.HList.TypeCastGeneric1()
27import System.IO.Error
28import ByteStringOperators
29
30
31newtype ConnId = ConnId Int
32 deriving Eq
33
34newtype ConnectionFinalizer = ConnectionFinalizer (IO ())
35
36getPacket h = do { hWaitForInput h (-1) ; fmap (fromChunks . (:[])) $ hGetNonBlocking h 1024 }
37
38newtype ServerHandle = ServerHandle Socket
39
40quitListening :: ServerHandle -> IO ()
41quitListening (ServerHandle socket) = sClose socket
42
43doServer addrfamily port g startCon = do
44 doServer' addrfamily port g startCon
45
46doServer' family port g startCon = runServer2 port (runConn2 g)
47 where
48 runConn2 g st (sock,_) = do
49 h <- socketToHandle sock ReadWriteMode
50 hSetBuffering h NoBuffering
51 st'' <- startCon sock (h .*. st)
52 let doException (SomeException e) = Prelude.putStrLn ("\n\nexception: " ++ show e ++ "\n\n")
53 handle doException $ fix $ \loop -> do
54 let continue () = hIsEOF h >>= flip when loop . not
55 packet <- getPacket h
56 g st'' packet continue
57 let ConnectionFinalizer cleanup = hOccursFst st''
58 cleanup
59 hClose h
60
61 {-
62 runServer2 ::
63 Num num =>
64 PortNumber -> (num -> (Socket, SockAddr) -> IO b -> IO b) -> IO b
65 -}
66 runServer2 st@(HCons port _) go = do
67 sock <- socket family Stream 0
68 setSocketOption sock ReuseAddr 1
69 case family of
70 AF_INET -> bindSocket sock (SockAddrInet port iNADDR_ANY)
71 AF_INET6 -> bindSocket sock (SockAddrInet6 port 0 iN6ADDR_ANY 0)
72 listen sock 2
73 forkIO $ do
74 mainLoop sock (ConnId 0) go
75 -- L.putStrLn $ "quit accept loop"
76 return (ServerHandle sock)
77 where
78 mainLoop sock idnum@(ConnId n) go = do
79 let doException ioerror = do
80 let typ = ioeGetErrorType ioerror
81 if -- typ == InvalidArgument
82 -- but the symbol is not exported :/
83 bshow typ=="invalid argument"
84 then do
85 L.putStrLn $ "quit accept-loop."
86 else do
87 L.putStrLn ("accept-loop exception: " <++> bshow ioerror <++> "\n")
88 return Nothing
89 mcon <- handle doException $ fix $ \loop -> do
90 con <- accept sock
91 return $ Just con
92 case mcon of
93 Just con -> do
94 forkIO $ go (idnum .*. st) con
95 mainLoop sock (ConnId (n+1)) go
96 Nothing -> return ()
97
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
deleted file mode 100644
index ff50ab1c..00000000
--- a/Presence/XMPPServer.hs
+++ /dev/null
@@ -1,649 +0,0 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE TupleSections #-}
5{-# LANGUAGE TypeFamilies #-}
6-- {-# LANGUAGE GADTs #-}
7module XMPPServer
8 ( module XMPPServer
9 , module XMPPTypes
10 , quitListening
11 ) where
12
13import Data.Char (isSpace)
14import Data.HList.TypeEqGeneric1()
15import Data.HList.TypeCastGeneric1()
16import ByteStringOperators
17import System.IO
18 ( IOMode(..)
19 , BufferMode(..)
20 , hSetBuffering
21 )
22
23import Server
24import Data.ByteString.Lazy.Char8 as L
25 ( hPutStrLn
26 , unlines
27 , lines
28 , uncons
29 , takeWhile
30 , concat
31 , splitWith
32 , drop
33 , ByteString
34 , pack
35 , unpack )
36import qualified Data.ByteString.Lazy.Char8 as L
37 ( putStrLn )
38import System.IO
39 ( Handle
40 )
41import Data.HList
42import AdaptServer
43import Text.XML.HaXml.Lex (xmlLex,TokenT(..))
44import Text.XML.HaXml.Parse (XParser,xmlParseWith,element,{-doctypedecl,-}processinginstruction,elemOpenTag,elemCloseTag)
45import Text.XML.HaXml.Types as Hax hiding (Element) -- (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
46import qualified Text.XML.HaXml.Types as Hax (Element(..))
47import Text.XML.HaXml.Posn (Posn, posnLine, posnColumn)
48import qualified Text.XML.HaXml.Pretty as PP
49import Text.PrettyPrint
50import Data.Maybe
51import Debug.Trace
52import Control.Arrow
53import Network.Socket
54import Data.String
55import Control.Monad.Trans.Maybe
56import Control.Monad.IO.Class
57import Control.DeepSeq
58import Control.Concurrent.STM
59import Control.Concurrent
60import Control.Exception as Exception
61import Text.Show.ByteString as L
62import qualified Data.Map as Map
63import GHC.Conc
64import Network.BSD hiding (getHostByAddr)
65import Control.Concurrent.Async
66import qualified Data.Set as Set
67import GetHostByAddr
68import XMPPTypes
69
70getNamesForPeer :: Peer -> IO [ByteString]
71getNamesForPeer LocalHost = fmap ((:[]) . pack) getHostName
72getNamesForPeer peer@(RemotePeer addr) = do
73 {-
74 let hints = Just $ defaultHints { addrFlags = [ AI_CANONNAME ] }
75 L.putStrLn $ "getAddrInfo 1 " <++> showPeer peer
76 infos <- getAddrInfo hints (Just . unpack . showPeer $ peer) Nothing
77 return . map pack . mapMaybe addrCanonName $ infos
78 -}
79 -- ent <- getHostByName (unpack . showPeer $ peer)
80 ent <- getHostByAddr addr -- AF_UNSPEC addr
81 let names = hostName ent : hostAliases ent
82 return . map pack $ names
83
84
85
86xmlifyPresenceForPeer sock (Presence jid stat) = do
87 -- TODO: accept socket argument and determine local ip address
88 -- connected to this peer.
89 addr <- getSocketName sock
90 let n = name jid
91 rsc = resource jid
92 jid_str = n <$++> "@" <?++> showPeer (RemotePeer addr) <++?> "/" <++$> rsc
93 return . L.unlines $
94 [ "<presence from='" <++> jid_str <++> "' " <++> typ stat <++> ">"
95 , "<show>" <++> shw stat <++> "</show>"
96 , "</presence>"
97 ]
98 where
99 typ Offline = " type='unavailable'"
100 typ _ = ""
101 shw Available = "chat"
102 shw Away = "away"
103 shw Offline = "away" -- Is this right?
104
105xmlifyPresenceForClient (Presence jid stat) = do
106 let n = name jid
107 rsc = resource jid
108 names <- getNamesForPeer (peer jid)
109 let tostr p = n <$++> "@" <?++> p <++?> "/" <++$> rsc
110 jidstrs = fmap tostr names
111 return (L.concat $ map doit jidstrs)
112 where
113 doit jidstr = L.unlines
114 [ "<presence from='" <++> jidstr <++> "' " <++> typ stat <++> ">"
115 , "<show>" <++> shw stat <++> "</show>"
116 , "</presence>"
117 ]
118 typ Offline = " type='unavailable'"
119 typ _ = ""
120 shw Available = "chat"
121 shw Away = "away"
122 shw Offline = "away" -- Is this right?
123
124instance NFData Presence where
125 rnf (Presence jid stat) = rnf jid `seq` stat `seq` ()
126
127
128greet host = L.unlines
129 [ "<?xml version='1.0'?>"
130 , "<stream:stream"
131 , "from='" <++> host <++> "'"
132 , "id='someid'"
133 , "xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' version='1.0'>"
134 , "<stream:features>"
135 , " <bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>"
136 {-
137 -- , " <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
138 , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
139 -- , " <mechanism>DIGEST-MD5</mechanism>"
140 , " <mechanism>PLAIN</mechanism>"
141 , " </mechanisms> "
142 -}
143 , "</stream:features>"
144 ]
145
146-- data TaggedXMPPSession s = TaggedXMPPSession s
147
148data Commands = Send ByteString
149 deriving Prelude.Show
150
151startCon session_factory sock st = do
152 let h = hOccursFst st :: Handle
153 -- cred <- getLocalPeerCred sock
154 -- Prelude.putStrLn $ "PEER CRED: "++Prelude.show cred
155 pname <- getPeerName sock
156 session <- newSession session_factory sock
157 Prelude.putStrLn $ "PEER NAME: "++Prelude.show pname
158 pchan <- subscribe session Nothing
159 cmdChan <- atomically newTChan
160 reader <- forkIO $
161 handle (\(SomeException e) -> L.putStrLn $ "quit reader via exception: "<++>bshow e) $
162 fix $ \loop -> do
163 event <- atomically $
164 (fmap Left $ readTChan pchan)
165 `orElse`
166 (fmap Right $ readTChan cmdChan)
167 case event of
168 Left presence -> do
169 L.putStrLn $ "PRESENCE: " <++> bshow presence
170 -- TODO: it violates spec to send presence information before
171 -- a resource is bound.
172 r <- xmlifyPresenceForClient presence
173 hPutStrLn h r
174 L.putStrLn $ "\nOUT client:\n" <++> r
175 Right (Send r) ->
176 hPutStrLn h r
177 loop
178 let quit = do
179 killThread reader
180 closeSession session
181 return ( (session,cmdChan) .*. ConnectionFinalizer quit .*. st)
182
183iq_query_unavailable host id mjid xmlns kind = L.unlines $
184 [ "<iq type='error'"
185 , " from='" <++> host <++> "'" <++?> " to='" <++$> mjid <$++> "'"
186 , " id='" <++> id <++> "'>"
187 , " <" <++> kind <++> " xmlns='" <++> xmlns <++> "'/>"
188 , " <error type='cancel'>"
189 , " <service-unavailable"
190 , " xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>"
191 , " </error>"
192 , "</iq>"
193 ]
194
195tagattrs tag content = Prelude.concatMap (\(CElem (Elem _ a _) _)->a)
196 $ Prelude.filter (bindElem tag) content
197anytagattrs content = Prelude.concatMap (\(CElem (Elem n a _) _)->map (second (n,)) a) content
198
199bindElem tag (CElem (Elem (N n) _ _) _) | n==tag = True
200bindElem _ _ = False
201
202hasElem tag content =
203 not . Prelude.null . Prelude.filter (bindElem tag) $ content
204
205unattr (AttValue as) = listToMaybe $ Prelude.concatMap left as
206 where left (Left x) = [x]
207 left _ = []
208
209astring (AttValue [Left s]) = [s]
210
211tagcontent tag content = Prelude.concatMap (\(CElem (Elem _ _ c) _)->c)
212 $ Prelude.filter (bindElem tag) content
213
214iq_bind_reply id jid = L.unlines $
215 [ "<iq type='result' id='" <++> id <++> "'>"
216 , "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'>"
217 , "<jid>" <++> jid <++> "</jid>"
218 , "</bind>"
219 , "</iq> "
220 ]
221iq_session_reply host id = L.unlines $
222 [ "<iq type='result'"
223 , " id='" <++> id <++> "'"
224 , " from='" <++> host <++> "'"
225 , " /> "
226 ]
227
228{-
229iqresult_info host id mjid = L.unlines $
230 [ "<iq type='result'"
231 , " from='" <++> host <++> "'" <++?> " to='" <++$> mjid <$++> "'"
232 , " id='" <++> id <++> "'>"
233 , " <query xmlns='http://jabber.org/protocol/disco#info'>"
234 , " <identity"
235 , " category='server'"
236 , " type='im'"
237 , " name='" <++> host <++> "'/>"
238 , " <feature var='http://jabber.org/protocol/disco#info'/>"
239 , " <feature var='http://jabber.org/protocol/disco#items'/>"
240 , " </query>"
241 , "</iq>"
242 ]
243-}
244
245iqresponse session host (Elem _ attrs content) = runMaybeT $ do
246 id <- MaybeT . return $ fmap pack (lookup (N "id") attrs >>= unattr)
247 typ <- MaybeT . return $ fmap pack (lookup (N "type") attrs >>= unattr)
248 case typ of
249 "set" -> do
250 let string (CString _ s _) = [s]
251 mplus (do
252 rsrc <- MaybeT . return . fmap pack $ listToMaybe . Prelude.concatMap string . tagcontent "resource" . tagcontent "bind" $ content
253 -- let jid = "TODO" <++> "@" <++> host <++> "/" <++> pack rsrc
254 liftIO $ do
255 setResource session rsrc
256 jid <- getJID session
257 return $ iq_bind_reply id (L.show jid) )
258 (do
259 guard (hasElem "session" content)
260 return (iq_session_reply host id))
261
262 "get" -> {- trace ("iq-get "++show (attrs,content)) $ -} do
263 (tag,as) <- MaybeT . return $ lookup (N "xmlns") (anytagattrs content)
264 xmlns <- MaybeT . return $ fmap pack $ listToMaybe . astring $ as
265 let servicekind = case tag of { (N s) -> pack s ; _ -> "query" }
266 case xmlns of
267 "urn:xmpp:ping" ->
268 return $
269 "<iq from='" <++> host
270 <++> ("' " <++?> "to='" <++$> fmap pack (lookup (N "from") attrs >>= unattr) <$++> "' ")
271 <++> "id='" <++> id <++> "' type='result'/>"
272
273 _ -> return (iq_query_unavailable host id Nothing xmlns servicekind)
274 _ -> MaybeT (return Nothing)
275
276
277presence_response host (Elem _ attrs content) = do
278 -- let id = fmap pack (lookup (N "id") attrs >>= unattr)
279 typ <- fmap pack (lookup (N "type") attrs >>= unattr)
280 case typ of
281 "subscribe" -> do
282 -- <presence to='guest@localhost' type='subscribe'/>
283 to <- fmap pack (lookup (N "to") attrs >>= unattr)
284 Just $ "<presence to='" <++> to <++> "' type='subscribed'/>"
285 _ -> Nothing
286
287doCon st elem cont = do
288 let h = hOccursFst st :: Handle
289 (session,cmdChan) = hHead st
290 hsend r = do
291 atomically $ writeTChan cmdChan (Send r)
292 -- hPutStrLn h r
293 L.putStrLn $ "\nOUT client:\n" <++> r
294 -- host <- fmap pack $ getHostName -- Assume localhost for client session JID
295 host <- do
296 jid <- getJID session
297 names <- getNamesForPeer (peer jid)
298 return (head names)
299
300 putStrLn $ (Prelude.show $ hang (text "\nIN client:") 2 $ pp elem) ++ "\n"
301
302 case elem of
303 OpenTag _ ->
304 hsend (greet host)
305 Element e@(Elem (N "iq") _ _) -> do
306 rpns <- iqresponse session host e
307 case rpns of
308 Nothing -> trace "IGNORE: no response to <iq>" $ return ()
309 Just r -> hsend r
310 Element e@(Elem (N "presence") _ _) ->
311 case presence_response host e of
312 Nothing -> trace "IGNORE: no response to <presence>" $ return ()
313 Just r -> hsend r
314
315 _ -> return () -- putStrLn $ "unhandled: "++show v
316
317 cont ()
318
319instance Prelude.Show Hax.ElemTag where
320 show _ = "elemtag"
321
322data XmppObject
323 = Element (Hax.Element Posn)
324 | ProcessingInstruction Hax.ProcessingInstruction
325 | OpenTag ElemTag
326 | CloseTag ()
327 deriving Prelude.Show
328
329pp (Element e) = PP.element e
330pp o = fromString (Prelude.show o)
331
332streamName = QN (Namespace {nsPrefix= "stream" , nsURI="http://etherx.jabber.org/streams" }) "stream"
333
334newtype TryParse p x e = Try (Either e p,[x])
335
336instance Monad (TryParse p x) where
337 return v = Try (Left v,[])
338 Try (Left m,xs) >>= k = k m
339 Try (Right e,xs) >>= _ = Try (Right e,xs)
340
341runTryParse (Try p) = p
342mapRight f (Right x,ls) = (Right (f x),ls)
343mapRight f (Left y,ls) = (Left y ,ls)
344
345dropLeadingSpace toks = dropWhile space toks
346 where
347 space (_,TokFreeText cs) = all isSpace cs
348 space _ = False
349
350xmppParse :: [(Posn, TokenT)] -> (Either String XmppObject, [(Posn, TokenT)])
351xmppParse ls = runTryParse $ do
352 let xml :: (t -> b) -> XParser t -> (Either String b, [(Posn, TokenT)])
353 xml tag = mapRight tag . flip xmlParseWith (dropLeadingSpace ls)
354 Try . xml Element $ element
355 Try . xml OpenTag $ elemOpenTag
356 Try . xml CloseTag $ elemCloseTag streamName
357 Try . xml ProcessingInstruction $ processinginstruction
358
359
360showTokenT TokCommentOpen = "<!--"
361showTokenT TokCommentClose = "-->"
362showTokenT TokPIOpen = "<?"
363showTokenT TokPIClose = "?>"
364showTokenT TokSectionOpen = "<!["
365showTokenT TokSectionClose = "]]>"
366showTokenT TokSpecialOpen = "<!"
367showTokenT TokEndOpen = "</"
368showTokenT TokEndClose = "/>"
369showTokenT TokAnyOpen = "<"
370showTokenT TokAnyClose = ">"
371showTokenT TokSqOpen = "["
372showTokenT TokSqClose = "]"
373showTokenT TokEqual = "="
374showTokenT TokQuery = "?"
375showTokenT TokStar = "*"
376showTokenT TokPlus = "+"
377showTokenT TokAmp = "&"
378showTokenT TokSemi = ";"
379showTokenT TokHash = "#"
380showTokenT TokBraOpen = "("
381showTokenT TokBraClose = ")"
382showTokenT TokPipe = "|"
383showTokenT TokPercent = "%"
384showTokenT TokComma = ","
385showTokenT TokQuote = "' or \""
386showTokenT TokNull = "(null)"
387showTokenT (TokError s) = "TokError "++ Prelude.show s
388showTokenT (TokSection s) = "TokSection "++Prelude.show s
389showTokenT (TokSpecial s) = "TokSpecial "++Prelude.show s
390showTokenT (TokName s) = "TokName "++Prelude.show s
391showTokenT (TokFreeText s) = "TokFreeText "++s
392
393showtoks ts = Prelude.show $ map (showTokenT . snd) ts
394
395
396listenForXmppClients addr_family session_factory port st = do
397 -- standard port: 5222
398 let (start,dopkt) =
399 adaptServer showtoks ( dropTill
400 , xmlLexPartial "local-client" . unpack
401 , xmppParse)
402 (startCon session_factory,doCon)
403 doServer addr_family
404 (port .*. st)
405 dopkt
406 start
407
408
409startPeer session_factory sock st = do
410 let h = hOccursFst st :: Handle
411 name <- fmap bshow $ getPeerName sock
412 L.putStrLn $ "IN peer: connected " <++> name
413 jids <- newTVarIO Set.empty
414 session <- newSession session_factory sock
415 let quit = do
416 L.putStrLn $ "IN peer: disconnected " <++> name
417 js <- fmap Set.toList (readTVarIO jids)
418 let offline jid = Presence jid Offline
419 forM_ js $ announcePresence session . offline
420 closeSession session
421 return ( (session,jids) .*. ConnectionFinalizer quit .*. st )
422
423doPeer st elem cont = do
424 let (session,jids) = hHead st
425 L.putStrLn $ "IN peer: " <++> bshow elem
426 case elem of
427 Element e@(Elem (N "presence") attrs content) -> do
428 let jid = fmap pack (lookup (N "from") attrs >>= unattr)
429 typ = fmap pack (lookup (N "type") attrs >>= unattr)
430 case (jid,typ) of
431 (Just jid,Just "unavailable") -> do
432 L.putStrLn $ "IN peer: PRESENCE! Offline jid=" <++> jid
433 -- parseAddressJID -- convert peer reported user@address to JID data structure
434 peer_jid <- parseAddressJID jid
435 atomically $ do
436 jids_ <- readTVar jids
437 writeTVar jids (Set.delete peer_jid jids_)
438 announcePresence session (Presence peer_jid Offline)
439 (Just jid,Just typ) ->
440 -- possible probe, ignored for now
441 L.putStrLn $ "IN peer: Ignored presence! "<++>typ<++>" jid="<++>jid
442 (Just jid,Nothing) -> do
443 let string (CString _ s _) = [s]
444 stat = listToMaybe . Prelude.concatMap string . tagcontent "show" $ content
445 stat' = case stat of
446 Nothing -> Available
447 Just "away" -> Away
448 Just "xa" -> Away -- TODO: xa
449 Just "dnd" -> Away -- TODO: dnd
450 Just "chat" -> Available
451 _ -> Available
452 -- Available or Away.
453 pjid <- parseAddressJID jid
454 -- names <- getNamesForPeer (peer pjid)
455 -- L.putStrLn $ "IN peer: PRESENCE! "<++>bshow (stat,names)<++>" avail/away jid=" <++> jid
456 atomically $ do
457 jids_ <- readTVar jids
458 writeTVar jids (Set.insert pjid jids_)
459 announcePresence session (Presence pjid stat')
460 L.putStrLn $ "IN peer: " <++> bshow (Presence pjid stat')
461 _ -> return () -- putStrLn $ "inbound unhandled: "++show v
462 cont ()
463
464xmlLexPartial name cs =
465 let ls = xmlLex name cs
466 isTokError (_,TokError _) = True
467 isTokError _ = False
468 (gs,bs) = break isTokError ls
469 in if any (not . isTokError) bs
470 then ls
471 else gs
472
473
474listenForRemotePeers addrfamily session_factory port st = do
475 -- standard port: 5269
476 let (start,dopkt) =
477 adaptServer showtoks ( dropTill
478 , xmlLexPartial "remote-inbound" . unpack
479 , xmppParse)
480 (startPeer session_factory,doPeer)
481 doServer addrfamily
482 (port .*. st)
483 dopkt
484 start
485
486dropTill bs ((fst->posn):_) =
487 let ls = zip [1..] (L.lines bs)
488 ln = posnLine posn
489 col = posnColumn posn
490 ls' = map snd $ dropWhile ((<ln).fst) ls
491 in case ls' of
492 [] -> ""
493 fstLine:ls'' -> foldr1 (<++>) (L.drop (fromIntegral (col-1)) fstLine : ls'')
494
495
496data OutBoundMessage = OutBoundPresence Presence
497 deriving Prelude.Show
498
499newServerConnections = atomically $ newTVar Map.empty
500
501sendMessage cons msg peer = do
502 found <- atomically $ do
503 consmap <- readTVar cons
504 return (Map.lookup peer consmap)
505 let newEntry = do
506 chan <- atomically newTChan
507 t <- forkIO $ connect_to_server chan peer
508 -- L.putStrLn $ "remote-map new: " <++> showPeer peer
509 return (True,(chan,t))
510 (is_new,entry) <- maybe newEntry
511 ( \(chan,t) -> do
512 st <- threadStatus t
513 let running = do
514 -- L.putStrLn $ "remote-map, thread running: " <++> showPeer peer
515 return (False,(chan,t))
516 died = do
517 -- L.putStrLn $ "remote-map, thread died("<++>bshow st<++>"): " <++> showPeer peer
518 newEntry
519 case st of
520 ThreadRunning -> running
521 ThreadBlocked _ -> running
522 ThreadDied -> died
523 ThreadFinished -> died
524 )
525 found
526 -- L.putStrLn $ "sendMessage ->"<++>showPeer peer<++>": "<++>bshow msg
527 atomically $ writeTChan (fst entry) msg
528 when is_new . atomically $
529 readTVar cons >>= writeTVar cons . Map.insert peer entry
530
531connect_to_server chan peer = (>> return ()) . runMaybeT $ do
532 let port = 5269 :: Int
533
534 connected <- liftIO . async $ connect' (peerAddr peer) port
535
536 -- We'll cache Presence notifications until the socket
537 -- is ready.
538 cached <- liftIO $ newIORef Map.empty
539
540 sock <- MaybeT . fix $ \loop -> do
541 e <- atomically $ orElse
542 (fmap Right $ waitSTM connected)
543 (fmap Left $ readTChan chan)
544 case e of
545 Left (OutBoundPresence (Presence jid Offline)) -> do
546 cached_map <- readIORef cached
547 writeIORef cached (Map.delete jid cached_map)
548 loop
549 Left (OutBoundPresence p@(Presence jid st)) -> do
550 cached_map <- readIORef cached
551 writeIORef cached (Map.insert jid st cached_map)
552 loop
553 {-
554 Left event -> do
555 L.putStrLn $ "REMOTE-OUT DISCARDED: " <++> bshow event
556 loop
557 -}
558 Right sock -> return sock
559
560 liftIO $ do
561 h <- socketToHandle sock ReadWriteMode
562 hSetBuffering h NoBuffering
563 hPutStrLn h "<stream>"
564 L.putStrLn $ "OUT peer: <stream>"
565 cache <- fmap Map.assocs . readIORef $ cached
566 writeIORef cached Map.empty -- hint garbage collector: we're done with this
567 forM_ cache $ \(jid,st) -> do
568 r <- xmlifyPresenceForPeer sock (Presence jid st)
569 hPutStrLn h r
570 L.putStrLn $ "OUT peer: (cache)\n" <++> r <++> "\n"
571 fix $ \loop -> do
572 event <- atomically $ readTChan chan
573 case event of
574 OutBoundPresence p -> do
575 r <- xmlifyPresenceForPeer sock p
576 hPutStrLn h r
577 L.putStrLn $ "OUT peer:\n" <++> r <++> "\n"
578 loop
579 hPutStrLn h "</stream>"
580 L.putStrLn $ "OUT peer: </stream>"
581
582
583connect' :: SockAddr -> Int -> IO (Maybe Socket)
584connect' addr port = do
585 proto <- getProtocolNumber "tcp"
586 {-
587 -- Given (host :: HostName) ...
588 let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]
589 , addrProtocol = proto
590 , addrSocketType = Stream }
591 addrs <- getAddrInfo (Just hints) (Just host) (Just serv)
592 firstSuccessful $ map tryToConnect addrs
593 -}
594 let getport (SockAddrInet port _) = port
595 getport (SockAddrInet6 port _ _ _) = port
596 let withPort (SockAddrInet _ a) port = SockAddrInet (toEnum port) a
597 withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c
598 let doException (SomeException e) = do
599 L.putStrLn $ "\nFailed to reach "<++> showPeer (RemotePeer addr) <++> " on port "<++>bshow port<++>": " <++> bshow e
600 return Nothing
601 handle doException
602 $ tryToConnect proto (addr `withPort` port)
603 where
604 tryToConnect proto addr =
605 bracketOnError
606 (socket (socketFamily addr) Stream proto)
607 (sClose ) -- only done if there's an error
608 (\sock -> do
609 connect sock addr
610 return (Just sock) -- socketToHandle sock ReadWriteMode
611 )
612
613catchIO :: IO a -> (IOException -> IO a) -> IO a
614catchIO a h = Exception.catch a h
615
616-- Returns the first action from a list which does not throw an exception.
617-- If all the actions throw exceptions (and the list of actions is not empty),
618-- the last exception is thrown.
619firstSuccessful :: [IO a] -> IO a
620firstSuccessful [] = error "firstSuccessful: empty list"
621firstSuccessful (p:ps) = catchIO p $ \e ->
622 case ps of
623 [] -> Exception.throwIO e
624 _ -> firstSuccessful ps
625
626
627seekRemotePeers :: XMPPConfig config =>
628 config -> TChan Presence -> IO b0
629seekRemotePeers config chan = do
630 server_connections <- newServerConnections
631 fix $ \loop -> do
632 event <- atomically $ readTChan chan
633 case event of
634 p@(Presence jid stat) | not (is_remote (peer jid)) -> do
635 -- L.putStrLn $ "seekRemotePeers: " <++> L.show jid <++> " " <++> bshow stat
636 runMaybeT $ do
637 u <- MaybeT . return $ name jid
638 subscribers <- liftIO $ do
639 subs <- getSubscribers config u
640 mapM parseHostNameJID subs
641 -- liftIO . L.putStrLn $ "subscribers: " <++> bshow subscribers
642 let peers = Set.map peer (Set.fromList subscribers)
643 forM_ (Set.toList peers) $ \peer -> do
644 when (is_remote peer) $
645 liftIO $ sendMessage server_connections (OutBoundPresence p) peer
646 -- TODO: send presence probes for buddies
647 -- TODO: cache remote presences for clients
648 _ -> return (Just ())
649 loop
diff --git a/Presence/main.hs b/Presence/main.hs
index deab92ac..8c2371f4 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -30,11 +30,7 @@ import UTmp
30-- the manner in which the error message attempted (and failed) to communicate. 30-- the manner in which the error message attempted (and failed) to communicate.
31#endif 31#endif
32import FGConsole 32import FGConsole
33#ifdef HAXML
34import XMPPServer
35#else
36import XMPP 33import XMPP
37#endif
38import ControlMaybe 34import ControlMaybe
39import Data.HList 35import Data.HList
40import Control.Exception hiding (catch) 36import Control.Exception hiding (catch)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 21:08:05 +0000