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