abhin4v
/
hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Moved to classy-prelude

master
Abhinav Sarkar 2014-05-10 21:45:16 +05:30
parent cfc796564a
commit 964d2fbb35
7 changed files with 52 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
Main.hs
View File

@ -3,9 +3,8 @@
module Main (main) where module Main (main) where
import qualified Data.Configurator as CF import qualified Data.Configurator as CF
import qualified Data.Text as T
import BasicPrelude hiding (try, getArgs) import ClassyPrelude hiding (try, getArgs)
import Control.Exception import Control.Exception
import Data.Configurator.Types import Data.Configurator.Types
import System.Environment import System.Environment
@ -24,10 +23,10 @@ main = do
prog <- getProgName prog <- getProgName
when (length args < 1) $ do when (length args < 1) $ do
putStrLn $ "Usage: " ++ T.pack prog ++ " <config file path>" putStrLn $ "Usage: " ++ pack prog ++ " <config file path>"
exitFailure exitFailure
let configFile = head args let configFile = headEx args
loadBotConfig configFile >>= run loadBotConfig configFile >>= run
loadBotConfig :: String -> IO BotConfig loadBotConfig :: String -> IO BotConfig
@ -46,5 +45,5 @@ loadBotConfig configFile = do
return $ BotConfig server port channel botNick timeout handlers cfg return $ BotConfig server port channel botNick timeout handlers cfg
case eBotConfig of case eBotConfig of
Left (KeyError k) -> error $ "Error while reading key from config: " ++ T.unpack k Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k
Right botConfig -> return botConfig Right botConfig -> return botConfig

24
Network/IRC/Client.hs
View File

@ -2,17 +2,15 @@
module Network.IRC.Client (run) where module Network.IRC.Client (run) where
import qualified Data.Text as T
import qualified Data.Text.Format as TF import qualified Data.Text.Format as TF
import qualified Data.Text.Format.Params as TF import qualified Data.Text.Format.Params as TF
import BasicPrelude hiding (log) import ClassyPrelude hiding (log)
import Control.Concurrent import Control.Concurrent
import Control.Monad.Reader import Control.Monad.Reader hiding (forM_)
import Control.Monad.State import Control.Monad.State hiding (forM_)
import Network import Network
import System.IO import System.IO (hSetBuffering, BufferMode(..))
import System.Time
import System.Timeout import System.Timeout
import Network.IRC.Handlers import Network.IRC.Handlers
@ -23,7 +21,7 @@ oneSec :: Int
oneSec = 1000000 oneSec = 1000000
log :: Text -> IO () log :: Text -> IO ()
log msg = getClockTime >>= \t -> TF.print "[{}] ** {}\n" $ TF.buildParams (show t, msg) log msg = getCurrentTime >>= \t -> TF.print "[{}] ** {}\n" $ TF.buildParams (t, msg)
sendCommand :: Bot -> Command -> IO () sendCommand :: Bot -> Command -> IO ()
sendCommand Bot { .. } reply = do sendCommand Bot { .. } reply = do
@ -41,14 +39,14 @@ listen = do
when (status == Kicked) $ when (status == Kicked) $
threadDelay (5 * oneSec) >> sendCommand bot JoinCmd threadDelay (5 * oneSec) >> sendCommand bot JoinCmd
mLine <- fmap (fmap init) . timeout (oneSec * botTimeout botConfig) . hGetLine $ socket mLine <- map (map initEx) . timeout (oneSec * botTimeout botConfig) . hGetLine $ socket
case mLine of case mLine of
Nothing -> return Disconnected Nothing -> return Disconnected
Just line -> do Just line -> do
now <- getClockTime now <- getCurrentTime
TF.print "[{}] {}\n" $ TF.buildParams (show now, line) TF.print "[{}] {}\n" $ TF.buildParams (now, line)
let message = msgFromLine botConfig now (T.pack line) let message = msgFromLine botConfig now line
case message of case message of
JoinMsg { .. } | userNick user == nick -> log "Joined" >> return Joined JoinMsg { .. } | userNick user == nick -> log "Joined" >> return Joined
KickMsg { .. } | kicked == nick -> log "Kicked" >> return Kicked KickMsg { .. } | kicked == nick -> log "Kicked" >> return Kicked
@ -81,7 +79,7 @@ connect botConfig@BotConfig { .. } = do
where where
connectToWithRetry = connectTo server (PortNumber (fromIntegral port)) connectToWithRetry = connectTo server (PortNumber (fromIntegral port))
`catch` (\(e :: SomeException) -> do `catch` (\(e :: SomeException) -> do
log ("Error: " ++ show e ++ ". Waiting.") log ("Error while connecting: " ++ pack (show e) ++ ". Waiting.")
threadDelay (5 * oneSec) threadDelay (5 * oneSec)
connectToWithRetry) connectToWithRetry)
@ -103,7 +101,7 @@ run botConfig = withSocketsDo $ do
where where
run_ = bracket (connect botConfig) disconnect $ \bot -> run_ = bracket (connect botConfig) disconnect $ \bot ->
go bot `catch` \(e :: SomeException) -> do go bot `catch` \(e :: SomeException) -> do
log $ "Exception! " ++ show e log $ "Exception! " ++ pack (show e)
return Errored return Errored
go bot = do go bot = do

