summaryrefslogtreecommitdiff
path: root/Presence/main.hs
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2017-11-04 17:04:16 -0400
committerjoe <joe@jerkface.net>2017-11-04 17:04:16 -0400
commit366d793c9f9acc9b228675f1af23c01ef02dd3b1 (patch)
tree0970725923144707cb5dfb479c9d1289ec0be4c7 /Presence/main.hs
parent67afff3c6e2ce009e7fff83669e8c381e27166f2 (diff)
Deleted obsolete files.
Diffstat (limited to 'Presence/main.hs')
-rw-r--r--Presence/main.hs888
1 files changed, 0 insertions, 888 deletions
diff --git a/Presence/main.hs b/Presence/main.hs
deleted file mode 100644
index db1a7445..00000000
--- a/Presence/main.hs
+++ /dev/null
@@ -1,888 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE ExistentialQuantification #-}
5{-# LANGUAGE TupleSections #-}
6{-# LANGUAGE ViewPatterns #-}
7module Main where
8
9import System.Directory
10import Control.Monad
11import System.Posix.Signals
12import System.Posix.Types
13import System.Posix.Process
14import Data.Maybe
15import Data.Char
16import ConfigFiles
17import Control.Arrow (second)
18import Data.Traversable (sequenceA)
19import Data.List (partition)
20
21import System.INotify
22#ifndef NOUTMP
23import UTmp
24-- UTmp is inconvenient for the profiling build due to Template Haskell
25-- causing ghc to report "Dynamic linking required,..."
26--
27-- To make a full-featured profiling build, the bp script will make a
28-- non-profiling binary for BitSyntax available to an otherwise-profiling
29-- build.
30#endif
31import FGConsole
32import XMPP
33import ControlMaybe
34import Data.HList
35import Control.Exception hiding (catch)
36import LocalPeerCred
37import System.Posix.User
38import Logging
39import qualified Data.Set as Set
40import Data.Set as Set ((\\))
41import qualified Data.Map as Map
42import Data.Map as Map (Map)
43
44import Control.Concurrent.STM
45import Control.Concurrent
46import Control.Monad.Trans.Maybe
47import Control.Monad.IO.Class
48
49import ByteStringOperators
50import qualified Data.ByteString.Lazy.Char8 as L
51import Data.ByteString.Lazy.Char8 as L (ByteString)
52import qualified Prelude
53import Prelude hiding (putStrLn)
54import System.Environment
55-- import qualified Text.Show.ByteString as L
56import Network.Socket (Family(AF_INET,AF_INET6))
57import Holumbus.Data.MultiMap as MM (MultiMap)
58import qualified Holumbus.Data.MultiMap as MM
59
60data Client = Client {
61 clientShow :: JabberShow,
62 clientChan :: TChan ClientCommands
63 }
64
65-- see Data.Map.Lazy.fromSet
66fromSet f = Map.fromList . map (\a -> (a,f a)) . Set.toList
67
68-- see Data.Map.Lazy.keysSet
69keys = map fst . Map.toList
70
71
72
73{- PresenceState
74 -
75 - This is the global state for the xmpp daemon.
76 - It is not directly accessed outside of this module.
77 -}
78data PresenceState = PresenceState
79 { hostname :: Peer -- ByteString, TODO: remove this, its always LocalHost now
80
81 -- currentTTY - a string such as "tty7" which is kept up to date as console
82 -- switches occur.
83 , currentTTY :: TVar ByteString
84
85 -- activeUsers - a is a set of triples representing data in /var/run/utmp
86 -- it is kept up to date by an inotify watch on that file.
87 , activeUsers :: TVar (Map (UserName, Tty) (ProcessID, Map ProcessID Client))
88
89 -- subscriberMap - the idea was to allow subscribing to a particular user only.
90 -- When that user becomes present, an announcement would be sent
91 -- on the channel associated with him. This functionality is currently
92 -- unused and may be removed soon if it's decided its unneccessary.
93 , subscriberMap :: TVar (Map JID (RefCount,TChan Presence)) -- UNUSED as yet
94
95 -- localSubscriber - a channel and reference count where all presence events are
96 -- announced.
97 , localSubscriber :: TMVar (RefCount,TChan Presence) -- TODO: rename this, its not just locals
98 -- ... or make a seperate channel for remotes
99
100 -- rosterChannel - a channel and reference count where all roster change events are
101 -- announced
102 , rosterChannel :: TMVar (RefCount,TChan RosterEvent)
103
104
105 -- remoteUsers - a cache of remote users considered to be online. These are sent to a client
106 -- on connect so that it can populate it's notion of online users.
107 , remoteUsers :: TVar (Map Peer (RefCount,TVar (MultiMap JabberUser (JabberResource,JabberShow))))
108
109 -- remotePeers - a set of channels that may be used to send messages to remote peers.
110 , remotePeers :: OutgoingConnections CachedMessages
111 }
112
113
114
115
116{- newPresenceState
117 -
118 - This is a smart constructor for the global state.
119 - This is currently used only from Main.start and PresenceState
120 - records are not created by any means other than this constructor.
121 -}
122newPresenceState hostname = atomically $ do
123 tty <- newTVar ""
124 us <- newTVar (Map.empty)
125 subs <- newTVar (Map.empty)
126 locals_greedy <- newEmptyTMVar
127 rchan <- newEmptyTMVar
128 remotes <- newTVar (Map.empty)
129 server_connections <- newOutgoingConnections toPeer
130 return $ PresenceState hostname tty us subs locals_greedy rchan remotes server_connections
131
132
133{- ClientSessions
134 -
135 - This is the per-client state. It is manipulated mainly via the
136 - JabberClientSession interface.
137 -}
138data ClientSession = ClientSession {
139 localhost :: Peer, -- anotehr name or the LocalHost constructor, todo: remove this.
140
141 -- unix_uid: This is the detected uid of the user of the connecting client.
142 -- The ByteString is the numeric inode text parsed from /proc/net/tcp6
143 -- (*not* the login name of the user)
144 unix_uid :: (IORef (Maybe (UserID,L.ByteString))),
145
146 unix_pid :: Maybe CPid,
147
148 -- unix_resource: This is the detected TTY of the connecting client.
149 unix_resource :: (IORef (Maybe L.ByteString)),
150
151 -- chans: This is a list of channels that the session is reading and will be
152 -- whose counts will be decremented when the session ends.
153 -- Note: currently is likely to be only two channels, the
154 -- localSubscriber & rosterChannel of the global state record.
155 chans :: TVar [RefCountedChan],
156
157 clientChannel :: TChan ClientCommands,
158
159 -- presence_state: a reference to the global state.
160 presence_state :: PresenceState
161}
162
163instance JabberClientSession ClientSession where
164 data XMPPClass ClientSession = ClientSessions PresenceState
165
166 newSession (ClientSessions state) sock = do
167 -- muid <- getLocalPeerCred sock
168 addr <- getPeerName sock
169 muid <- getLocalPeerCred' addr
170 debugL $ "CLIENT SESSION: open " <++> bshow muid
171 uid_ref <- newIORef muid
172 (mtty,pid) <- getTTYandPID muid
173 res_ref <- newIORef mtty
174 chans <- atomically $ newTVar []
175 clientChan <- atomically $ newTChan
176 return $ ClientSession (hostname state) uid_ref pid res_ref chans clientChan state
177 where
178 getTTYandPID muid = do
179 us <- fmap (map (second fst) . Map.toList) . readTVarIO $ activeUsers state
180 let tailOf3 ((_,a),b) = (a,b)
181 (t,pid) <- case muid of
182 Just (uid,inode) -> identifyTTY (map tailOf3 us) uid inode
183 Nothing -> return (Nothing,Nothing)
184 let rsc = t `mplus` fmap ( ("pid."<++>) . bshow ) pid
185 return (rsc,pid)
186
187 setResource s wanted_resource = do
188 -- TODO: handle resource = empty string
189 rsc <- readIORef (unix_resource s)
190 let rsc' = maybe wanted_resource id rsc
191 writeIORef (unix_resource s) (Just rsc')
192 debugL $ "CLIENT SESSION: resource " <++> rsc' <++> " (wanted: "<++>wanted_resource<++>")"
193
194 setPresence s stat = do
195 withJust (unix_pid s) $ \client_pid -> do
196 whenJust (readIORef (unix_resource s)) $ \tty -> do
197 user <- readIORef (unix_uid s) >>= getJabberUserForId
198 greedysubs <- atomically $ do
199 let au = activeUsers . presence_state $ s
200 us <- readTVar au
201 sequenceA $ Map.lookup (user,tty) us >>= \(ttypid,cs) -> do
202 let entry = (ttypid, Map.insert client_pid
203 (Client {
204 clientShow = stat,
205 clientChan = Main.clientChannel s
206 })
207 cs)
208 Just $ do
209 writeTVar au (Map.insert (user,tty) entry us)
210 subs <- readTVar $ subscriberMap (presence_state s)
211 greedy <- fmap snd . readTMVar $ localSubscriber (presence_state s)
212 activetty <- readTVar $ currentTTY (presence_state s)
213 usermap <- readTVar $ activeUsers (presence_state s)
214 return (greedy,subs,activetty,usermap)
215 withJust greedysubs $ \(greedy,subs,active_tty,usermap) -> do
216 update_presence (Just greedy)
217 (fmap snd subs)
218 [JID (Just user) (localhost s) (Just tty)]
219 (matchResource usermap active_tty)
220
221 getJID s = do
222 let host = localhost s
223 user <- readIORef (unix_uid s) >>= getJabberUserForId
224
225 rsc <- readIORef (unix_resource s)
226 -- let jid = user <++> "@" <++> host <++?> "/" <++$> rsc
227 -- debugL $ "CLIENT SESSION: jid " <++> L.show (JID (Just user) host rsc)
228 return (JID (Just user) host rsc)
229
230 closeSession s = do
231 atomically $ do
232 cs <- readTVar (chans s)
233 forM_ cs $ \(RefCountedChan c) -> do
234 unsubscribeToChan c
235 debugL "CLIENT SESSION: close"
236 withJust (unix_pid s) $ \client_pid -> do
237 whenJust (readIORef (unix_resource s)) $ \tty -> do
238 user <- readIORef (unix_uid s) >>= getJabberUserForId
239 atomically $ do
240 let au = activeUsers . presence_state $ s
241 us <- readTVar au
242 let remove = second (Map.delete client_pid)
243 writeTVar au (Map.adjust remove (user,tty) us)
244
245 subscribe session Nothing = do
246 let tmvar = localSubscriber (presence_state session)
247 atomically $ do
248 cs <- readTVar (chans session)
249 writeTVar (chans session) (RefCountedChan tmvar:cs)
250 subscribeToChan tmvar
251 subscribe session (Just jid) = do -- UNUSED as yet
252 let tvar = subscriberMap (presence_state session)
253 atomically $ subscribeToMap tvar jid
254
255 subscribeToRoster session = do
256 let rchan = rosterChannel . presence_state $ session
257 atomically $ do
258 cs <- readTVar (chans session)
259 writeTVar (chans session) (RefCountedChan rchan:cs)
260 subscribeToChan rchan
261
262 clientChannel session = Main.clientChannel session
263
264 forCachedPresence s action = do
265 jid <- getJID s
266 debugL $ "forCachedPresence "<++> bshow jid
267 withJust (name jid) $ \user -> do
268 let parseHostNameJID' str = do
269 handle (\(SomeException _) -> return Nothing)
270 (fmap Just . parseHostNameJID $ str)
271 buddies <- do
272 buddies <- ConfigFiles.getBuddies user
273 fmap catMaybes (mapM parseHostNameJID' buddies)
274 remotes <- readTVarIO . remoteUsers . presence_state $ s
275 forM_ buddies $ \buddy -> do
276 debugL $ "forCachedPresence buddy = "<++> bshow buddy
277 let mjids = fmap snd $ Map.lookup (peer buddy) remotes
278 jids <- maybe (return MM.empty) readTVarIO mjids
279 debugL $ "forCachedPresence jids = "<++> bshow jids
280 withJust (splitResource buddy) $ \(buddyU,_) -> do
281 forM_ (Set.toList . MM.lookup buddyU $ jids) $ \(rsc,status) -> do
282 let p = Presence (buddy `withResource` Just rsc) status
283 debugL $ "cached presence: " <++> bshow p
284 action p
285 -- forCachedPresence jids = MM (fromList
286 -- [(JabberUser (Chunk "joe" Empty) (RemotePeer [fde3:6df:8be1:81ef:8bae:a0df:9c5d:5]:0)
287 -- ,fromList [(Chunk "tty7" Empty,Available)])])
288 -- cached presence: Presence joe@[fde3:6df:8be1:81ef:8bae:a0df:9c5d:5] Available
289
290
291 sendPending s = do
292 jid <- getJID s
293 debugL $ "sendPending "<++> bshow jid
294 flip (maybe (return ())) (name jid) $ \user -> do
295 pending <- ConfigFiles.getPending user
296 let getRChan = do
297 let rchan = rosterChannel . presence_state $ s
298 isempty <- isEmptyTMVar rchan
299 if (not isempty)
300 then do
301 (_,ch) <- readTMVar rchan
302 return . Just $ ch
303 else return Nothing
304 atomically $ do
305 whenJust getRChan $ \rchan -> do
306 forM_ pending (writeTChan rchan . PendingSubscriber user)
307
308 addSolicited s jid_str jid = do
309 me <- getJID s
310 withJust (name me) $ \user -> do
311 addRawJid ConfigFiles.modifySolicited user jid_str
312
313 rosterPush (RequestedSubscription user jid_str) (presence_state s)
314
315 sendMessage (remotePeers . presence_state $ s)
316 (Solicitation me jid)
317 (peer jid)
318
319
320 getMyBuddies s = do
321 user <- readIORef (unix_uid s) >>= getJabberUserForId
322 ConfigFiles.getBuddies user
323 getMySubscribers s = do
324 user <- readIORef (unix_uid s) >>= getJabberUserForId
325 ConfigFiles.getSubscribers user
326 getMyOthers s = do
327 user <- readIORef (unix_uid s) >>= getJabberUserForId
328 ConfigFiles.getOthers user
329 getMyPending s = do
330 user <- readIORef (unix_uid s) >>= getJabberUserForId
331 ConfigFiles.getPending user
332 getMySolicited s = do
333 user <- readIORef (unix_uid s) >>= getJabberUserForId
334 ConfigFiles.getSolicited user
335
336 isSubscribed s contact = do
337 handleIO (\e -> return False) $ do
338 user <- readIORef (unix_uid s) >>= getJabberUserForId
339 subs <- ConfigFiles.getSubscribers user
340 debugL $ "isSubscribed parsing: "<++>contact
341 cjid <- parseHostNameJID contact
342 msubs <- mapM (cmpJID cjid) subs
343 return (Nothing `elem` msubs)
344
345 isBuddy s contact = do
346 handleIO (\e -> return False) $ do
347 user <- readIORef (unix_uid s) >>= getJabberUserForId
348 subs <- ConfigFiles.getBuddies user
349 debugL $ "isBuddy parsing: "<++>contact
350 cjid <- parseHostNameJID contact
351 msubs <- mapM (cmpJID cjid) subs
352 return (Nothing `elem` msubs)
353
354
355 approveSubscriber s contact = do
356 user <- readIORef (unix_uid s) >>= getJabberUserForId
357 cjid <- parseHostNameJID contact
358 let rmjid modify user buddy = modify user (cmpJID buddy) Nothing
359
360 -- update config files
361 addRawJid ConfigFiles.modifySubscribers user contact -- add subscribers
362 rmjid ConfigFiles.modifyPending user cjid
363 rmjid ConfigFiles.modifyOthers user cjid
364
365 -- roster push
366 rosterPush (NewSubscriber user contact) (presence_state s)
367
368 -- notify peer
369 sendMessage (remotePeers . presence_state $ s)
370 (Approval (JID (Just user) LocalHost Nothing)
371 cjid)
372 (peer cjid)
373 presence <- getUserStatus (presence_state s) user
374 let cons = remotePeers . presence_state $ s
375 forM_ presence $ \p -> sendMessage cons (OutBoundPresence p) (peer cjid)
376 return ()
377
378 rejectSubscriber s contact = do
379 user <- readIORef (unix_uid s) >>= getJabberUserForId
380 cjid <- parseHostNameJID contact
381 let rmjid modify user buddy = modify user (cmpJID buddy) Nothing
382
383 -- update config files
384 was_pending <- rmjid ConfigFiles.modifyPending user cjid
385 was_subscribed <- rmjid ConfigFiles.modifySubscribers user cjid
386 addRawJid ConfigFiles.modifyOthers user contact
387
388 -- roster push
389 rosterPush (RejectSubscriber user contact) (presence_state s)
390
391 -- notify peer
392 when (was_pending || was_subscribed) $ do
393 let cons = remotePeers . presence_state $ s
394 isonline (Presence _ Offline) = False
395 isonline _ = True
396 presence <- fmap (filter isonline) $ getUserStatus (presence_state s) user
397 me <- getJID s
398 when (not (null presence)) $
399 sendMessage cons (OutBoundPresence . Presence me $ Offline) (peer cjid)
400 sendMessage (remotePeers . presence_state $ s)
401 (Rejection (JID (Just user) LocalHost Nothing)
402 cjid)
403 (peer cjid)
404 return ()
405
406 sendChat s msg = do
407 sendMessage (remotePeers . presence_state $ s)
408 (OutBoundMessage msg)
409 (peer . msgTo $ msg)
410
411
412{- PeerSession
413 -
414 - This is the per-remote-peer state. It is manipulated mainly via the
415 - JabberPeerSession interface.
416 -}
417data PeerSession = PeerSession {
418 -- announced: a list of users that were announced by the remote peer.
419 -- This list is kept in order to mark them all offline in
420 -- case the peer connection is lost or goes down.
421 announced :: TVar (MultiMap JabberUser (JabberResource,JabberShow)),
422
423 -- peer_name: This the address of the remote peer.
424 peer_name :: Peer,
425
426 -- peer_global: a reference to the global state.
427 peer_global :: PresenceState
428}
429
430instance JabberPeerSession PeerSession where
431 data XMPPPeerClass PeerSession = PeerSessions PresenceState
432
433 newPeerSession (PeerSessions state) sock = do
434 me <- fmap (RemotePeer . withoutPort) (getPeerName sock)
435 debugL $ "PEER SESSION: open "<++>showPeer me
436 let remotes = remoteUsers state
437 (jids,us) <- atomically $ do
438 jids <- getRefFromMap remotes me (newTVar MM.empty) return
439 us <- readTVar (activeUsers state)
440 return (jids,map tupleToJID . Set.toList . Map.keysSet $ us)
441 forM_ us $ sendProbes state (Just me)
442 return $ PeerSession jids me state
443
444 closePeerSession session = do
445 debugL $ "PEER SESSION: close "<++>showPeer (peer_name session)
446 let offline jid = Presence jid Offline
447 unrefFromMap (remoteUsers . peer_global $ session) (peer_name session)
448 $ do
449 sendPeerMessage session Disconnect
450 debugStr ("unrefFromMap!")
451 js <- fmap (MM.toAscList) (readTVarIO . announced $ session)
452 forM_ js $ \(u,rs) -> do
453 forM_ (Set.toList rs) $ \(rsc,_) -> do
454 debugStr ("Annoucing offline: "++show (offline $ unsplitResource u (Just rsc)))
455 announcePresence session . offline $ unsplitResource u (Just rsc)
456
457 peerSessionFactory session = PeerSessions (peer_global session)
458
459 peerAddress session = peer_name session
460
461 userStatus session user = getUserStatus (peer_global session) user
462
463 -- This should be used on inbound presence to inform clients.
464 -- For outbound, use sendPeerMessage and OutBoundPresence.
465 announcePresence session (Presence jid status) = do
466 (greedy,subs) <- atomically $ do
467 subs <- readTVar $ subscriberMap (peer_global session)
468 greedy <- fmap snd $ readTMVar $ localSubscriber (peer_global session)
469 return (greedy,subs)
470 update_presence (Just greedy) (fmap snd subs) [jid] (const status)
471 liftIO . atomically $ do
472 jids <- readTVar . announced $ session
473 withJust (splitResource jid) $ \(u,rsc) -> do
474 let match (r',_) = (rsc==Nothing || Just r'==rsc)
475 writeTVar (announced session)
476 $ case status of
477 Offline -> MM.deleteElemIf u match jids
478 stat -> maybe jids (\r -> MM.insert u (r,stat) jids) rsc
479
480 sendPeerMessage session msg = do
481 let cons = remotePeers . peer_global $ session
482 debugL $ "sendPeerMessage " <++> bshow msg <++> " --> "<++>bshow (peer_name session)
483 sendMessage cons msg (peer_name session)
484
485 getBuddies _ user = ConfigFiles.getBuddies user
486 getSubscribers _ user = ConfigFiles.getSubscribers user
487
488 processApproval session user buddy = do
489 solicited <- ConfigFiles.getSolicited user
490 let rmjid modify user buddy = modify user (cmpJID buddy) Nothing
491 was_sol <- rmjid ConfigFiles.modifySolicited user buddy
492 when was_sol $ do -- if buddy ∈ solicited:
493 addJid ConfigFiles.modifyBuddies user buddy -- add buddies
494 rmjid ConfigFiles.modifyOthers user buddy -- remove others
495 mbuddy <- asHostNameJID buddy
496 withJust mbuddy $ \buddy -> do
497 rosterPush (NewBuddy user buddy) (peer_global session)
498
499 processRejection session user buddy = do
500 solicited <- ConfigFiles.getSolicited user
501 let rmjid modify user buddy = modify user (cmpJID buddy) Nothing
502 was_sol <- rmjid ConfigFiles.modifySolicited user buddy
503 when was_sol $ do -- if buddy ∈ solicited:
504 rmjid ConfigFiles.modifyBuddies user buddy -- remove buddies
505 addJid ConfigFiles.modifyOthers user buddy -- add others
506 mbuddy <- asHostNameJID buddy
507 withJust mbuddy $ \buddy -> do
508 rosterPush (RemovedBuddy user buddy) (peer_global session)
509
510 processRequest session user buddy = do
511 let addjid modify user buddy = do
512 hbuddy <- asHostNameJID buddy
513 modify user (cmpJID buddy) hbuddy
514 was_pending <- addjid ConfigFiles.modifyPending user buddy
515 debugL $ "processRequest was_pending="<++>bshow was_pending
516 -- "all available resources in accordence with section 8"
517 -- Section 8 says (for presence of type "subscribe", the server MUST
518 -- adhere to the rules defined under Section 3 and summarized under
519 -- Appendix A.
520 -- Appendex A.3.1 says
521 -- contact ∈ subscribers --> SHOULD NOT, already handled
522 -- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT
523 -- contact ∉ subscribers & contact ∉ pending --> MUST
524 when (not was_pending) $ do
525 mbuddy <- asHostNameJID buddy
526 withJust mbuddy $ \buddy -> do
527 rosterPush (PendingSubscriber user buddy) (peer_global session)
528
529 sendChatToClient session msg = do
530 let rsc = resource (msgTo msg)
531 g = peer_global session
532 (curtty,cmap) <- atomically $ liftM2 (,) (readTVar (currentTTY g))
533 (readTVar (activeUsers g))
534
535 let rsc' = maybe curtty id rsc
536 withJust (name (msgTo msg)) $ \nto -> do
537 let send ((foundto,foundrsc),(ttypid,clients)) =
538 forM_ (Map.toList clients) $ \(pid,client) -> do
539 atomically $ writeTChan (clientChan client) (Chat msg)
540 let goodtos = filter (\((fto,_),_)->fto==nto) (Map.assocs cmap)
541 (good_rs,other_rs) = partition (\((_,r),_)->r==rsc') goodtos
542
543 -- new behavior that sends to all available resources
544 mapM_ send good_rs -- prefered destination (exact resource match)
545 mapM_ send other_rs -- other clients
546 let msgHere = localizedBody msg
547 msgElsewhere = "you have chat on "++show (snd . fst . head $ other_rs)
548 localizedBody msg = "TODO"
549 case (good_rs,other_rs) of
550 ([],[]) -> consoleMessage rsc' msgHere -- dump message to console
551 ([],_) -> consoleMessage rsc' msgElsewhere -- notify: was sent to other tty
552 _ -> return ()
553
554consoleMessage tty str = do
555 debugStr $ L.unpack tty ++ ": "++ str
556 return ()
557
558type RefCount = Int
559
560type JabberResource = L.ByteString
561type JabberName = L.ByteString
562data JabberUser = JabberUser JabberName Peer
563 deriving (Eq,Ord,Show)
564
565splitResource :: JID -> Maybe (JabberUser,Maybe JabberResource)
566splitResource (JID Nothing _ _ ) = Nothing
567splitResource (JID (Just n) p r ) = Just (JabberUser n p, r)
568
569unsplitResource (JabberUser n p) r = JID (Just n) p r
570
571
572rosterPush msg state = do
573 let rchan = rosterChannel state
574 atomically $ do
575 isempty <- isEmptyTMVar rchan
576 when (not isempty) $ do
577 (_,ch) <- readTMVar rchan
578 writeTChan ch msg
579
580getJabberUserForId muid =
581 maybe (return "nobody")
582 (\(uid,_) ->
583 handle (\(SomeException _) ->
584 return . L.append "uid." . L.pack . show $ uid)
585 $ do
586 user <- fmap userName $ getUserEntryForID uid
587 return (L.pack user)
588 )
589 muid
590
591cmpJID newitem jid = do
592 -- debugL $ "Comparing "<++>bshow jid
593 olditem <- parseHostNameJID jid
594 if olditem==newitem then return Nothing
595 else return $ Just jid
596
597
598addRawJid modify user jid = do
599 newitem <- parseHostNameJID jid
600 modify user (cmpJID newitem) (Just jid)
601 return ()
602
603addJid modify user jid = do
604 hjid <- asHostNameJID jid
605 debugL $ "addJid (asHostNameJID) --> "<++>bshow hjid
606 withJust hjid $ \hjid -> do
607 modify user (cmpJID jid) (Just hjid)
608 return ()
609
610tupleToJID (user,tty) = jid user LocalHost tty
611
612filterKeys f m = Map.filterWithKey (\k v->f k) m
613
614getUserStatus state user = do
615 (tty,users) <- atomically $ do
616 tty <- readTVar $ currentTTY state
617 users <- readTVar $ activeUsers state
618 return (tty,users)
619 let jids = filterKeys (\(name,tty) -> name ==user) users
620 ps = map (\jid -> Presence (tupleToJID jid) (matchResource' tty jid))
621 . keys
622 $ jids
623 if null ps
624 then return [Presence (JID { name=Just user, peer=LocalHost, resource=Nothing }) Offline]
625 else return ps
626
627
628
629data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a))
630
631subscribeToChan :: TMVar (RefCount, TChan a) -> STM (TChan a)
632subscribeToChan tmvar =
633 (do (cnt,chan) <- takeTMVar tmvar
634 putTMVar tmvar (cnt+1,chan)
635 chan' <- dupTChan chan
636 return chan' )
637 `orElse`
638 (do chan <- newTChan
639 putTMVar tmvar (1,chan)
640 return chan )
641unsubscribeToChan :: TMVar (RefCount,TChan a) -> STM ()
642unsubscribeToChan tmvar = do
643 isEmpty <- isEmptyTMVar tmvar
644 when (not isEmpty) $ do
645 (cnt,chan) <- takeTMVar tmvar
646 when (cnt>1) (putTMVar tmvar (cnt-1,chan))
647
648getRefFromMap tvar key newObject copyObject = do
649 subs <- readTVar tvar
650 let mbobject = Map.lookup key subs
651 (object,subs') <-
652 do case mbobject of
653 Nothing -> do
654 newobject <- newObject
655 return (newobject, Map.insert key (1,newobject) subs)
656 Just (cnt,object) -> do
657 object' <- copyObject object
658 return (object', Map.insert key (cnt+1,object) subs)
659 writeTVar tvar subs'
660 return object
661
662unrefFromMap tvar key finalizer = do
663 vanished <- atomically $ do
664 omap <- readTVar tvar
665 let (r,omap') = Map.updateLookupWithKey unref key omap
666 writeTVar tvar omap'
667 -- updateLookupWithKey
668 -- The function returns changed value, if it is updated.
669 -- Returns the original key value if the map entry is deleted.
670 -- GAAAHGAFHASD:LFKJDSA:LKFJPOFEIWE:FLJF!#@!$@#!
671 -- FUCK YOU Data.Map
672 -- Guess I have to do another pointless logarithmic lookup.
673 return (isNothing (Map.lookup key omap'))
674 when vanished finalizer
675 where
676 unref key (cnt,object) =
677 if cnt==1 then Nothing
678 else Just (cnt-1,object)
679
680
681subscribeToMap tvar jid =
682 getRefFromMap tvar jid newTChan dupTChan
683
684matchResource usermap tty jid = maybe Away (avail . (==tty)) $ resource jid
685 where
686 avail True = case ( name jid >>= \u -> Map.lookup (u,tty) usermap ) of
687 Nothing -> Available
688 Just (pid,clients) ->
689 let stats = map (clientShow . snd) . Map.toList $ clients
690 in if null stats
691 then Available
692 else maximum stats
693 avail False = Away
694
695matchResource' tty (_,rsc) = avail (rsc==tty)
696 where
697 avail True = Available
698 avail False = Away
699
700sendPresence chan jid status =
701 (liftIO . atomically . writeTChan chan . Presence jid $ status) :: MaybeT IO ()
702
703lookupT jid subscribers = MaybeT . return $ Map.lookup jid subscribers
704
705update_presence locals_greedy subscribers state getStatus =
706 forM_ state $ \jid -> do
707 let status = getStatus jid
708 runMaybeT $ do
709 chan <- lookupT jid subscribers
710 sendPresence chan jid status
711 runMaybeT $ do
712 chan <- MaybeT . return $ locals_greedy
713 sendPresence chan jid status
714 debugL $ bshow jid <++> " " <++> bshow status
715
716sendProbes state mbpeer jid = do
717 debugL $ "sending probes for " <++> bshow jid
718 withJust (name jid) $ \user -> do
719 let parseHostNameJID' str = do
720 handle (\(SomeException _) -> return Nothing)
721 (fmap Just . parseHostNameJID $ str)
722 buddies <- do
723 buddies <- ConfigFiles.getBuddies user
724 buddies' <- fmap catMaybes (mapM parseHostNameJID' buddies)
725 case mbpeer of
726 Nothing -> return buddies'
727 Just p -> return (filter (\jid-> peer jid == p) buddies')
728 debugL $ "buddies for " <++> bshow jid <++> " = " <++> bshow buddies
729 wanted <- do
730 wanted <- ConfigFiles.getSolicited user
731 fmap catMaybes (mapM parseHostNameJID' wanted)
732 remotes <- readTVarIO (remoteUsers state)
733 forM_ (map (True,) buddies ++ map (False,) wanted) $ \(got,buddy) -> do
734 let mjids = fmap snd $ Map.lookup (peer buddy) remotes
735 jids <- maybe (return MM.empty) readTVarIO mjids
736 withJust (splitResource buddy) $ \(buddyU,_) -> do
737 let noinfo = not (MM.member buddyU jids)
738 when noinfo $ do
739 let msg = if got then PresenceProbe jid buddy else Solicitation jid buddy
740 debugL $ "sendMessage " <++> bshow msg
741 sendMessage (remotePeers state) msg (peer buddy)
742
743
744track_login host state e = do
745#ifndef NOUTMP
746 us <- UTmp.users
747#else
748 let us = []
749#endif
750 let toJabberId host (user,tty,pid) =
751 if L.take 3 tty == "tty"
752 then Just ((user,tty),pid) -- (jid user host tty)
753 else Nothing
754 new_users0 = mapMaybe (toJabberId host) us
755 new_users' = Map.fromList
756 . map (\((u,tty),pid)-> ((u,tty),(pid,Map.empty)))
757 $ new_users0
758 (Set.fromList->new_users,_) = unzip new_users0
759 (tty,active_users,subs,locals_greedy) <- atomically $ do
760 tty <- readTVar $ currentTTY state
761 st <- flip swapTVar new_users' $ activeUsers state
762 xs <- readTVar $ subscriberMap state
763 locals_greedy <- tryReadTMVar $ localSubscriber state
764 return (tty,st,fmap snd xs,fmap snd locals_greedy)
765 let known_users = Map.keysSet active_users
766 let arrivals = map tupleToJID . Set.toList $ new_users \\ known_users
767 departures = map tupleToJID . Set.toList $ known_users \\ new_users
768 update_presence locals_greedy subs departures $ const Offline
769 update_presence locals_greedy subs arrivals $ matchResource active_users tty
770 forM_ arrivals
771 $ sendProbes state Nothing
772
773on_chvt state vtnum = do
774 let tty = L.snoc "tty" $ intToDigit (fromIntegral vtnum)
775 debugL $ "VT switch: " <++> tty
776 (active_users,subs,locals_greedy) <- atomically $ do
777 us <- readTVar $ activeUsers state
778 subs <- readTVar $ subscriberMap state
779 writeTVar (currentTTY state) tty
780 locals_greedy <- tryReadTMVar $ localSubscriber state
781 return (us,fmap snd subs,fmap snd locals_greedy)
782 let users = Map.keysSet active_users
783 update_presence locals_greedy
784 subs
785 (map tupleToJID . Set.toList $ users)
786 $ matchResource active_users tty
787
788-- start
789--
790-- This function creates the global state, kicks off all the server threads,
791-- and inotify watches and then waits for Enter before terminating the program.
792--
793start :: Network.Socket.Family -> IO ()
794start ip4or6 = do
795 let host = LocalHost
796 global_state <- newPresenceState host
797 let dologin e = track_login host global_state e
798 dologin :: t -> IO ()
799
800 chan <- atomically $ subscribeToChan (localSubscriber global_state)
801 remotes <- forkIO $ seekRemotePeers (PeerSessions global_state) chan (remotePeers global_state)
802
803 installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing
804
805 mtty <- monitorTTY (on_chvt global_state)
806 inotify <- initINotify
807#ifndef NOUTMP
808 wd <- addWatch
809 inotify
810 [CloseWrite] -- [Open,Close,Access,Modify,Move]
811 utmp_file
812 dologin
813#endif
814 clients <- listenForXmppClients ip4or6 (ClientSessions global_state) 5222 HNil
815 peers <- listenForRemotePeers ip4or6 (PeerSessions global_state) 5269 HNil
816
817 threadDelay 1000 -- wait a moment to obtain current tty
818 dologin ()
819 -- L.putStrLn "\nHit enter to terminate...\n"
820 quitVar <- newEmptyTMVarIO
821 installHandler sigTERM (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
822 quitMessage <- atomically $ takeTMVar quitVar
823 -- getLine
824
825 killThread remotes
826 quitListening clients
827 quitListening peers
828 -- threadDelay 1000
829 debugL "closed listener."
830 unmonitorTTY mtty
831 debugL "unhooked tty monitor."
832#ifndef NOUTMP
833 removeWatch wd
834#endif
835 debugL "Normal termination."
836
837sendUSR1 pid = do
838 signalProcess sigUSR1 pid
839
840getStartupAction [] = throw (userError "pid file?") >> return (Right "")
841getStartupAction (p:ps) = do
842 handle onEr $
843 ( do
844 pid <- fmap CPid (readFile p >>= readIO)
845 -- signal pid
846 return (Left pid) )
847 where
848 onEr (SomeException _) = do
849 pid <- getProcessID
850 debugL $ "starting pid = " <++> bshow pid
851 handle (\(SomeException _) -> getStartupAction ps)
852 (do
853 writeFile p (show pid)
854 debugL $ "writing " <++> bshow p
855 -- start daemon
856 return (Right p) )
857
858runOnce ps run notify = getStartupAction ps >>= doit
859 where
860 doit (Left pid ) = notify pid
861 doit (Right pidfile ) = do
862 run
863 removeFile pidfile
864
865getOptions [] = Map.empty
866
867getOptions (('-':opt_name):xs) =
868 if xs/=[] && xs!!0!!0/='-'
869 then Map.insert (L.pack opt_name) (L.pack (xs!!0)) (getOptions (tail xs))
870 else Map.insert (L.pack opt_name) "" (getOptions xs)
871
872getOptions (x0:xs) = getOptions xs
873
874
875-- main
876--
877-- This function parses the comand line arguments and checks if the pid file already
878-- exists. If the pid file exists, it signals USR1 to the currently running daemon.
879-- Otherwise, it chains to the true "main" function of the application: Main.start
880main = do
881 opts <- fmap getOptions getArgs
882 let use_ip4 = if isJust (Map.lookup "4" opts) then AF_INET else AF_INET6
883 -- Disabled because of failing to start after a crash:
884 -- -- This code sends USR1 to a running instance to trigger rescan of utmp file.
885 -- runOnce ["/var/run/presence.pid","/tmp/presence.pid"] (start use_ip4) sendUSR1
886 start use_ip4
887
888
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 20:00:29 +0000