started project

6 files changed, 351 insertions, 0 deletions

diff --git a/Presence/ByteStringOperators.hs b/Presence/ByteStringOperators.hs
new file mode 100644
index 00000000..8ecb214b
--- /dev/null
+++ b/Presence/ByteStringOperators.hs
@@ -0,0 +1,18 @@
+module ByteStringOperators where
+
+import qualified Data.ByteString as S (ByteString)
+import Data.ByteString.Lazy.Char8 as L 
+
+(<++>) :: ByteString -> ByteString -> ByteString
+(<++.>) :: ByteString -> S.ByteString -> ByteString
+(<.++>) :: S.ByteString -> ByteString -> ByteString
+(<.++.>) :: S.ByteString -> S.ByteString -> ByteString
+a <++> b =  L.append a b
+a <++.> b = L.append a (fromChunks [b])
+a <.++> b = L.append (fromChunks [a]) b
+a <.++.> b = fromChunks [a,b]
+infixr 5 <.++.>
+infixr 5 <.++>
+infixr 5 <++>
+infixr 5 <++.>
+
diff --git a/Presence/FGConsole.hs b/Presence/FGConsole.hs
new file mode 100644
index 00000000..fc1ece65
--- /dev/null
+++ b/Presence/FGConsole.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module FGConsole where
+
+import Data.Word
+import System.Posix.IO
+import System.Posix.Types
+import Control.Concurrent
+-- import GHC.IO.Handle
+import Unsafe.Coerce
+import Control.Exception as E
+-- import Prelude as E
+import Control.Monad
+import Foreign.C.Error
+import Foreign.C
+
+import Todo
+import Debug.Trace
+import System.Posix.Signals
+
+-- c_monitorTTY fd = trace "c_monitorTTY" (return ()) -- (trace "WTF" todo)
+
+foreign import ccall "monitorTTY" c_monitorTTY :: Fd -> IO ()
+foreign import ccall "closeTTY" c_closeTTY :: IO ()
+
+monitorTTY :: (Word8 -> IO ()) -> IO (Fd,ThreadId)
+monitorTTY handler =  do
+    (rfd,wfd) <- createPipe
+    thread <- forkIO $ do
+        let cleanup = do
+                trace "quitting monitorTTY thread." (return ())
+                closeFd wfd `E.catch` \(e::IOException) -> return ()
+                closeFd rfd `E.catch` \(e::IOException) -> return ()
+                c_closeTTY
+        -- rh <- fdToHandle rfd
+        c_monitorTTY wfd
+        let monitor = 
+                (do
+                    threadWaitRead rfd
+                    (cs,cnt) <- fdRead rfd 1
+                    forM_ cs (handler . unsafeCoerce . trace "read byte")
+                    monitor)
+                `E.catch`
+                      \(e :: IOException) -> do
+                        err <- getErrno
+                        case () of
+                         _ | err==eAGAIN -> monitor
+                         _ | otherwise   -> cleanup
+                `E.catch` 
+                      \(e ::  AsyncException) -> cleanup
+        monitor
+    return (rfd,thread)
+
+unmonitorTTY (rfd,thread) = do
+    closeFd rfd
+    yield
+    killThread thread
+    raiseSignal sigUSR1
+    -- threadDelay 1000000
+
+
+-- vim:ft=haskell:
diff --git a/Presence/Server.hs b/Presence/Server.hs
new file mode 100644
index 00000000..c41f047f
--- /dev/null
+++ b/Presence/Server.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+module Server where
+
+import Network.Socket
+import qualified Data.ByteString as S (ByteString)
+import Data.ByteString.Lazy.Char8 as L 
+    ( ByteString
+    , hPutStrLn
+    , fromChunks
+    , putStrLn )
+import Data.ByteString.Char8 
+    ( hGetNonBlocking
+    )
+import System.IO 
+    ( Handle
+    , IOMode(..)
+    , hSetBuffering
+    , BufferMode(..)
+    , hWaitForInput
+    , hClose
+    , hIsEOF
+    )
+import Control.Monad
+import Control.Monad.Fix (fix)
+import Todo
+import Control.Concurrent (forkIO)
+import Control.Exception (handle,SomeException(..))
+import Data.HList
+import Data.HList.TypeEqGeneric1()
+import Data.HList.TypeCastGeneric1()
+
+
+newtype ConnId = ConnId Int
+  deriving Eq
+
+newtype ConnectionFinalizer = ConnectionFinalizer (IO ())
+
+getPacket h = do { hWaitForInput h (-1) ; fmap (fromChunks . (:[])) $ hGetNonBlocking h 1024 }
+
+{-
+doServer ::
+  HList st 
+  => PortNumber :*: st
+      -> ( Handle :*: ConnId :*: PortNumber :*: st
+            -> S.ByteString 
+            -> (() -> IO ()) 
+            -> IO () )
+      -> IO b
+-}
+doServer port g startCon = runServer2 port (runConn2 g)
+ where
+    runConn2 g st (sock,_) = do
+        h <- socketToHandle sock ReadWriteMode
+        hSetBuffering h NoBuffering
+        st'' <- startCon (h .*. st)
+        handle (\(SomeException _) -> return ()) $ fix $ \loop -> do
+            let continue () = hIsEOF h >>= flip when loop . not
+            packet <- getPacket h
+            g st'' packet continue
+        let ConnectionFinalizer cleanup = hOccursFst st''
+        cleanup
+        hClose h
+
+    {-
+    runServer2 ::
+      Num num =>
+      PortNumber -> (num -> (Socket, SockAddr) -> IO b -> IO b) -> IO b
+    -}
+    runServer2 st@(HCons port _) go = do
+        sock <- socket AF_INET Stream 0
+        setSocketOption sock ReuseAddr 1
+        bindSocket sock (SockAddrInet port iNADDR_ANY)
+        listen sock 2
+        mainLoop sock (ConnId 0) go
+     where
+        mainLoop sock idnum@(ConnId n) go = do
+            con <- accept sock
+            forkIO $ go (idnum .*. st) con 
+            mainLoop sock (ConnId (n+1)) go
+
diff --git a/Presence/Todo.hs b/Presence/Todo.hs
new file mode 100644
index 00000000..7428565e
--- /dev/null
+++ b/Presence/Todo.hs
@@ -0,0 +1,12 @@
+module Todo where
+
+todo = todo -- bottom that means unimplemented function
+
+withType :: v -> v -> v
+withType = const
+
+type Todo = ()
+
+-- Bad idea:  -xc backtrace shows it looking just like the other
+--            bottom defined above.
+-- crash = crash -- bottom used to crash to indicate error
diff --git a/Presence/UTmp.hs b/Presence/UTmp.hs
new file mode 100644
index 00000000..c94dcef2
--- /dev/null
+++ b/Presence/UTmp.hs
@@ -0,0 +1,93 @@
+
+{-# LANGUAGE TemplateHaskell #-}
+module UTmp (users, utmp_file) where
+
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as C
+import Data.BitSyntax
+import Data.Functor.Identity
+import Foreign.C.String
+import Data.Maybe
+import System.Posix.Signals
+import System.Posix.Types
+import Control.Monad
+import Unsafe.Coerce
+import Data.Word
+import Data.Int
+import Control.Monad.Error.Class
+import System.IO.Error
+
+import Todo
+
+utmp_file = "/var/run/utmp"
+
+utmp_bs = S.readFile utmp_file
+
+decode_utmp_bytestring = 
+    runIdentity 
+    . $(bitSyn [ UnsignedLE 4 -- type
+               , UnsignedLE 4 -- pid
+               , Fixed 32 -- tty
+               , Fixed 4 -- inittab id
+               , Fixed 32 -- username
+               , Fixed 256 -- remote host
+               , UnsignedLE 4 -- termination status
+               , UnsignedLE 4 -- exit status
+               , Fixed 4 -- session id
+               , Fixed 8 -- time entry was made
+               , Fixed 16 -- remote addr v6
+               , Skip 20 -- reserved
+               ])
+
+utmp_size = 384 -- 768
+
+
+utmp_records bs | S.length bs >= utmp_size 
+    =  u:utmp_records us
+ where
+    (u,us) = S.splitAt utmp_size bs
+
+utmp_records bs = [bs]
+
+utmp = fmap (map decode_utmp_bytestring . utmp_records) utmp_bs
+
+
+interp_utmp_record (typ,pid,tty,inittab,user,hostv4,term,exit,session,time,hostv6) =
+    (toStr user, toStr tty, processId pid, (toEnum . fromIntegral) typ :: UT_Type)
+ where
+    toStr = takeWhile (/='\0') . C.unpack
+    processId = CPid . coerce
+    coerce :: Word32 -> Int32
+    coerce = unsafeCoerce
+
+
+data UT_Type
+ = EMPTY           -- No valid user accounting information.  */
+
+ | RUN_LVL         -- The system's runlevel.  */
+ | BOOT_TIME       -- Time of system boot.  */
+ | NEW_TIME        -- Time after system clock changed.  */
+ | OLD_TIME        -- Time when system clock changed.  */
+
+ | INIT_PROCESS    -- Process spawned by the init process.  */
+ | LOGIN_PROCESS   -- Session leader of a logged in user.  */
+ | USER_PROCESS    -- Normal process.  */
+ | DEAD_PROCESS    -- Terminated process.  */
+
+ | ACCOUNTING      
+
+ deriving (Enum,Show,Eq,Read)
+
+processAlive pid = do
+    catchError (do { signalProcess nullSignal pid ; return True })
+      $ \e -> do { return (not ( isDoesNotExistError e)); }
+
+users = do
+    us <- utmp
+    let us' = map interp_utmp_record us
+        us'' = mapMaybe user_proc us'
+        user_proc (u,tty,pid,USER_PROCESS) = Just (u,tty,pid)
+        user_proc _                        = Nothing
+        onThrd f (_,_,pid) = f pid
+    us3 <- filterM (onThrd processAlive) us''
+    return us3
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
+
+