7
Network/IRC/Handlers.hs
View File

@ -2,15 +2,14 @@
module Network.IRC.Handlers (getHandler) where module Network.IRC.Handlers (getHandler) where
import qualified Data.Text as T import ClassyPrelude
import Data.Text (strip)
import BasicPrelude
import Network.IRC.Handlers.SongSearch import Network.IRC.Handlers.SongSearch
import Network.IRC.Types import Network.IRC.Types
clean :: Text -> Text clean :: Text -> Text
clean = T.toLower . T.strip clean = toLower . strip
getHandler :: HandlerName -> Maybe Handler getHandler :: HandlerName -> Maybe Handler
getHandler "greeter" = Just $ Handler greeter getHandler "greeter" = Just $ Handler greeter

14
Network/IRC/Handlers/SongSearch.hs
View File

@ -3,12 +3,12 @@
module Network.IRC.Handlers.SongSearch (songSearch) where module Network.IRC.Handlers.SongSearch (songSearch) where
import qualified Data.Configurator as CF import qualified Data.Configurator as CF
import qualified Data.Text as T
import BasicPrelude hiding (try) import ClassyPrelude hiding (try)
import Control.Exception import Control.Exception
import Data.Aeson import Data.Aeson
import Data.Aeson.Types (emptyArray) import Data.Aeson.Types (emptyArray)
import Data.Text (strip)
import Network.Curl.Aeson import Network.Curl.Aeson
import Network.HTTP.Base import Network.HTTP.Base
@ -20,18 +20,18 @@ data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text }
instance FromJSON Song where instance FromJSON Song where
parseJSON (Object o) = Song <$> o .: "Url" <*> o .: "SongName" <*> o .: "ArtistName" parseJSON (Object o) = Song <$> o .: "Url" <*> o .: "SongName" <*> o .: "ArtistName"
parseJSON a | a == emptyArray = return NoSong parseJSON a | a == emptyArray = return NoSong
parseJSON _ = mzero parseJSON _ = mempty
songSearch :: MonadIO m => BotConfig -> Message -> m (Maybe Command) songSearch :: MonadIO m => BotConfig -> Message -> m (Maybe Command)
songSearch BotConfig { .. } ChannelMsg { .. } songSearch BotConfig { .. } ChannelMsg { .. }
| "!m " `T.isPrefixOf` msg = liftIO $ do | "!m " `isPrefixOf` msg = liftIO $ do
let query = T.strip . T.drop 3 $ msg let query = strip . drop 3 $ msg
mApiKey <- CF.lookup config "songsearch.tinysong_apikey" mApiKey <- CF.lookup config "songsearch.tinysong_apikey"
fmap (Just . ChannelMsgReply) $ case mApiKey of map (Just . ChannelMsgReply) $ case mApiKey of
Nothing -> -- do log "tinysong api key not found in config" Nothing -> -- do log "tinysong api key not found in config"
return $ "Error while searching for " ++ query return $ "Error while searching for " ++ query
Just apiKey -> do Just apiKey -> do
let apiUrl = "http://tinysong.com/b/" ++ urlEncode (T.unpack query) let apiUrl = "http://tinysong.com/b/" ++ urlEncode (unpack query)
++ "?format=json&key=" ++ apiKey ++ "?format=json&key=" ++ apiKey
result <- try $ curlAesonGet apiUrl >>= evaluate result <- try $ curlAesonGet apiUrl >>= evaluate

26
Network/IRC/Protocol.hs
View File

