From 50b21c21ee92a5dbc220022772c74b288e327e5d Mon Sep 17 00:00:00 2001
From: Julien Dessaux
Date: Wed, 21 Apr 2010 22:58:34 +0200
Subject: Make the main thread exit cleanly in case of connection loss.

---
 Hsbot/Core.hs | 29 ++++++++++++++++++++++-------
 Hsbot/Main.hs |  1 +
 2 files changed, 23 insertions(+), 7 deletions(-)

(limited to 'Hsbot')

diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs
index e3ce3eb..2195525 100644
--- a/Hsbot/Core.hs
+++ b/Hsbot/Core.hs
@@ -5,10 +5,12 @@ module Hsbot.Core
 
 import Control.Concurrent
 import Control.Concurrent.Chan()
+import Control.Exception
 import Control.Monad.State
 import Data.List()
 import qualified Data.Map as M
 import Network
+import Prelude hiding (catch)
 import System.IO
 import System.Time (getClockTime)
 
@@ -26,9 +28,10 @@ connectServer server = do
     handle <- connectTo name $ serverPort server
     hSetBuffering handle NoBuffering
     putStrLn "done."
-    putStr $ "Opening server communication channel... "
+    putStr "Opening server communication channel... "
     chan <- newChan :: IO (Chan BotMsg)
-    threadId <- forkIO $ botReader handle chan
+    myFatherThreadId <- myThreadId
+    threadId <- forkIO $ botReader handle chan myFatherThreadId
     putStrLn "done."
     return $ Bot server starttime handle [] M.empty chan threadId M.empty
 
@@ -36,16 +39,21 @@ connectServer server = do
 disconnectServer :: IrcBot ()
 disconnectServer = do
     bot <- get
+    let name = serverAddress $ serverConfig bot
+    liftIO $ putStr "Shutting down plugins..."
     mapM_ unloadPlugin (M.keys $ botPlugins bot)
+    liftIO $ putStrLn"done."
+    liftIO $ putStr "Closing server communication channel... "
     liftIO $ killThread $ readerThreadId bot
+    liftIO $ putStrLn "done."
+    liftIO $ putStr $ "Disconnecting from " ++ name ++ "... "
     liftIO $ hClose $ botHandle bot
-    return ()
+    liftIO $ putStrLn "done."
 
 -- | Socket reading loop
-botReader :: Handle -> Chan BotMsg -> IO ()
-botReader handle chan = forever $ do
-    -- TODO : detect end of connection!
-    str <- hGetLine handle
+botReader :: Handle -> Chan BotMsg -> ThreadId -> IO ()
+botReader handle chan fatherThreadId = forever $ do
+    str <- (hGetLine handle) `catch` handleIOException
     let msg = parseIrcMsg str
     case msg of
         Right msg' -> do
@@ -53,4 +61,11 @@ botReader handle chan = forever $ do
             writeChan chan (InputMsg msg')
         _ -> do
             return ()
+  where
+    handleIOException :: IOException -> IO (String)
+    handleIOException ioException = do
+        throwTo fatherThreadId ioException
+        myId <- myThreadId
+        killThread myId
+        return ""
 
diff --git a/Hsbot/Main.hs b/Hsbot/Main.hs
index 82b643f..767722b 100644
--- a/Hsbot/Main.hs
+++ b/Hsbot/Main.hs
@@ -28,6 +28,7 @@ imain = do
 run :: IrcBot ()
 run = do
     initServer
+    liftIO $ putStrLn "Starting plugins..."
     loadPlugin "Ping" mainPing
     loadPlugin "Core" mainCore
     loadPlugin "Quote" mainQuote
-- 
cgit v1.2.3