Some type refactoring, added config related error handling

Main.hs

@@ -4,9 +4,10 @@ module Main (main) where
 
 import qualified Data.Text as T
 
-import qualified Data.Configurator as C
+import Control.Exception
+import Control.Monad
+import Data.Configurator
 import Data.Configurator.Types
-
 import Data.Maybe
 import System.Environment
 import System.Exit
@@ -23,16 +24,28 @@ main = do
   args <- getArgs
   prog <- getProgName
 
+  when (length args < 1) $ do
+    putStrLn ("Usage: " ++ prog ++ " <config file path>")
+    exitFailure
+
   let configFile = head args
-  cfg <- C.load [C.Required configFile]
-
-  server   <- C.require cfg "server"
-  port     <- C.require cfg "port"
-  channel  <- C.require cfg "channel"
-  botNick  <- C.require cfg "nick"
-  timeout  <- C.require cfg "timeout"
-  handlers <- C.require cfg "handlers"
-
-  if length args < 1
-    then putStrLn ("Usage: " ++ prog ++ " <config file path>") >> exitFailure
-    else run $ BotConfig server port channel botNick timeout handlers cfg
+  loadBotConfig configFile >>= run
+
+loadBotConfig :: FilePath -> IO BotConfig
+loadBotConfig configFile = do
+  eCfg <- try $ load [Required configFile]
+  case eCfg of
+    Left (ParseError _ _) -> error "Error while loading config"
+    Right cfg             -> do
+      eBotConfig <- try $ do
+        server   <- require cfg "server"
+        port     <- require cfg "port"
+        channel  <- require cfg "channel"
+        botNick  <- require cfg "nick"
+        timeout  <- require cfg "timeout"
+        handlers <- require cfg "handlers"
+        return $ BotConfig server port channel botNick timeout handlers cfg
+
+      case eBotConfig of
+        Left (KeyError k) -> error $ "Error while reading key from config: " ++ T.unpack k
+        Right botConfig   -> return botConfig

Network/IRC/Client.hs

@@ -6,7 +6,9 @@ import qualified Data.Text as T
 
 import Control.Exception
 import Control.Concurrent
+import Control.Monad
 import Control.Monad.Reader
+import Control.Monad.State
 import Network
 import Prelude hiding (log, catch)
 import System.IO
@@ -18,13 +20,8 @@ import Network.IRC.Handlers
 import Network.IRC.Protocol
 import Network.IRC.Types
 
-data Status = Connected | Disconnected | Joined | Kicked | Errored
-              deriving (Show, Eq)
-
 oneSec = 1000000
 
-io = liftIO
-
 log msg = getClockTime >>= \t -> printf "[%s] ** %s\n" (show t) msg
 
 sendCommand :: Bot -> Command -> IO ()
@@ -32,39 +29,40 @@ sendCommand Bot { .. } reply = do
   let line = T.unpack $ lineFromCommand botConfig reply
   hPrintf socket "%s\r\n" line >> printf "> %s\n" line
 
-listen :: Status -> IRC Status
-listen status = do
+listen :: IRC ()
+listen = do
+  status <- get
   bot@Bot { .. } <- ask
   let nick  = botNick botConfig
 
-  when (status == Kicked) $
-    io $ threadDelay (5 * oneSec) >> sendCommand bot JoinCmd
-
-  mLine <- io . timeout (oneSec * botTimeout botConfig) . hGetLine $ socket
-  case mLine of
-    Nothing -> return Disconnected
-    Just l -> do
-      let line = init l
-      time <- io getClockTime
-
-      io $ printf "[%s] %s\n" (show time) line
-
-      let message = msgFromLine botConfig time (T.pack line)
-      nStatus <- io $ case message of
-        JoinMsg { .. } | userNick user == nick -> log "Joined" >> return Joined
-        KickMsg { .. }                         -> log "Kicked" >> return Kicked
-        _                                      -> do
-          forkIO $ case message of
-            Ping { .. }                 -> sendCommand bot $ Pong msg
-            ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd
-            msg                         -> forM_ (handlers botConfig) $ \handler -> do
-              cmd <- handleMessage handler botConfig msg
-              case cmd of
-                Nothing  -> return ()
-                Just cmd -> sendCommand bot cmd
-          return status
-
-      listen nStatus
+  nStatus <- liftIO $ do
+    when (status == Kicked) $
+      threadDelay (5 * oneSec) >> sendCommand bot JoinCmd
+
+    mLine <- fmap (fmap init) . timeout (oneSec * botTimeout botConfig) . hGetLine $ socket
+    case mLine of
+      Nothing -> return Disconnected
+      Just line -> do
+        time <- getClockTime
+        printf "[%s] %s\n" (show time) line
+
+        let message = msgFromLine botConfig time (T.pack line)
+        case message of
+          JoinMsg { .. } | userNick user == nick -> log "Joined" >> return Joined
+          KickMsg { .. }                         -> log "Kicked" >> return Kicked
+          _                                      -> do
+            forkIO $ case message of
+              Ping { .. }                 -> sendCommand bot $ Pong msg
+              ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd
+              msg                         -> forM_ (handlers botConfig) $ \handler -> forkIO $ do
+                cmd <- runHandler (getHandler handler) botConfig msg
+                case cmd of
+                  Nothing  -> return ()
+                  Just cmd -> sendCommand bot cmd
+            return status
+
+  put nStatus
+  when (nStatus /= Disconnected) listen
 
 connect :: BotConfig -> IO Bot
 connect botConfig@BotConfig { .. } = do
