diff --git a/.gitignore b/.gitignore index 8d8dadb..4d2b220 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,4 @@ cabal.sandbox.config dist config.cfg +*sublime* diff --git a/Main.hs b/Main.hs index df1b336..9aeaab5 100644 --- a/Main.hs +++ b/Main.hs @@ -12,7 +12,7 @@ import Data.Maybe import System.Environment import System.Exit -import Network.IRC.Types +import Network.IRC.Types (BotConfig(BotConfig)) import Network.IRC.Client instance Configured a => Configured [a] where diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs index 37fd5a5..af46696 100644 --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -10,7 +10,7 @@ import Control.Monad import Control.Monad.Reader import Control.Monad.State import Network -import Prelude hiding (log, catch) +import Prelude hiding (log) import System.IO import System.Time import System.Timeout @@ -20,8 +20,10 @@ import Network.IRC.Handlers import Network.IRC.Protocol import Network.IRC.Types +oneSec :: Int oneSec = 1000000 +log :: String -> IO () log msg = getClockTime >>= \t -> printf "[%s] ** %s\n" (show t) msg sendCommand :: Bot -> Command -> IO () @@ -43,10 +45,10 @@ listen = do case mLine of Nothing -> return Disconnected Just line -> do - time <- getClockTime - printf "[%s] %s\n" (show time) line + now <- getClockTime + printf "[%s] %s\n" (show now) line - let message = msgFromLine botConfig time (T.pack line) + let message = msgFromLine botConfig now (T.pack line) case message of JoinMsg { .. } | userNick user == nick -> log "Joined" >> return Joined KickMsg { .. } | kicked == nick -> log "Kicked" >> return Kicked @@ -54,11 +56,15 @@ listen = 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 + msg -> forM_ (handlers botConfig) $ \handlerName -> forkIO $ do + let mHandler = getHandler handlerName + case mHandler of + Nothing -> log $ "No handler found with name: " ++ T.unpack handlerName + Just handler -> do + mCmd <- runHandler handler botConfig msg + case mCmd of + Nothing -> return () + Just cmd -> sendCommand bot cmd return status put nStatus @@ -67,11 +73,11 @@ listen = do connect :: BotConfig -> IO Bot connect botConfig@BotConfig { .. } = do log "Connecting ..." - handle <- connectToWithRetry - hSetBuffering handle LineBuffering + socket <- connectToWithRetry + hSetBuffering socket LineBuffering hSetBuffering stdout LineBuffering log "Connected" - return $ Bot botConfig handle + return $ Bot botConfig socket where connectToWithRetry = connectTo server (PortNumber (fromIntegral port)) `catch` (\(e :: SomeException) -> do @@ -93,6 +99,7 @@ run botConfig = withSocketsDo $ do case status of Disconnected -> log "Connection timed out" >> run botConfig Errored -> return () + _ -> error "Unsupported status" where run_ = bracket (connect botConfig) disconnect $ \bot -> go bot `catch` \(e :: SomeException) -> do diff --git a/Network/IRC/Handlers.hs b/Network/IRC/Handlers.hs index f3e3357..09a7325 100644 --- a/Network/IRC/Handlers.hs +++ b/Network/IRC/Handlers.hs @@ -10,14 +10,19 @@ import Prelude hiding ((++)) import Network.IRC.Handlers.SongSearch import Network.IRC.Types +clean :: Text -> Text clean = toLower . strip + +(++) :: Text -> Text -> Text (++) = append -getHandler :: HandlerName -> Handler -getHandler "greeter" = Handler greeter -getHandler "welcomer" = Handler welcomer -getHandler "songsearch" = Handler songSearch +getHandler :: HandlerName -> Maybe Handler +getHandler "greeter" = Just $ Handler greeter +getHandler "welcomer" = Just $ Handler welcomer +getHandler "songsearch" = Just $ Handler songSearch +getHandler _ = Nothing +greeter :: Monad m => BotConfig -> Message -> m (Maybe Command) greeter _ ChannelMsg { .. } = case L.find (== clean msg) greetings of Nothing -> return Nothing Just greeting -> return . Just . ChannelMsgReply $ greeting ++ " " ++ userNick user @@ -27,6 +32,7 @@ greeter _ ChannelMsg { .. } = case L.find (== clean msg) greetings of , "ohayo", "oyasumi"] greeter _ _ = return Nothing +welcomer :: Monad m => BotConfig -> Message -> m (Maybe Command) welcomer BotConfig { .. } JoinMsg { .. } | userNick user /= botNick = return . Just . ChannelMsgReply $ "welcome back " ++ userNick user welcomer _ _ = return Nothing diff --git a/Network/IRC/Handlers/SongSearch.hs b/Network/IRC/Handlers/SongSearch.hs index 09e620e..86d3871 100644 --- a/Network/IRC/Handlers/SongSearch.hs +++ b/Network/IRC/Handlers/SongSearch.hs @@ -10,15 +10,12 @@ 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, lookup) import Network.IRC.Types -(+++) = append - data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text } deriving (Show, Eq) @@ -27,7 +24,8 @@ instance FromJSON Song where parseJSON a | a == emptyArray = return NoSong parseJSON _ = mzero -songSearch bot@BotConfig { .. } ChannelMsg { .. } +songSearch :: MonadIO m => BotConfig -> Message -> m (Maybe Command) +songSearch BotConfig { .. } ChannelMsg { .. } | "!m " `isPrefixOf` msg = liftIO $ do let query = strip . drop 3 $ msg mApiKey <- lookup config "songsearch.tinysong_apikey" @@ -45,4 +43,6 @@ songSearch bot@BotConfig { .. } ChannelMsg { .. } Song { .. } -> "Listen to " +++ artist +++ " - " +++ name +++ " at " +++ url NoSong -> "No song found for: " +++ query | otherwise = return Nothing + where + (+++) = append songSearch _ _ = return Nothing diff --git a/Network/IRC/Protocol.hs b/Network/IRC/Protocol.hs index fccc757..acbe64b 100644 --- a/Network/IRC/Protocol.hs +++ b/Network/IRC/Protocol.hs @@ -10,8 +10,6 @@ import System.Time import Network.IRC.Types -(++) = append - msgFromLine :: BotConfig -> ClockTime -> Text -> Message msgFromLine (BotConfig { .. }) time line | "PING :" `isPrefixOf` line = Ping time . drop 6 $ line @@ -50,3 +48,5 @@ lineFromCommand (BotConfig { .. }) reply = case reply of JoinCmd -> "JOIN " ++ channel ChannelMsgReply { .. } -> "PRIVMSG " ++ channel ++ " :" ++ rmsg PrivMsgReply (User { .. }) rmsg -> "PRIVMSG " ++ botNick ++ " :" ++ rmsg + where + (++) = append diff --git a/Network/IRC/Types.hs b/Network/IRC/Types.hs index 56b59ce..db92572 100644 --- a/Network/IRC/Types.hs +++ b/Network/IRC/Types.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE RecordWildCards, DeriveDataTypeable, RankNTypes, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards, 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 @@ -68,5 +67,4 @@ 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 +runIRC bot botStatus = flip runReaderT bot . flip execStateT botStatus . _runIRC diff --git a/hask-irc.cabal b/hask-irc.cabal index 4014cd4..5b9b048 100644 --- a/hask-irc.cabal +++ b/hask-irc.cabal @@ -58,6 +58,9 @@ library default-language: Haskell2010 + ghc-options: -Wall -fno-warn-unused-do-bind -O2 -funbox-strict-fields + + executable hask-irc -- .hs or .lhs file containing the Main module. main-is: Main.hs @@ -66,7 +69,7 @@ executable hask-irc -- other-modules: -- LANGUAGE extensions used by modules in this package. - other-extensions: RecordWildCards, OverloadedStrings, ScopedTypeVariables + other-extensions: RecordWildCards, OverloadedStrings, ScopedTypeVariables, OverlappingInstances -- 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, @@ -79,3 +82,5 @@ executable hask-irc -- Base language which the package is written in. default-language: Haskell2010 + ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields +