blob: dd6bfb2ef5bd12578532d687603f9fb7978eefe8 (
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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
|
{-# 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 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 (Set)
import ByteStringOperators
import qualified Data.ByteString.Lazy.Char8 as L
import Data.ByteString.Lazy.Char8 as L (putStrLn)
import qualified Prelude
import Prelude hiding (putStrLn)
jid user host rsrc = user <++> "@" <++> host <++> "/" <++> rsrc
toJabberId host (user,tty,_) =
if L.take 3 tty == "tty"
then Just (jid user host tty)
else Nothing
track_login :: IORef (Set L.ByteString) -> t -> IO ()
track_login tracked e = do
-- print e
putStrLn "---"
#ifndef NOUTMP
us <- users
#else
let us = []
#endif
let ids = mapMaybe (toJabberId "localhost") us
forM_ ids L.putStrLn
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 vtnum = do
L.putStrLn $ "changed vt to " <++> bshow vtnum
start :: IO ()
start = do
tracked <- newIORef Set.empty
let dologin e = track_login tracked e
dologin :: t -> IO ()
#ifndef NOUTMP
installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing
#endif
-- installHandler sigTERM (CatchOnce (dologin (userError "term signaled"))) Nothing
inotify <- initINotify
print inotify
#ifndef NOUTMP
wd <- addWatch
inotify
[CloseWrite] -- [Open,Close,Access,Modify,Move]
utmp_file
dologin
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 = " <++> 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
|