@@ -104,4 +102,4 @@ run botConfig = withSocketsDo $ do
     go bot = do
       sendCommand bot NickCmd
       sendCommand bot UserCmd
-      runReaderT (listen Connected) bot
+      runIRC bot Connected listen

Network/IRC/Handlers.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE RecordWildCards, OverloadedStrings #-}
 
-module Network.IRC.Handlers (handleMessage) where
+module Network.IRC.Handlers (getHandler) where
 
 import qualified Data.List as L
 
@@ -13,21 +13,20 @@ import Network.IRC.Types
 clean = toLower . strip
 (++) = append
 
-handleMessage :: HandlerName -> Handler
-handleMessage "greeter"    = greeter
-handleMessage "welcomer"   = welcomer
-handleMessage "songsearch" = songSearch
+getHandler :: HandlerName -> Handler
+getHandler "greeter"    = Handler greeter
+getHandler "welcomer"   = Handler welcomer
+getHandler "songsearch" = Handler songSearch
 
-greeter bot ChannelMsg { .. } = case L.find (== clean msg) greetings of
+greeter _ ChannelMsg { .. } = case L.find (== clean msg) greetings of
     Nothing       -> return Nothing
     Just greeting -> return . Just . ChannelMsgReply $ greeting ++ " " ++ userNick user
   where
     greetings = ["hi", "hello", "hey", "sup", "bye"
                 , "good morning", "good evening", "good night"
                 , "ohayo", "oyasumi"]
-
 greeter _ _ = return Nothing
 
-welcomer bot@BotConfig { .. } JoinMsg { .. }
+welcomer BotConfig { .. } JoinMsg { .. }
   | userNick user /= botNick = return . Just . ChannelMsgReply $ "welcome back " ++ userNick user
 welcomer _ _ = return Nothing

Network/IRC/Handlers/SongSearch.hs

