diff options
Diffstat (limited to 'Presence/main.hs')
-rw-r--r-- | Presence/main.hs | 45 |
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 | |||
45 | import Data.ByteString.Lazy.Char8 as L (ByteString,putStrLn) | 45 | import Data.ByteString.Lazy.Char8 as L (ByteString,putStrLn) |
46 | import qualified Prelude | 46 | import qualified Prelude |
47 | import Prelude hiding (putStrLn) | 47 | import Prelude hiding (putStrLn) |
48 | import System.Environment | ||
48 | 49 | ||
49 | 50 | ||
50 | data UnixSession = UnixSession { | 51 | data 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 = | |||
134 | type RefCount = Int | 136 | type RefCount = Int |
135 | 137 | ||
136 | data PresenceState = PresenceState | 138 | data 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 | ||
143 | newPresenceState = atomically $ do | 146 | newPresenceState 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 | ||
150 | track_login state e = do | 153 | track_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 | ||
184 | start :: IO () | 187 | start :: ByteString -> IO () |
185 | start = do | 188 | start 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 | ||
249 | getOptions [] = Map.empty | ||
250 | |||
251 | getOptions (('-':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 | |||
256 | getOptions (x0:xs) = getOptions xs | ||
257 | |||
246 | 258 | ||
247 | main = do | 259 | main = 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 | ||