summaryrefslogtreecommitdiff
path: root/Presence/main.hs
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2013-06-17 16:19:15 -0400
committerjoe <joe@jerkface.net>2013-06-17 16:19:15 -0400
commit7adaccbf993c602f09b2b9e7dea0360ac0dce93e (patch)
tree6c4b3aaa4c551ae8d8b897725d0cb5791836878c /Presence/main.hs
parent5982df9112b7e5fe7bcab62434771f1ca979e14d (diff)
Switched UTmp.users to return ByteStrings instead of Strings.
Diffstat (limited to 'Presence/main.hs')
-rw-r--r--Presence/main.hs39
1 files changed, 27 insertions, 12 deletions
diff --git a/Presence/main.hs b/Presence/main.hs
index d679fdba..f0bc39f5 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -1,6 +1,7 @@
1{-# LANGUAGE CPP #-} 1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-} 2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE TypeFamilies #-} 3{-# LANGUAGE TypeFamilies #-}
4module Main where
4 5
5import System.Directory 6import System.Directory
6import Control.Monad 7import Control.Monad
@@ -11,7 +12,15 @@ import Data.Maybe
11 12
12import System.INotify 13import System.INotify
13#ifndef NOUTMP 14#ifndef NOUTMP
14import UTmp 15import UTmp
16-- Breaks profiling build with error:
17-- Dynamic linking required, but this is a non-standard build (eg. prof).
18-- You need to build the program twice: once the normal way, and then
19-- in the desired way using -osuf to set the object file suffix.
20--
21-- TODO: Figure out wtf ghc is trying to tell me.
22-- In the mean time, use -DNOTMP to build for profiling.
23--
15#endif 24#endif
16import FGConsole 25import FGConsole
17import XMPPServer 26import XMPPServer
@@ -22,25 +31,28 @@ import LocalPeerCred
22import ByteStringOperators 31import ByteStringOperators
23import qualified Data.ByteString.Lazy.Char8 as L 32import qualified Data.ByteString.Lazy.Char8 as L
24import System.Posix.User 33import System.Posix.User
34import qualified Data.Set as Set
35import Data.Set (Set)
25 36
26 37
27jid user host rsrc = user ++ "@" ++ host ++ "/" ++ rsrc 38jid user host rsrc = user <++> "@" <++> host <++> "/" <++> rsrc
28 39
29toJabberId :: String -> (String,String,t) -> Maybe String
30toJabberId host (user,tty,_) = 40toJabberId host (user,tty,_) =
31 if take 3 tty == "tty" 41 if L.take 3 tty == "tty"
32 then Just (jid user host tty) 42 then Just (jid user host tty)
33 else Nothing 43 else Nothing
34 44
35#ifndef NOUTMP 45track_login :: IORef (Set L.ByteString) -> t -> IO ()
36utmp_event e = do 46track_login tracked e = do
37 -- print e 47 -- print e
38 putStrLn "---" 48 putStrLn "---"
49#ifndef NOUTMP
39 us <- users 50 us <- users
40 let ids = mapMaybe (toJabberId "localhost") us 51#else
41 ids :: [String] 52 let us = []
42 forM_ ids putStrLn
43#endif 53#endif
54 let ids = mapMaybe (toJabberId "localhost") us
55 forM_ ids L.putStrLn
44 56
45data UnixSession = UnixSession { 57data UnixSession = UnixSession {
46 unix_uid :: (IORef (Maybe UserID)), 58 unix_uid :: (IORef (Maybe UserID)),
@@ -82,10 +94,13 @@ on_chvt vtnum = do
82 94
83start :: IO () 95start :: IO ()
84start = do 96start = do
97 tracked <- newIORef Set.empty
98 let dologin e = track_login tracked e
99 dologin :: t -> IO ()
85#ifndef NOUTMP 100#ifndef NOUTMP
86 installHandler sigUSR1 (Catch (utmp_event (userError "signaled"))) Nothing 101 installHandler sigUSR1 (Catch (dologin (userError "signaled"))) Nothing
87#endif 102#endif
88 -- installHandler sigTERM (CatchOnce (utmp_event (userError "term signaled"))) Nothing 103 -- installHandler sigTERM (CatchOnce (dologin (userError "term signaled"))) Nothing
89 inotify <- initINotify 104 inotify <- initINotify
90 print inotify 105 print inotify
91#ifndef NOUTMP 106#ifndef NOUTMP
@@ -93,7 +108,7 @@ start = do
93 inotify 108 inotify
94 [CloseWrite] -- [Open,Close,Access,Modify,Move] 109 [CloseWrite] -- [Open,Close,Access,Modify,Move]
95 utmp_file 110 utmp_file
96 utmp_event 111 dologin
97 print wd 112 print wd
98#endif 113#endif
99 mtty <- monitorTTY on_chvt 114 mtty <- monitorTTY on_chvt