started project

1 files changed, 85 insertions, 0 deletions

diff --git a/Presence/main.hs b/Presence/main.hs
new file mode 100644
index 00000000..99f58ee4
--- /dev/null
+++ b/Presence/main.hs
@@ -0,0 +1,85 @@
+
+import System.Directory
+import System.IO
+import Control.Monad
+import System.Posix.Signals
+import System.Posix.Types
+import Control.Monad.Error.Class
+import Control.Exception (throw)
+import System.Posix.Process
+import Data.Maybe
+
+import System.INotify
+import UTmp
+import FGConsole
+
+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
+
+utmp_event e = do
+    -- print e
+    putStrLn "---"
+    us <- users
+    let ids = mapMaybe (toJabberId "localhost") us
+        ids :: [String]
+    forM_ ids putStrLn
+
+on_chvt vtnum = do
+    putStrLn $ "changed vt to "++ show vtnum
+
+start :: IO ()
+start = do
+    installHandler sigUSR1 (Catch (utmp_event (userError "signaled"))) Nothing
+    inotify <- initINotify
+    print inotify
+    wd <- addWatch
+            inotify
+            [CloseWrite] -- [Open,Close,Access,Modify,Move]
+            utmp_file
+            utmp_event
+    print wd
+    mtty <- monitorTTY on_chvt
+    putStrLn "Hit enter to terminate..."
+    getLine
+    unmonitorTTY mtty
+    removeWatch wd
+
+sendUSR1 pid = do
+    signalProcess sigUSR1 pid
+
+getStartupAction []     = throw (userError "pid file?") >> return (Right "")
+getStartupAction (p:ps) = do
+    catch
+        ( do
+            pid <- fmap CPid (readFile p >>= readIO)
+            -- signal pid
+            return (Left pid) )
+        onEr
+ where
+    onEr e = do
+        pid <- getProcessID
+        putStrLn $ "starting pid = "++show pid
+        catch (do 
+                writeFile p (show pid)
+                putStrLn $ "writing "++show p
+                -- start daemon
+                return (Right p) )
+              (\_ -> getStartupAction ps)
+
+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
+
+