blob: d679fdba2ee9059eedb7d91937dda4d898da5c99 (
plain)
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
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
import System.Directory
import Control.Monad
import System.Posix.Signals
import System.Posix.Types
import System.Posix.Process
import Data.Maybe
import System.INotify
#ifndef NOUTMP
import UTmp
#endif
import FGConsole
import XMPPServer
import Data.HList
import Network.Socket (sClose)
import Control.Exception
import LocalPeerCred
import ByteStringOperators
import qualified Data.ByteString.Lazy.Char8 as L
import System.Posix.User
jid user host rsrc = user ++ "@" ++ host ++ "/" ++ rsrc
toJabberId :: String -> (String,String,t) -> Maybe String
toJabberId host (user,tty,_) =
if take 3 tty == "tty"
then Just (jid user host tty)
else Nothing
#ifndef NOUTMP
utmp_event e = do
-- print e
putStrLn "---"
us <- users
let ids = mapMaybe (toJabberId "localhost") us
ids :: [String]
forM_ ids putStrLn
#endif
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
putStrLn $ "SESSION: open " ++ show 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 _ = putStrLn "SESSION: close"
on_chvt vtnum = do
putStrLn $ "changed vt to "++ show vtnum
start :: IO ()
start = do
#ifndef NOUTMP
installHandler sigUSR1 (Catch (utmp_event (userError "signaled"))) Nothing
#endif
-- installHandler sigTERM (CatchOnce (utmp_event (userError "term signaled"))) Nothing
inotify <- initINotify
print inotify
#ifndef NOUTMP
wd <- addWatch
inotify
[CloseWrite] -- [Open,Close,Access,Modify,Move]
utmp_file
utmp_event
print wd
#endif
mtty <- monitorTTY on_chvt
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 = "++show pid
handle (\(SomeException _) -> getStartupAction ps)
(do
writeFile p (show pid)
putStrLn $ "writing "++show 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
|