@ -2,17 +2,15 @@
module Network.IRC.Protocol (msgFromLine, lineFromCommand) where module Network.IRC.Protocol (msgFromLine, lineFromCommand) where
import qualified Data.List as L import ClassyPrelude
import qualified Data.Text as T import Data.List ((!!))
import Data.Text (split)
import BasicPrelude
import System.Time
import Network.IRC.Types import Network.IRC.Types
msgFromLine :: BotConfig -> ClockTime -> Text -> Message msgFromLine :: BotConfig -> UTCTime -> Text -> Message
msgFromLine (BotConfig { .. }) time line msgFromLine (BotConfig { .. }) time line
| "PING :" `T.isPrefixOf` line = Ping time . T.drop 6 $ line | "PING :" `isPrefixOf` line = Ping time . drop 6 $ line
| otherwise = case command of | otherwise = case command of
"JOIN" -> JoinMsg time user "JOIN" -> JoinMsg time user
"QUIT" -> QuitMsg time user message "QUIT" -> QuitMsg time user message
@ -21,7 +19,7 @@ msgFromLine (BotConfig { .. }) time line
"MODE" -> if source == botNick "MODE" -> if source == botNick
then ModeMsg time Self target message [] then ModeMsg time Self target message []
else ModeMsg time user target mode modeArgs else ModeMsg time user target mode modeArgs
"NICK" -> NickMsg time user (T.drop 1 target) "NICK" -> NickMsg time user (drop 1 target)
"PRIVMSG" -> if target == channel "PRIVMSG" -> if target == channel
then ChannelMsg time user message then ChannelMsg time user message
else PrivMsg time user message else PrivMsg time user message
@ -29,16 +27,16 @@ msgFromLine (BotConfig { .. }) time line
where where
isSpc = (== ' ') isSpc = (== ' ')
isNotSpc = not . isSpc isNotSpc = not . isSpc
splits = T.split isSpc line splits = split isSpc line
source = T.drop 1 . T.takeWhile isNotSpc $ line source = drop 1 . takeWhile isNotSpc $ line
target = splits !! 2 target = splits !! 2
command = splits !! 1 command = splits !! 1
message = T.drop 1 . unwords . L.drop 3 $ splits message = drop 1 . unwords . drop 3 $ splits
user = let u = T.split (== '!') source in User (u !! 0) (u !! 1) user = let u = split (== '!') source in User (u !! 0) (u !! 1)
mode = splits !! 3 mode = splits !! 3
modeArgs = L.drop 4 splits modeArgs = drop 4 splits
kicked = splits !! 3 kicked = splits !! 3
kickReason = T.drop 1 . unwords . L.drop 4 $ splits kickReason = drop 1 . unwords . drop 4 $ splits
lineFromCommand :: BotConfig -> Command -> Text lineFromCommand :: BotConfig -> Command -> Text
lineFromCommand (BotConfig { .. }) reply = case reply of lineFromCommand (BotConfig { .. }) reply = case reply of

25
Network/IRC/Types.hs
View File

@ -3,13 +3,10 @@
module Network.IRC.Types where module Network.IRC.Types where
import BasicPrelude hiding (show) import ClassyPrelude
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.State import Control.Monad.State
import Data.Configurator.Types import Data.Configurator.Types
import Prelude (Show(..))
import System.IO
import System.Time
type Channel = Text type Channel = Text
type Nick = Text type Nick = Text
@ -23,16 +20,16 @@ data User = Self | User { userNick :: Nick, userServer :: Text }
deriving (Show, Eq) deriving (Show, Eq)
data Message = data Message =
ChannelMsg { time :: ClockTime, user :: User, msg :: Text } ChannelMsg { time :: UTCTime, user :: User, msg :: Text }
| PrivMsg { time :: ClockTime, user :: User, msg :: Text } | PrivMsg { time :: UTCTime, user :: User, msg :: Text }
| Ping { time :: ClockTime, msg :: Text } | Ping { time :: UTCTime, msg :: Text }
| JoinMsg { time :: ClockTime, user :: User } | JoinMsg { time :: UTCTime, user :: User }
| ModeMsg { time :: ClockTime, user :: User, target :: Text , mode :: Text, modeArgs :: [Text] } | ModeMsg { time :: UTCTime, user :: User, target :: Text , mode :: Text, modeArgs :: [Text] }
| NickMsg { time :: ClockTime, user :: User, nick :: Text } | NickMsg { time :: UTCTime, user :: User, nick :: Text }
| QuitMsg { time :: ClockTime, user :: User, msg :: Text } | QuitMsg { time :: UTCTime, user :: User, msg :: Text }
| PartMsg { time :: ClockTime, user :: User, msg :: Text } | PartMsg { time :: UTCTime, user :: User, msg :: Text }
| KickMsg { time :: ClockTime, user :: User, kicked :: Text , msg :: Text } | KickMsg { time :: UTCTime, user :: User, kicked :: Text , msg :: Text }
| OtherMsg { time :: ClockTime, source :: Text, command :: Text , target :: Text, msg :: Text } | OtherMsg { time :: UTCTime, source :: Text, command :: Text , target :: Text, msg :: Text }
deriving (Show, Eq) deriving (Show, Eq)
data Command = data Command =

8
hask-irc.cabal
View File

@ -50,9 +50,9 @@ cabal-version: >=1.10
library library
build-depends: base >=4.5 && <4.7, text >=0.11 && <0.12, mtl >=2.1 && <2.2, 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, 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, curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP, transformers >=0.3,
basic-prelude ==0.3.8, text-format >= 0.3.1 classy-prelude ==0.9.1, text-format >= 0.3.1
exposed-modules: Network.IRC.Types, Network.IRC.Protocol, exposed-modules: Network.IRC.Types, Network.IRC.Protocol,
Network.IRC.Handlers, Network.IRC.Client Network.IRC.Handlers, Network.IRC.Client
@ -74,9 +74,9 @@ executable hask-irc
-- Other library packages from which modules are imported. -- 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, 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, 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, curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP, transformers >=0.3,
basic-prelude ==0.3.8, text-format >= 0.3.1 classy-prelude ==0.9.1, text-format >= 0.3.1
-- Directories containing source files. -- Directories containing source files.
-- hs-source-dirs: -- hs-source-dirs: