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
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
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 System.INotify
#ifndef NOUTMP
import UTmp
-- Breaks profiling build with error:
-- 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.
--
-- TODO: Figure out wtf ghc is trying to tell me.
-- In the mean time, use -DNOTMP to build for profiling.
--
#endif
import FGConsole
import XMPPServer
import Data.HList
import Network.Socket (sClose)
import Control.Exception
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.MVar -- .Strict
import Control.Concurrent (threadDelay)
import Control.Concurrent.Chan
import Control.DeepSeq
import Control.Monad.Trans.Maybe
-- import Control.Monad.Trans.Class
import Control.Monad.IO.Class
-- import Debug.Trace
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)
-- | Jabber ID (JID) datatype
data JID = JID { name :: Maybe ByteString
, server :: ByteString
, resource :: Maybe ByteString
}
deriving (Ord,Eq)
instance Show JID where
show (JID n s r ) = L.unpack $ fmap (<++>"@") n <?++> s <++?> fmap ("/"<++>) r
instance NFData JID where
rnf v@(JID n s r) = n `seq` s `seq` r `seq` ()
jid user host rsrc = JID (Just user) host (Just rsrc)
data UnixSession = UnixSession {
unix_uid :: (IORef (Maybe UserID)),
unix_resource :: (IORef (Maybe L.ByteString))
}
instance XMPPSession UnixSession where
data XMPPClass UnixSession = UnixSessions
newSession _ sock handle = do
muid <- getLocalPeerCred sock
L.putStrLn $ "SESSION: open " <++> bshow muid
uid_ref <- newIORef muid
res_ref <- newIORef Nothing
return $ UnixSession uid_ref res_ref
setResource s resource = do
writeIORef (unix_resource s) (Just resource)
L.putStrLn $ "SESSION: resource " <++> resource
getJID s = do
let host = "localhost" -- TODO
muid <- readIORef (unix_uid s)
user <- 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
rsc <- readIORef (unix_resource s)
let suf = maybe "" ("/"<++>) rsc
jid = user <++> "@" <++> L.pack host <++> suf
L.putStrLn $ "SESSION: jid " <++> jid
return jid
closeSession _ = L.putStrLn "SESSION: close"
data JabberShow = Offline
| Away
| Available
deriving (Show,Enum,Ord,Eq,Read)
data Presence = Presence JID JabberShow
type MaybePresence = Maybe Presence
instance NFData Presence where
rnf (Presence jid stat) = rnf jid `seq` stat `seq` ()
matchResource tty jid = maybe Away (avail . (==tty)) $ resource jid
where
avail True = Available
avail False = Away
sendPresence chan jid status =
(liftIO . writeChan chan . Just . Presence jid $ status) :: MaybeT IO ()
lookupT jid subscribers = MaybeT . return $ Map.lookup jid subscribers
update_presence subscribers state getStatus =
forM_ (Set.toList state) $ \jid -> do
let status = getStatus jid
runMaybeT $ do
chan <- lookupT jid subscribers
sendPresence chan jid status
putStrLn $ bshow jid <++> " " <++> bshow status
track_login :: MVar (ByteString,Set JID,Map JID (Chan MaybePresence)) -> t -> IO ()
track_login mvar e = do
#ifndef NOUTMP
us <- UTmp.users
#else
let us = []
#endif
let toJabberId host (user,tty,_) =
if L.take 3 tty == "tty"
then Just (jid user host tty)
else Nothing
jids = Set.fromList $ mapMaybe (toJabberId "localhost") us
(tty,users,subscribers)
<- modifyMVar mvar $ \(tty,st,xs) ->
return ((tty,jids,xs),(tty,st,xs))
let arrivals = jids \\ users
departures = users \\ jids
update_presence subscribers departures $ const Offline
update_presence subscribers arrivals $ matchResource tty
on_chvt mvar vtnum = do
let tty = L.snoc "tty" $ intToDigit (fromIntegral vtnum)
L.putStrLn $ "VT switch: " <++> tty
(users,subscribers) <- modifyMVar mvar $ \(_,us,xs) -> do
return ((tty,us,xs),(us,xs))
update_presence subscribers users $ matchResource tty
start :: IO ()
start = do
tracked <- newMVar ("",Set.empty,Map.empty)
let dologin e = track_login tracked e
dologin :: t -> IO ()
installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing
-- installHandler sigTERM (CatchOnce (dologin (userError "term signaled"))) Nothing
mtty <- monitorTTY (on_chvt tracked)
inotify <- initINotify
#ifndef NOUTMP
wd <- addWatch
inotify
[CloseWrite] -- [Open,Close,Access,Modify,Move]
utmp_file
dologin
#endif
sock <- listenForXmppClients UnixSessions 5222 HNil
threadDelay 1000 -- wait a moment to obtain current tty
dologin ()
putStrLn "\nHit enter to terminate...\n"
getLine
sClose sock
-- 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
main = do
runOnce ["/var/run/presence.pid","/tmp/presence.pid"] start sendUSR1
|
