1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TupleSections #-}
module Main where
import System.Directory
import Control.Monad
import System.Posix.Signals
import System.Posix.Types
import System.Posix.Process
import Data.Maybe
import Data.Char
import ConfigFiles
import System.INotify
#ifndef NOUTMP
import UTmp
-- UTmp is inconvenient for the profiling build due to Template Haskell
-- causing ghc to report:
--
-- Dynamic linking required, but this is a non-standard build (eg. prof).
-- You need to build the program twice: once the normal way, and then
-- in the desired way using -osuf to set the object file suffix.
--
-- ... so -DNOUTMP was introduced to remove TemplateHaskell from the build.
-- However, a full-featured profiling build can be built using the bp
-- script which makes a non-profiling binary available during the build in
-- the manner in which the error message attempted (and failed) to communicate.
#endif
import FGConsole
import XMPP
import ControlMaybe
import Data.HList
import Control.Exception hiding (catch)
import LocalPeerCred
import System.Posix.User
import qualified Data.Set as Set
import Data.Set as Set (Set,(\\))
import qualified Data.Map as Map
import Data.Map as Map (Map)
import Control.Concurrent.STM
import Control.Concurrent
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import ByteStringOperators
import qualified Data.ByteString.Lazy.Char8 as L
import Data.ByteString.Lazy.Char8 as L (ByteString,putStrLn)
import qualified Prelude
import Prelude hiding (putStrLn)
import System.Environment
-- import qualified Text.Show.ByteString as L
import Network.Socket (Family(AF_INET,AF_INET6))
import Holumbus.Data.MultiMap as MM (MultiMap)
import qualified Holumbus.Data.MultiMap as MM
type RefCount = Int
type JabberResource = L.ByteString
type JabberName = L.ByteString
data JabberUser = JabberUser JabberName Peer
deriving (Eq,Ord,Show)
splitResource :: JID -> Maybe (JabberUser,Maybe JabberResource)
splitResource (JID Nothing _ _ ) = Nothing
splitResource (JID (Just n) p r ) = Just (JabberUser n p, r)
unsplitResource (JabberUser n p) r = JID (Just n) p r
data PresenceState = PresenceState
{ hostname :: Peer -- ByteString, TODO: remove this, its always LocalHost now
, currentTTY :: TVar ByteString
, activeUsers :: TVar (Set (UserName, Tty, ProcessID))
, subscriberMap :: TVar (Map JID (RefCount,TChan Presence)) -- UNUSED as yet
, localSubscriber :: TMVar (RefCount,TChan Presence) -- TODO: rename this, its not just locals
-- ... or make a seperate channel for remotes
, rosterChannel :: TMVar (RefCount,TChan RosterEvent)
, remoteUsers :: TVar (Map Peer (RefCount,TVar (MultiMap JabberUser (JabberResource,JabberShow))))
, outGoingConnections :: TVar (Map Peer (TChan OutBoundMessage, ThreadId))
}
rosterPush msg state = do
let rchan = rosterChannel state
atomically $ do
isempty <- isEmptyTMVar rchan
when (not isempty) $ do
(_,ch) <- readTMVar rchan
writeTChan ch msg
getJabberUserForId muid =
maybe (return "nobody")
(\(uid,_) ->
handle (\(SomeException _) ->
return . L.append "uid." . L.pack . show $ uid)
$ do
user <- fmap userName $ getUserEntryForID uid
return (L.pack user)
)
muid
data ClientSession = ClientSession {
localhost :: Peer, -- ByteString,
unix_uid :: (IORef (Maybe (UserID,L.ByteString))),
unix_resource :: (IORef (Maybe L.ByteString)),
chans :: TVar [RefCountedChan],
presence_state :: PresenceState
}
cmpJID newitem jid = do
-- putStrLn $ "Comparing "<++>bshow jid
olditem <- parseHostNameJID jid
if olditem==newitem then return Nothing
else return $ Just jid
addRawJid modify user jid = do
newitem <- parseHostNameJID jid
modify user (cmpJID newitem) (Just jid)
return ()
addJid modify user jid = do
hjid <- asHostNameJID jid
putStrLn $ "addJid (asHostNameJID) --> "<++>bshow hjid
withJust hjid $ \hjid -> do
modify user (cmpJID jid) (Just hjid)
return ()
instance JabberClientSession ClientSession where
data XMPPClass ClientSession = ClientSessions PresenceState
newSession (ClientSessions state) sock = do
-- muid <- getLocalPeerCred sock
addr <- getPeerName sock
muid <- getLocalPeerCred' addr
L.putStrLn $ "CLIENT SESSION: open " <++> bshow muid
uid_ref <- newIORef muid
res_ref <- newIORef Nothing
chans <- atomically $ newTVar []
return $ ClientSession (hostname state) uid_ref res_ref chans state
setResource s resource = do
-- TODO: handle resource = empty string
us <- fmap Set.toList . readTVarIO $ activeUsers (presence_state s)
muid <- readIORef (unix_uid s)
let tailOf3 (_,a,b) = (a,b)
(t,pid) <- case muid of
Just (uid,inode) -> identifyTTY (map tailOf3 us) uid inode
Nothing -> return (Nothing,Nothing)
let rsc = t `mplus` fmap ( ("pid."<++>) . bshow ) pid
rsc' = maybe resource id rsc
writeIORef (unix_resource s) (Just rsc')
L.putStrLn $ "CLIENT SESSION: resource " <++> rsc'
getJID s = do
let host = localhost s
user <- readIORef (unix_uid s) >>= getJabberUserForId
rsc <- readIORef (unix_resource s)
-- let jid = user <++> "@" <++> host <++?> "/" <++$> rsc
-- L.putStrLn $ "CLIENT SESSION: jid " <++> L.show (JID (Just user) host rsc)
return (JID (Just user) host rsc)
closeSession session = do
atomically $ do
cs <- readTVar (chans session)
forM_ cs $ \(RefCountedChan c) -> do
unsubscribeToChan c
L.putStrLn "CLIENT SESSION: close"
subscribe session Nothing = do
let tmvar = localSubscriber (presence_state session)
atomically $ do
cs <- readTVar (chans session)
writeTVar (chans session) (RefCountedChan tmvar:cs)
subscribeToChan tmvar
subscribe session (Just jid) = do -- UNUSED as yet
let tvar = subscriberMap (presence_state session)
atomically $ subscribeToMap tvar jid
subscribeToRoster session = do
let rchan = rosterChannel . presence_state $ session
atomically $ do
cs <- readTVar (chans session)
writeTVar (chans session) (RefCountedChan rchan:cs)
subscribeToChan rchan
forCachedPresence s action = do
jid <- getJID s
L.putStrLn $ "forCachedPresence "<++> bshow jid
withJust (name jid) $ \user -> do
let parseHostNameJID' str = do
handle (\(SomeException _) -> return Nothing)
(fmap Just . parseHostNameJID $ str)
buddies <- do
buddies <- ConfigFiles.getBuddies user
fmap catMaybes (mapM parseHostNameJID' buddies)
remotes <- readTVarIO . remoteUsers . presence_state $ s
forM_ buddies $ \buddy -> do
L.putStrLn $ "forCachedPresence buddy = "<++> bshow buddy
let mjids = fmap snd $ Map.lookup (peer buddy) remotes
jids <- maybe (return MM.empty) readTVarIO mjids
L.putStrLn $ "forCachedPresence jids = "<++> bshow jids
withJust (splitResource buddy) $ \(buddyU,_) -> do
forM_ (Set.toList . MM.lookup buddyU $ jids) $ \(rsc,status) -> do
let p = Presence buddy status
L.putStrLn $ "cached presence: " <++> bshow p
action p
sendPending s = do
jid <- getJID s
putStrLn $ "sendPending "<++> bshow jid
flip (maybe (return ())) (name jid) $ \user -> do
pending <- ConfigFiles.getPending user
let getRChan = do
let rchan = rosterChannel . presence_state $ s
isempty <- isEmptyTMVar rchan
if (not isempty)
then do
(_,ch) <- readTMVar rchan
return . Just $ ch
else return Nothing
atomically $ do
whenJust getRChan $ \rchan -> do
forM_ pending (writeTChan rchan . PendingSubscriber user)
addSolicited s jid_str jid = do
me <- getJID s
withJust (name me) $ \user -> do
addRawJid ConfigFiles.modifySolicited user jid_str
rosterPush (RequestedSubscription user jid_str) (presence_state s)
sendMessage (outGoingConnections . presence_state $ s)
(Solicitation me jid)
(peer jid)
getMyBuddies s = do
user <- readIORef (unix_uid s) >>= getJabberUserForId
ConfigFiles.getBuddies user
getMySubscribers s = do
user <- readIORef (unix_uid s) >>= getJabberUserForId
ConfigFiles.getSubscribers user
getMyOthers s = do
user <- readIORef (unix_uid s) >>= getJabberUserForId
ConfigFiles.getOthers user
getMyPending s = do
user <- readIORef (unix_uid s) >>= getJabberUserForId
ConfigFiles.getPending user
getMySolicited s = do
user <- readIORef (unix_uid s) >>= getJabberUserForId
ConfigFiles.getSolicited user
isSubscribed s contact = do
handleIO (\e -> return False) $ do
user <- readIORef (unix_uid s) >>= getJabberUserForId
subs <- ConfigFiles.getSubscribers user
putStrLn $ "isSubscribed parsing: "<++>contact
cjid <- parseHostNameJID contact
msubs <- mapM (cmpJID cjid) subs
return (Nothing `elem` msubs)
isBuddy s contact = do
handleIO (\e -> return False) $ do
user <- readIORef (unix_uid s) >>= getJabberUserForId
subs <- ConfigFiles.getBuddies user
putStrLn $ "isBuddy parsing: "<++>contact
cjid <- parseHostNameJID contact
msubs <- mapM (cmpJID cjid) subs
return (Nothing `elem` msubs)
approveSubscriber s contact = do
user <- readIORef (unix_uid s) >>= getJabberUserForId
cjid <- parseHostNameJID contact
let rmjid modify user buddy = modify user (cmpJID buddy) Nothing
-- update config files
addRawJid ConfigFiles.modifySubscribers user contact -- add subscribers
rmjid ConfigFiles.modifyPending user cjid
rmjid ConfigFiles.modifyOthers user cjid
-- roster push
rosterPush (NewSubscriber user contact) (presence_state s)
-- notify peer
sendMessage (outGoingConnections . presence_state $ s)
(Approval (JID (Just user) LocalHost Nothing)
cjid)
(peer cjid)
presence <- getUserStatus (presence_state s) user
let cons = outGoingConnections . presence_state $ s
forM_ presence $ \p -> sendMessage cons (OutBoundPresence p) (peer cjid)
return ()
rejectSubscriber s contact = do
user <- readIORef (unix_uid s) >>= getJabberUserForId
cjid <- parseHostNameJID contact
let rmjid modify user buddy = modify user (cmpJID buddy) Nothing
-- update config files
was_pending <- rmjid ConfigFiles.modifyPending user cjid
was_subscribed <- rmjid ConfigFiles.modifySubscribers user cjid
addRawJid ConfigFiles.modifyOthers user contact
-- roster push
rosterPush (RejectSubscriber user contact) (presence_state s)
-- notify peer
when (was_pending || was_subscribed) $ do
let cons = outGoingConnections . presence_state $ s
isonline (Presence _ Offline) = False
isonline _ = True
presence <- fmap (filter isonline) $ getUserStatus (presence_state s) user
me <- getJID s
when (not (null presence)) $
sendMessage cons (OutBoundPresence . Presence me $ Offline) (peer cjid)
sendMessage (outGoingConnections . presence_state $ s)
(Rejection (JID (Just user) LocalHost Nothing)
cjid)
(peer cjid)
return ()
tupleToJID (user,tty,pid) = jid user LocalHost tty
getUserStatus state user = do
(tty,users) <- atomically $ do
tty <- readTVar $ currentTTY state
users <- readTVar $ activeUsers state
return (tty,users)
let jids = Set.filter (\(name,tty,pid) -> name ==user) users
ps = map (\jid -> Presence (tupleToJID jid) (matchResource' tty jid)) . Set.toList $ jids
if null ps
then return [Presence (JID { name=Just user, peer=LocalHost, resource=Nothing }) Offline]
else return ps
data PeerSession = PeerSession {
announced :: TVar (MultiMap JabberUser (JabberResource,JabberShow)),
peer_name :: Peer,
peer_global :: PresenceState
}
instance JabberPeerSession PeerSession where
data XMPPPeerClass PeerSession = PeerSessions PresenceState
newPeerSession (PeerSessions state) sock = do
me <- fmap (RemotePeer . withoutPort) (getPeerName sock)
L.putStrLn $ "PEER SESSION: open "<++>showPeer me
let remotes = remoteUsers state
jids <- atomically $ getRefFromMap remotes me (newTVar MM.empty) return
return $ PeerSession jids me state
closePeerSession session = do
L.putStrLn $ "PEER SESSION: close "<++>showPeer (peer_name session)
let offline jid = Presence jid Offline
unrefFromMap (remoteUsers . peer_global $ session) (peer_name session)
$ do
js <- fmap (MM.toAscList) (readTVarIO . announced $ session)
forM_ js $ \(u,rs) -> do
forM_ (Set.toList rs) $ \(rsc,_) -> do
announcePresence session . offline $ unsplitResource u (Just rsc)
peerSessionFactory session = PeerSessions (peer_global session)
peerAddress session = peer_name session
userStatus session user = getUserStatus (peer_global session) user
-- This should be used on inbound presence to inform clients.
-- For outbound, use sendPeerMessage and OutBoundPresence.
announcePresence session (Presence jid status) = do
(greedy,subs) <- atomically $ do
subs <- readTVar $ subscriberMap (peer_global session)
greedy <- fmap snd $ readTMVar $ localSubscriber (peer_global session)
return (greedy,subs)
update_presence (Just greedy) (fmap snd subs) [jid] (const status)
liftIO . atomically $ do
jids <- readTVar . announced $ session
withJust (splitResource jid) $ \(u,rsc) -> do
let match (r',_) = (rsc==Nothing || Just r'==rsc)
writeTVar (announced session)
$ case status of
Offline -> MM.deleteElemIf u match jids
stat -> maybe jids (\r -> MM.insert u (r,stat) jids) rsc
sendPeerMessage session msg = do
let cons = outGoingConnections . peer_global $ session
putStrLn $ "sendPeerMessage " <++> bshow msg <++> " --> "<++>bshow (peer_name session)
sendMessage cons msg (peer_name session)
getBuddies _ user = ConfigFiles.getBuddies user
getSubscribers _ user = ConfigFiles.getSubscribers user
processApproval session user buddy = do
solicited <- ConfigFiles.getSolicited user
let rmjid modify user buddy = modify user (cmpJID buddy) Nothing
was_sol <- rmjid ConfigFiles.modifySolicited user buddy
when was_sol $ do -- if buddy ∈ solicited:
addJid ConfigFiles.modifyBuddies user buddy -- add buddies
rmjid ConfigFiles.modifyOthers user buddy -- remove others
mbuddy <- asHostNameJID buddy
withJust mbuddy $ \buddy -> do
rosterPush (NewBuddy user buddy) (peer_global session)
processRejection session user buddy = do
solicited <- ConfigFiles.getSolicited user
let rmjid modify user buddy = modify user (cmpJID buddy) Nothing
was_sol <- rmjid ConfigFiles.modifySolicited user buddy
when was_sol $ do -- if buddy ∈ solicited:
rmjid ConfigFiles.modifyBuddies user buddy -- remove buddies
addJid ConfigFiles.modifyOthers user buddy -- add others
mbuddy <- asHostNameJID buddy
withJust mbuddy $ \buddy -> do
rosterPush (RemovedBuddy user buddy) (peer_global session)
processRequest session user buddy = do
let addjid modify user buddy = do
hbuddy <- asHostNameJID buddy
modify user (cmpJID buddy) hbuddy
was_pending <- addjid ConfigFiles.modifyPending user buddy
putStrLn $ "processRequest was_pending="<++>bshow was_pending
-- "all available resources in accordence with section 8"
-- Section 8 says (for presence of type "subscribe", the server MUST
-- adhere to the rules defined under Section 3 and summarized under
-- Appendix A.
-- Appendex A.3.1 says
-- contact ∈ subscribers --> SHOULD NOT, already handled
-- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT
-- contact ∉ subscribers & contact ∉ pending --> MUST
when (not was_pending) $ do
mbuddy <- asHostNameJID buddy
withJust mbuddy $ \buddy -> do
rosterPush (PendingSubscriber user buddy) (peer_global session)
data RefCountedChan = forall a. RefCountedChan (TMVar (RefCount,TChan a))
subscribeToChan :: TMVar (RefCount, TChan a) -> STM (TChan a)
subscribeToChan tmvar =
(do (cnt,chan) <- takeTMVar tmvar
putTMVar tmvar (cnt+1,chan)
chan' <- dupTChan chan
return chan' )
`orElse`
(do chan <- newTChan
putTMVar tmvar (1,chan)
return chan )
unsubscribeToChan :: TMVar (RefCount,TChan a) -> STM ()
unsubscribeToChan tmvar = do
isEmpty <- isEmptyTMVar tmvar
when (not isEmpty) $ do
(cnt,chan) <- takeTMVar tmvar
when (cnt>1) (putTMVar tmvar (cnt-1,chan))
getRefFromMap tvar key newObject copyObject = do
subs <- readTVar tvar
let mbobject = Map.lookup key subs
(object,subs') <-
do case mbobject of
Nothing -> do
newobject <- newObject
return (newobject, Map.insert key (1,newobject) subs)
Just (cnt,object) -> do
object' <- copyObject object
return (object', Map.insert key (cnt+1,object) subs)
writeTVar tvar subs'
return object
unrefFromMap tvar key finalizer = do
vanished <- atomically $ do
omap <- readTVar tvar
let (r,omap') = Map.updateLookupWithKey unref key omap
writeTVar tvar omap'
return (isNothing r)
when vanished finalizer
where
unref key (cnt,object) =
if cnt==1 then Nothing
else Just (cnt-1,object)
subscribeToMap tvar jid =
getRefFromMap tvar jid newTChan dupTChan
matchResource tty jid = maybe Away (avail . (==tty)) $ resource jid
where
avail True = Available
avail False = Away
matchResource' tty (_,rsc,_) = avail (rsc==tty)
where
avail True = Available
avail False = Away
sendPresence chan jid status =
(liftIO . atomically . writeTChan chan . Presence jid $ status) :: MaybeT IO ()
lookupT jid subscribers = MaybeT . return $ Map.lookup jid subscribers
update_presence locals_greedy subscribers state getStatus =
forM_ state $ \jid -> do
let status = getStatus jid
runMaybeT $ do
chan <- lookupT jid subscribers
sendPresence chan jid status
runMaybeT $ do
chan <- MaybeT . return $ locals_greedy
sendPresence chan jid status
putStrLn $ bshow jid <++> " " <++> bshow status
newPresenceState hostname = atomically $ do
tty <- newTVar ""
us <- newTVar (Set.empty)
subs <- newTVar (Map.empty)
locals_greedy <- newEmptyTMVar
rchan <- newEmptyTMVar
remotes <- newTVar (Map.empty)
server_connections <- newServerConnections
return $ PresenceState hostname tty us subs locals_greedy rchan remotes server_connections
sendProbes state jid = do
L.putStrLn $ "sending probes for " <++> bshow jid
withJust (name jid) $ \user -> do
let parseHostNameJID' str = do
handle (\(SomeException _) -> return Nothing)
(fmap Just . parseHostNameJID $ str)
buddies <- do
buddies <- ConfigFiles.getBuddies user
fmap catMaybes (mapM parseHostNameJID' buddies)
L.putStrLn $ "buddies for " <++> bshow jid <++> " = " <++> bshow buddies
wanted <- do
wanted <- ConfigFiles.getSolicited user
fmap catMaybes (mapM parseHostNameJID' wanted)
remotes <- readTVarIO (remoteUsers state)
forM_ (map (True,) buddies ++ map (False,) wanted) $ \(got,buddy) -> do
let mjids = fmap snd $ Map.lookup (peer buddy) remotes
jids <- maybe (return MM.empty) readTVarIO mjids
withJust (splitResource buddy) $ \(buddyU,_) -> do
let noinfo = not (MM.member buddyU jids)
when noinfo $ do
let msg = if got then PresenceProbe jid buddy else Solicitation jid buddy
L.putStrLn $ "sendMessage " <++> bshow msg
sendMessage (outGoingConnections state) msg (peer buddy)
track_login host state e = do
#ifndef NOUTMP
us <- UTmp.users
#else
let us = []
#endif
let toJabberId host (user,tty,pid) =
if L.take 3 tty == "tty"
then Just (user,tty,pid) -- (jid user host tty)
else Nothing
new_users = Set.fromList $ mapMaybe (toJabberId host) us
(tty,known_users,subs,locals_greedy) <- atomically $ do
tty <- readTVar $ currentTTY state
st <- flip swapTVar new_users $ activeUsers state
xs <- readTVar $ subscriberMap state
locals_greedy <- tryReadTMVar $ localSubscriber state
return (tty,st,fmap snd xs,fmap snd locals_greedy)
let arrivals = map tupleToJID . Set.toList $ new_users \\ known_users
departures = map tupleToJID . Set.toList $ known_users \\ new_users
update_presence locals_greedy subs departures $ const Offline
update_presence locals_greedy subs arrivals $ matchResource tty
forM_ arrivals
$ sendProbes state
on_chvt state vtnum = do
let tty = L.snoc "tty" $ intToDigit (fromIntegral vtnum)
L.putStrLn $ "VT switch: " <++> tty
(users,subs,locals_greedy) <- atomically $ do
us <- readTVar $ activeUsers state
subs <- readTVar $ subscriberMap state
writeTVar (currentTTY state) tty
locals_greedy <- tryReadTMVar $ localSubscriber state
return (us,fmap snd subs,fmap snd locals_greedy)
update_presence locals_greedy
subs
(map tupleToJID . Set.toList $ users)
$ matchResource tty
start :: Network.Socket.Family -> IO ()
start ip4or6 = do
let host = LocalHost
global_state <- newPresenceState host
let dologin e = track_login host global_state e
dologin :: t -> IO ()
chan <- atomically $ subscribeToChan (localSubscriber global_state)
remotes <- forkIO $ seekRemotePeers (PeerSessions global_state) chan (outGoingConnections global_state)
installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing
-- installHandler sigTERM (CatchOnce (dologin (userError "term signaled"))) Nothing
mtty <- monitorTTY (on_chvt global_state)
inotify <- initINotify
#ifndef NOUTMP
wd <- addWatch
inotify
[CloseWrite] -- [Open,Close,Access,Modify,Move]
utmp_file
dologin
#endif
clients <- listenForXmppClients ip4or6 (ClientSessions global_state) 5222 HNil
peers <- listenForRemotePeers ip4or6 (PeerSessions global_state) 5269 HNil
threadDelay 1000 -- wait a moment to obtain current tty
dologin ()
putStrLn "\nHit enter to terminate...\n"
getLine
killThread remotes
quitListening clients
quitListening peers
-- threadDelay 1000
putStrLn "closed listener."
unmonitorTTY mtty
putStrLn "unhooked tty monitor."
#ifndef NOUTMP
removeWatch wd
#endif
putStrLn "Normal termination."
sendUSR1 pid = do
signalProcess sigUSR1 pid
getStartupAction [] = throw (userError "pid file?") >> return (Right "")
getStartupAction (p:ps) = do
handle onEr $
( do
pid <- fmap CPid (readFile p >>= readIO)
-- signal pid
return (Left pid) )
where
onEr (SomeException _) = do
pid <- getProcessID
putStrLn $ "starting pid = " <++> bshow pid
handle (\(SomeException _) -> getStartupAction ps)
(do
writeFile p (show pid)
putStrLn $ "writing " <++> bshow p
-- start daemon
return (Right p) )
runOnce ps run notify = getStartupAction ps >>= doit
where
doit (Left pid ) = notify pid
doit (Right pidfile ) = do
run
removeFile pidfile
getOptions [] = Map.empty
getOptions (('-':opt_name):xs) =
if xs/=[] && xs!!0!!0/='-'
then Map.insert (L.pack opt_name) (L.pack (xs!!0)) (getOptions (tail xs))
else Map.insert (L.pack opt_name) "" (getOptions xs)
getOptions (x0:xs) = getOptions xs
main = do
opts <- fmap getOptions getArgs
let use_ip4 = if isJust (Map.lookup "4" opts) then AF_INET else AF_INET6
runOnce ["/var/run/presence.pid","/tmp/presence.pid"] (start use_ip4) sendUSR1
|