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
|
{-# 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 Control.Concurrent.MVar.Strict
import Control.DeepSeq
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
-- ^ Account name
, server :: ByteString
-- ^ Server adress
, resource :: Maybe ByteString
-- ^ Resource name
}
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) -- user <++> "@" <++> host <++> "/" <++> rsrc
toJabberId host (user,tty,_) =
if L.take 3 tty == "tty"
then Just (jid user host tty)
else Nothing
track_login :: MVar (Set JID) -> t -> IO ()
track_login tracked e = do
#ifndef NOUTMP
us <- users
#else
let us = []
#endif
let ids = Set.fromList $ mapMaybe (toJabberId "localhost") us
state <- swapMVar tracked ids
let arrivals = ids \\ state
departures = state \\ ids
forM_ (Set.toList departures) $ \id -> do
putStrLn $ bshow id <++> " Offline."
forM_ (Set.toList arrivals) $ \id -> do
putStrLn $ bshow id <++> " Available."
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"
on_chvt tracked vtnum = do
let tty = L.snoc "tty" $ intToDigit (fromIntegral vtnum)
L.putStrLn $ "changed vt to " <++> tty
state <- readMVar tracked
forM_ (Set.toList state) $ \jid -> do
case fmap (==tty) $ resource jid of
Just True -> putStrLn $ bshow jid <++> " Available."
Just False -> putStrLn $ bshow jid <++> " Away."
Nothing -> return ()
start :: IO ()
start = do
tracked <- newMVar Set.empty
let dologin e = track_login tracked e
dologin :: t -> IO ()
dologin ()
#ifndef NOUTMP
installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing
#endif
-- installHandler sigTERM (CatchOnce (dologin (userError "term signaled"))) Nothing
inotify <- initINotify
#ifndef NOUTMP
wd <- addWatch
inotify
[CloseWrite] -- [Open,Close,Access,Modify,Move]
utmp_file
dologin
#endif
mtty <- monitorTTY (on_chvt tracked)
sock <- listenForXmppClients UnixSessions 5222 HNil
putStrLn "Hit enter to terminate..."
getLine
{-
let doException (SomeException e) = Prelude.putStrLn ("\n\nexception: " ++ show e ++ "\n\n")
handle doException $ do
-}
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
|