@@ -1,26 +1,26 @@
-{-# LANGUAGE RecordWildCards, OverloadedStrings, ScopedTypeVariables, BangPatterns #-}
+{-# LANGUAGE RecordWildCards, OverloadedStrings, ScopedTypeVariables #-}
 
 module Network.IRC.Handlers.SongSearch (songSearch) where
 
-import qualified Data.Configurator as C
-
 import Control.Applicative
 import Control.Exception
 import Control.Monad
+import Control.Monad.Trans
 import Data.Aeson
 import Data.Aeson.Types (emptyArray)
+import Data.Configurator
 import Data.Text
 import Data.Text.IO
 import Network.Curl.Aeson
 import Network.HTTP.Base
-import Prelude hiding (putStrLn, drop)
+import Prelude hiding (putStrLn, drop, lookup)
 
 import Network.IRC.Types
 
 (+++) = append
 
 data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text }
-            deriving (Show)
+            deriving (Show, Eq)
 
 instance FromJSON Song where
     parseJSON (Object o)          = Song <$> o .: "Url" <*> o .: "SongName" <*> o .: "ArtistName"
@@ -28,18 +28,21 @@ instance FromJSON Song where
     parseJSON _                   = mzero
 
 songSearch bot@BotConfig { .. } ChannelMsg { .. }
-  | "!m " `isPrefixOf` msg = do
+  | "!m " `isPrefixOf` msg = liftIO $ do
       let query = strip . drop 3 $ msg
-      apiKey <- C.require config "songsearch.tinysong_apikey"
-      let apiUrl = "http://tinysong.com/b/" ++ urlEncode (unpack query)
-                    ++ "?format=json&key=" ++ apiKey
-
-      result <- try $ curlAesonGet apiUrl >>= evaluate
-
-      return . Just . ChannelMsgReply $ case result of
-        Left (_ :: CurlAesonException) -> "Error while searching for " +++ query
-        Right song                     -> case song of
-          Song { .. } -> "Listen to " +++ artist +++ " - " +++ name +++ " at " +++ url
-          NoSong      -> "No song found for: " +++ query
+      mApiKey <- lookup config "songsearch.tinysong_apikey"
+      fmap (Just . ChannelMsgReply) $ case mApiKey of
+        Nothing     -> -- do log "tinysong api key not found in config"
+          return $ "Error while searching for " +++ query
+        Just apiKey -> do
+          let apiUrl = "http://tinysong.com/b/" ++ urlEncode (unpack query)
+                        ++ "?format=json&key=" ++ apiKey
+
+          result <- try $ curlAesonGet apiUrl >>= evaluate
+          return $ case result of
+            Left (_ :: CurlAesonException) -> "Error while searching for " +++ query
+            Right song                     -> case song of
+              Song { .. } -> "Listen to " +++ artist +++ " - " +++ name +++ " at " +++ url
+              NoSong      -> "No song found for: " +++ query
   | otherwise = return Nothing
 songSearch _ _ = return Nothing

Network/IRC/Types.hs

@@ -1,9 +1,11 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards, DeriveDataTypeable, RankNTypes, GeneralizedNewtypeDeriving #-}
 
 module Network.IRC.Types where
 
 import Control.Monad.Reader
+import Control.Monad.State
 import Data.Configurator.Types
+import Data.Dynamic
 import Data.Text (Text)
 import System.IO
 import System.Time
@@ -11,7 +13,10 @@ import System.Time
 type Channel     = Text
 type Nick        = Text
 type HandlerName = Text
-type Handler     = BotConfig -> Message -> IO (Maybe Command)
+
+newtype Handler = Handler {
+  runHandler :: forall m . (MonadIO m) => BotConfig -> Message -> m (Maybe Command)
+}
 
 data User = Self | User { userNick :: Nick, userServer :: Text }
             deriving (Show, Eq)
@@ -56,4 +61,12 @@ instance Show BotConfig where
 
 data Bot = Bot { botConfig :: BotConfig, socket :: Handle } deriving (Show)
 
-type IRC = ReaderT Bot IO
+data BotStatus = Connected | Disconnected | Joined | Kicked | Errored
+                 deriving (Show, Eq)
+
+newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a }
+                deriving (Functor, Monad, MonadIO, MonadReader Bot, MonadState BotStatus)
+
+runIRC :: Bot -> BotStatus -> IRC a -> IO BotStatus
+runIRC bot botStatus irc =
+  fmap snd $ runReaderT (runStateT (_runIRC irc) Connected) bot

config.cfg.template

@@ -2,7 +2,7 @@ server = "irc.freenode.net"
 port = 6667
 channel = "#testtesttest"
 nick = "haskman"
-handlers = ["greeter", "welcomer"]
+handlers = ["greeter", "welcomer", "songsearch"]
 
 songsearch {
   tinysong_apikey = "xxxyyyzzz"

hask-irc.cabal

@@ -48,6 +48,15 @@ build-type:          Simple
 -- Constraint on the version of Cabal needed to build this package.
 cabal-version:       >=1.10
 
+library
+  build-depends:       base >=4.5 && <4.7, text >=0.11 && <0.12, mtl >=2.1 && <2.2,
+                       network >=2.3 && <2.5, old-time >=1.1 && <1.2, configurator >= 0.2,
+                       curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP, transformers >=0.3
+
+  exposed-modules:     Network.IRC.Types, Network.IRC.Protocol,
+                       Network.IRC.Handlers, Network.IRC.Client
+
+  default-language:    Haskell2010
 
 executable hask-irc
   -- .hs or .lhs file containing the Main module.
@@ -62,7 +71,7 @@ executable hask-irc
   -- Other library packages from which modules are imported.
   build-depends:       base >=4.5 && <4.7, text >=0.11 && <0.12, mtl >=2.1 && <2.2,
                        network >=2.3 && <2.5, old-time >=1.1 && <1.2, configurator >= 0.2,
-                       curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP
+                       curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP, transformers >=0.3
 
   -- Directories containing source files.
   -- hs-source-dirs: