diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs index ebdb350..aaa5a37 100644 --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, ScopedTypeVariables, NoImplicitPrelude, OverloadedStrings #-} +{-# LANGUAGE RecordWildCards, ScopedTypeVariables, NoImplicitPrelude, OverloadedStrings, BangPatterns #-} module Network.IRC.Client (run) where @@ -6,7 +6,7 @@ import qualified Data.Text.Format as TF import qualified Data.Text.Format.Params as TF import ClassyPrelude -import Control.Concurrent +import Control.Concurrent.Lifted import Control.Monad.Reader hiding (forM_, foldM) import Control.Monad.State hiding (forM_, foldM) import Data.Maybe (fromJust) @@ -31,7 +31,7 @@ sendCommand Bot { .. } reply = do time <- getCurrentTime let line = lineFromCommand botConfig reply TF.hprint socket "{}\r\n" $ TF.Only line - TF.print "[{}} > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line) + TF.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line) listen :: IRC () listen = do @@ -57,22 +57,45 @@ listen = do ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd >> return status _ -> return status - forM_ (msgHandlers botConfig) $ \msgHandlerName -> forkIO $ do + forM_ (msgHandlers botConfig) $ \msgHandlerName -> fork $ do let mMsgHandler = getMsgHandler msgHandlerName case mMsgHandler of Nothing -> debug $ "No msg handler found with name: " ++ msgHandlerName - Just msgHandler -> do + Just msgHandler -> let msgHandlerState = fromJust . lookup msgHandlerName $ msgHandlerStates - mCmd <- runMsgHandler msgHandler botConfig msgHandlerState message - case mCmd of - Nothing -> return () - Just cmd -> sendCommand bot cmd + in modifyMVar_ msgHandlerState $ \hState -> do + !(mCmd, nhState) <- runMsgHandler msgHandler botConfig hState message + case mCmd of + Nothing -> return () + Just cmd -> sendCommand bot cmd + return nhState return nStatus put nStatus when (nStatus /= Disconnected) listen +loadMsgHandlers :: BotConfig -> IO MsgHandlerStates +loadMsgHandlers botConfig@BotConfig { .. } = + flip (`foldM` mapFromList []) msgHandlers $ \hMap msgHandlerName -> do + debug $ "Loading msg handler: " ++ msgHandlerName + let mMsgHandler = getMsgHandler msgHandlerName + case mMsgHandler of + Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName) >> return hMap + Just msgHandler -> do + !msgHandlerState <- initMsgHandler msgHandler botConfig + mvMsgHandlerState <- newMVar msgHandlerState + return $ insertMap msgHandlerName mvMsgHandlerState hMap + +unloadMsgHandlers :: Bot -> IO () +unloadMsgHandlers Bot { .. } = + forM_ (mapToList msgHandlerStates) $ \(msgHandlerName, msgHandlerState) -> do + debug $ "Unloading msg handler: " ++ msgHandlerName + let mMsgHandler = getMsgHandler msgHandlerName + case mMsgHandler of + Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName) + Just msgHandler -> takeMVar msgHandlerState >>= exitMsgHandler msgHandler botConfig + connect :: BotConfig -> IO Bot connect botConfig@BotConfig { .. } = do debug "Connecting ..." @@ -88,27 +111,6 @@ connect botConfig@BotConfig { .. } = do threadDelay (5 * oneSec) connectToWithRetry) -loadMsgHandlers :: BotConfig -> IO MsgHandlerStates -loadMsgHandlers botConfig@BotConfig { .. } = - flip (`foldM` mapFromList []) msgHandlers $ \hMap msgHandlerName -> do - debug $ "Loading msg handler: " ++ msgHandlerName - let mMsgHandler = getMsgHandler msgHandlerName - case mMsgHandler of - Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName) >> return hMap - Just msgHandler -> do - msgHandlerState <- initMsgHandler msgHandler botConfig - return $ insertMap msgHandlerName msgHandlerState hMap - -unloadMsgHandlers :: Bot -> IO () -unloadMsgHandlers Bot { .. } = - forM_ (mapToList msgHandlerStates) $ \(msgHandlerName, msgHandlerState) -> do - debug $ "Unloading msg handler: " ++ msgHandlerName - let mMsgHandler = getMsgHandler msgHandlerName - case mMsgHandler of - Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName) - Just msgHandler -> exitMsgHandler msgHandler botConfig msgHandlerState - - disconnect :: Bot -> IO () disconnect bot@Bot { .. } = do debug "Disconnecting ..." diff --git a/Network/IRC/Handlers/Core.hs b/Network/IRC/Handlers/Core.hs index f97e346..3d0049d 100644 --- a/Network/IRC/Handlers/Core.hs +++ b/Network/IRC/Handlers/Core.hs @@ -56,27 +56,27 @@ fmtTime :: UTCTime -> String fmtTime = formatTime defaultTimeLocale "%F %T" messageLogger :: MonadMsgHandler m => Message -> m (Maybe Command) -messageLogger ChannelMsg { .. } = withLogFile $ \logFileHandle -> - TF.hprint logFileHandle "[{}] {}: {}\n" $ TF.buildParams (fmtTime msgTime, userNick user, msg) +messageLogger ChannelMsg { .. } = withLogFile $ \logFile -> + TF.hprint logFile "[{}] {}: {}\n" $ TF.buildParams (fmtTime msgTime, userNick user, msg) -messageLogger KickMsg { .. } = withLogFile $ \logFileHandle -> - TF.hprint logFileHandle "[{}] ** {} KICKED {} :{}\n" $ +messageLogger KickMsg { .. } = withLogFile $ \logFile -> + TF.hprint logFile "[{}] ** {} KICKED {} :{}\n" $ TF.buildParams (fmtTime msgTime, userNick user, kickedNick, msg) -messageLogger JoinMsg { .. } = withLogFile $ \logFileHandle -> - TF.hprint logFileHandle "[{}] ** {} JOINED\n" $ +messageLogger JoinMsg { .. } = withLogFile $ \logFile -> + TF.hprint logFile "[{}] ** {} JOINED\n" $ TF.buildParams (fmtTime msgTime, userNick user) -messageLogger PartMsg { .. } = withLogFile $ \logFileHandle -> - TF.hprint logFileHandle "[{}] ** {} PARTED :{}\n" $ +messageLogger PartMsg { .. } = withLogFile $ \logFile -> + TF.hprint logFile "[{}] ** {} PARTED :{}\n" $ TF.buildParams (fmtTime msgTime, userNick user, msg) -messageLogger QuitMsg { .. } = withLogFile $ \logFileHandle -> - TF.hprint logFileHandle "[{}] ** {} QUIT :{}\n" $ +messageLogger QuitMsg { .. } = withLogFile $ \logFile -> + TF.hprint logFile "[{}] ** {} QUIT :{}\n" $ TF.buildParams (fmtTime msgTime, userNick user, msg) -messageLogger NickMsg { .. } = withLogFile $ \logFileHandle -> - TF.hprint logFileHandle "[{}] ** {} CHANGED NICK TO {}\n" $ +messageLogger NickMsg { .. } = withLogFile $ \logFile -> + TF.hprint logFile "[{}] ** {} CHANGED NICK TO {}\n" $ TF.buildParams (fmtTime msgTime, userNick user, nick) messageLogger _ = return Nothing diff --git a/Network/IRC/Types.hs b/Network/IRC/Types.hs index 4196200..151ed66 100644 --- a/Network/IRC/Types.hs +++ b/Network/IRC/Types.hs @@ -64,11 +64,12 @@ instance Show BotConfig where "timeout = " ++ show botTimeout ++ "\n" ++ "handlers = " ++ show msgHandlers -type MsgHandlerStates = Map MsgHandlerName MsgHandlerState +type MsgHandlerState = Dynamic +type MsgHandlerStates = Map MsgHandlerName (MVar MsgHandlerState) data Bot = Bot { botConfig :: !BotConfig , socket :: !Handle - , msgHandlerStates :: !MsgHandlerStates} + , msgHandlerStates :: !MsgHandlerStates } data BotStatus = Connected | Disconnected | Joined | Kicked | Errored deriving (Show, Eq) @@ -79,31 +80,29 @@ newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a } , Monad , MonadIO , MonadReader Bot - , MonadState BotStatus) + , MonadState BotStatus ) runIRC :: Bot -> BotStatus -> IRC a -> IO BotStatus runIRC bot botStatus = flip runReaderT bot . flip execStateT botStatus . _runIRC -type MsgHandlerState = Dynamic - newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: StateT MsgHandlerState (ReaderT BotConfig IO) a } deriving ( Functor , Applicative , Monad , MonadIO , MonadState MsgHandlerState - , MonadReader BotConfig) + , MonadReader BotConfig ) class ( MonadIO m, Applicative m - , MonadState MsgHandlerState m, MonadReader BotConfig m) => MonadMsgHandler m where + , MonadState MsgHandlerState m, MonadReader BotConfig m ) => MonadMsgHandler m where msgHandler :: MsgHandlerT a -> m a instance MonadMsgHandler MsgHandlerT where msgHandler = id -runMsgHandler :: MsgHandler -> BotConfig -> MsgHandlerState -> Message -> IO (Maybe Command) +runMsgHandler :: MsgHandler -> BotConfig -> MsgHandlerState -> Message -> IO (Maybe Command, MsgHandlerState) runMsgHandler MsgHandler { .. } botConfig msgHandlerState = - flip runReaderT botConfig . flip evalStateT msgHandlerState . _runMsgHandler . msgHandlerRun + flip runReaderT botConfig . flip runStateT msgHandlerState . _runMsgHandler . msgHandlerRun initMsgHandler :: MsgHandler -> BotConfig -> IO MsgHandlerState initMsgHandler MsgHandler { .. } botConfig = diff --git a/hask-irc.cabal b/hask-irc.cabal index 2bb1b7f..d48f5bf 100644 --- a/hask-irc.cabal +++ b/hask-irc.cabal @@ -52,7 +52,8 @@ library build-depends: base >=4.5 && <4.7, text >=0.11 && <0.12, mtl >=2.1 && <2.2, network >=2.3 && <2.5, configurator >= 0.2, time >=1.4.0, curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP, transformers >=0.3, - classy-prelude ==0.9.1, text-format >= 0.3.1, filepath >=1.3, directory >=1.2 + classy-prelude ==0.9.1, text-format >= 0.3.1, filepath >=1.3, directory >=1.2, + lifted-base >=0.2 exposed-modules: Network.IRC.Types, Network.IRC.Protocol, Network.IRC.Handlers, Network.IRC.Client @@ -76,7 +77,8 @@ executable hask-irc build-depends: base >=4.5 && <4.7, text >=0.11 && <0.12, mtl >=2.1 && <2.2, network >=2.3 && <2.5, configurator >= 0.2, time >=1.4.0, curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP, transformers >=0.3, - classy-prelude ==0.9.1, text-format >= 0.3.1, filepath >=1.3, directory >=1.2 + classy-prelude ==0.9.1, text-format >= 0.3.1, filepath >=1.3, directory >=1.2, + lifted-base >=0.2 -- Directories containing source files. -- hs-source-dirs: