summaryrefslogtreecommitdiff
path: root/Presence/main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Presence/main.hs')
-rw-r--r--Presence/main.hs45
1 files changed, 30 insertions, 15 deletions
diff --git a/Presence/main.hs b/Presence/main.hs
index 211d7df9..86503a62 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -45,9 +45,11 @@ import qualified Data.ByteString.Lazy.Char8 as L
45import Data.ByteString.Lazy.Char8 as L (ByteString,putStrLn) 45import Data.ByteString.Lazy.Char8 as L (ByteString,putStrLn)
46import qualified Prelude 46import qualified Prelude
47import Prelude hiding (putStrLn) 47import Prelude hiding (putStrLn)
48import System.Environment
48 49
49 50
50data UnixSession = UnixSession { 51data UnixSession = UnixSession {
52 localhost :: ByteString,
51 unix_uid :: (IORef (Maybe UserID)), 53 unix_uid :: (IORef (Maybe UserID)),
52 unix_resource :: (IORef (Maybe L.ByteString)), 54 unix_resource :: (IORef (Maybe L.ByteString)),
53 presence_state :: PresenceState 55 presence_state :: PresenceState
@@ -60,12 +62,12 @@ instance XMPPSession UnixSession where
60 L.putStrLn $ "SESSION: open " <++> bshow muid 62 L.putStrLn $ "SESSION: open " <++> bshow muid
61 uid_ref <- newIORef muid 63 uid_ref <- newIORef muid
62 res_ref <- newIORef Nothing 64 res_ref <- newIORef Nothing
63 return $ UnixSession uid_ref res_ref state 65 return $ UnixSession (hostname state) uid_ref res_ref state
64 setResource s resource = do 66 setResource s resource = do
65 writeIORef (unix_resource s) (Just resource) 67 writeIORef (unix_resource s) (Just resource)
66 L.putStrLn $ "SESSION: resource " <++> resource 68 L.putStrLn $ "SESSION: resource " <++> resource
67 getJID s = do 69 getJID s = do
68 let host = "localhost" -- TODO 70 let host = localhost s
69 muid <- readIORef (unix_uid s) 71 muid <- readIORef (unix_uid s)
70 user <- maybe (return "nobody") 72 user <- maybe (return "nobody")
71 (\uid -> 73 (\uid ->
@@ -78,7 +80,7 @@ instance XMPPSession UnixSession where
78 muid 80 muid
79 rsc <- readIORef (unix_resource s) 81 rsc <- readIORef (unix_resource s)
80 let suf = maybe "" ("/"<++>) rsc 82 let suf = maybe "" ("/"<++>) rsc
81 jid = user <++> "@" <++> L.pack host <++> suf 83 jid = user <++> "@" <++> host <++> suf
82 L.putStrLn $ "SESSION: jid " <++> jid 84 L.putStrLn $ "SESSION: jid " <++> jid
83 return jid 85 return jid
84 closeSession _ = L.putStrLn "SESSION: close" 86 closeSession _ = L.putStrLn "SESSION: close"
@@ -134,20 +136,21 @@ update_presence greedy subscribers state getStatus =
134type RefCount = Int 136type RefCount = Int
135 137
136data PresenceState = PresenceState 138data PresenceState = PresenceState
137 { currentTTY :: TVar ByteString 139 { hostname :: ByteString
140 , currentTTY :: TVar ByteString
138 , activeUsers :: TVar (Set JID) 141 , activeUsers :: TVar (Set JID)
139 , subscriberMap :: TVar (Map JID (RefCount,TChan Presence)) 142 , subscriberMap :: TVar (Map JID (RefCount,TChan Presence))
140 , greedySubscriber :: TMVar (RefCount,TChan Presence) 143 , greedySubscriber :: TMVar (RefCount,TChan Presence)
141 } 144 }
142 145
143newPresenceState = atomically $ do 146newPresenceState hostname = atomically $ do
144 tty <- newTVar "" 147 tty <- newTVar ""
145 us <- newTVar (Set.empty) 148 us <- newTVar (Set.empty)
146 subs <- newTVar (Map.empty) 149 subs <- newTVar (Map.empty)
147 greedy <- newEmptyTMVar 150 greedy <- newEmptyTMVar
148 return $ PresenceState tty us subs greedy 151 return $ PresenceState hostname tty us subs greedy
149 152
150track_login state e = do 153track_login host state e = do
151#ifndef NOUTMP 154#ifndef NOUTMP
152 us <- UTmp.users 155 us <- UTmp.users
153#else 156#else
@@ -157,7 +160,7 @@ track_login state e = do
157 if L.take 3 tty == "tty" 160 if L.take 3 tty == "tty"
158 then Just (jid user host tty) 161 then Just (jid user host tty)
159 else Nothing 162 else Nothing
160 new_users = Set.fromList $ mapMaybe (toJabberId "localhost") us 163 new_users = Set.fromList $ mapMaybe (toJabberId host) us
161 (tty,known_users,subs,greedy) <- atomically $ do 164 (tty,known_users,subs,greedy) <- atomically $ do
162 tty <- readTVar $ currentTTY state 165 tty <- readTVar $ currentTTY state
163 st <- flip swapTVar new_users $ activeUsers state 166 st <- flip swapTVar new_users $ activeUsers state
@@ -181,10 +184,10 @@ on_chvt state vtnum = do
181 update_presence greedy subs users $ matchResource tty 184 update_presence greedy subs users $ matchResource tty
182 185
183 186
184start :: IO () 187start :: ByteString -> IO ()
185start = do 188start host = do
186 tracked <- newPresenceState 189 tracked <- newPresenceState host
187 let dologin e = track_login tracked e 190 let dologin e = track_login host tracked e
188 dologin :: t -> IO () 191 dologin :: t -> IO ()
189 installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing 192 installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing
190 -- installHandler sigTERM (CatchOnce (dologin (userError "term signaled"))) Nothing 193 -- installHandler sigTERM (CatchOnce (dologin (userError "term signaled"))) Nothing
@@ -197,14 +200,14 @@ start = do
197 utmp_file 200 utmp_file
198 dologin 201 dologin
199#endif 202#endif
200 sock <- listenForXmppClients (UnixSessions tracked) 5222 HNil 203 sockLocals <- listenForXmppClients (UnixSessions tracked) 5222 HNil
201 sockRemotes <- listenForRemotePeers (UnixSessions tracked) 5269 HNil 204 sockRemotes <- listenForRemotePeers (UnixSessions tracked) 5269 HNil
202 205
203 threadDelay 1000 -- wait a moment to obtain current tty 206 threadDelay 1000 -- wait a moment to obtain current tty
204 dologin () 207 dologin ()
205 putStrLn "\nHit enter to terminate...\n" 208 putStrLn "\nHit enter to terminate...\n"
206 getLine 209 getLine
207 sClose sock 210 sClose sockLocals
208 sClose sockRemotes 211 sClose sockRemotes
209 -- threadDelay 1000 212 -- threadDelay 1000
210 putStrLn "closed listener." 213 putStrLn "closed listener."
@@ -243,8 +246,20 @@ runOnce ps run notify = getStartupAction ps >>= doit
243 run 246 run
244 removeFile pidfile 247 removeFile pidfile
245 248
249getOptions [] = Map.empty
250
251getOptions (('-':opt_name):xs) =
252 if xs/=[] && xs!!0!!0/='-'
253 then Map.insert (L.pack opt_name) (L.pack (xs!!0)) (getOptions (tail xs))
254 else Map.insert (L.pack opt_name) "" (getOptions xs)
255
256getOptions (x0:xs) = getOptions xs
257
246 258
247main = do 259main = do
248 runOnce ["/var/run/presence.pid","/tmp/presence.pid"] start sendUSR1 260 opts <- fmap getOptions getArgs
261 let hostname = maybe "localhost" id (Map.lookup "n" opts)
262 L.putStrLn $ "hostname = " <++> hostname
263 runOnce ["/var/run/presence.pid","/tmp/presence.pid"] (start hostname) sendUSR1
249 264
250 265