graceful quit from accept loop

2 files changed, 42 insertions, 4 deletions

diff --git a/Presence/Server.hs b/Presence/Server.hs
index 5dce323c..feefea2b 100644
--- a/Presence/Server.hs
+++ b/Presence/Server.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Server where
 
 import Network.Socket
@@ -73,10 +74,21 @@ doServer port g startCon = runServer2 port (runConn2 g)
         setSocketOption sock ReuseAddr 1
         bindSocket sock (SockAddrInet port iNADDR_ANY)
         listen sock 2
-        mainLoop sock (ConnId 0) go
+        forkIO $ do
+            mainLoop sock (ConnId 0) go
+            L.putStrLn $ "quit accept loop"
+        return sock
      where
         mainLoop sock idnum@(ConnId n) go = do
-            con <- accept sock
-            forkIO $ go (idnum .*. st) con 
-            mainLoop sock (ConnId (n+1)) go
+            let doException (SomeException e) = do
+                Prelude.putStrLn ("\n\naccept-loop exception: " ++ show e ++ "\n\n")
+                return Nothing
+            mcon <- handle doException $ fix $ \loop -> do
+                con <- accept sock
+                return $ Just con
+            case mcon of
+              Just con -> do
+                forkIO $ go (idnum .*. st) con 
+                mainLoop sock (ConnId (n+1)) go
+              Nothing -> return ()
 
diff --git a/Presence/main.hs b/Presence/main.hs
index 1eb0c0ed..b0f73a9e 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 
 import System.Directory
 import System.IO
@@ -10,9 +11,15 @@ 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.Concurrent (threadDelay)
+import Control.Exception (handle,SomeException(..))
 
 jid user host rsrc = user ++ "@" ++ host ++ "/" ++ rsrc
 
@@ -22,6 +29,7 @@ toJabberId host (user,tty,_) =
       then Just (jid user host tty)
       else Nothing
 
+#ifndef NOUTMP
 utmp_event e = do
     -- print e
     putStrLn "---"
@@ -29,26 +37,44 @@ utmp_event e = do
     let ids = mapMaybe (toJabberId "localhost") us
         ids :: [String]
     forM_ ids putStrLn
+#endif
 
 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 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