diff --git a/Network/SimpleIRC/Core.hs b/Network/SimpleIRC/Core.hs --- a/Network/SimpleIRC/Core.hs +++ b/Network/SimpleIRC/Core.hs @@ -8,15 +8,15 @@ -- Portability : portable -- -- For information on how to use this library please take a look at the readme file on github, . -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, CPP #-} module Network.SimpleIRC.Core - ( + ( -- * Types - MIrc + MIrc , EventFunc , IrcConfig(..) , IrcEvent(..) - + -- * Functions , connect , disconnect @@ -27,8 +27,8 @@ , addEvent , changeEvents , remEvent - , defaultConfig - + , mkDefaultConfig + -- * Accessors , getChannels , getNickname @@ -36,8 +36,12 @@ , getPort , getUsername , getRealname +#ifdef TEST + , IrcServer(..) + , listenLoop +#endif ) where - + import Network import System.IO import Data.Maybe @@ -45,18 +49,19 @@ import Data.Char (isNumber) import Control.Monad import Control.Concurrent -import Control.Concurrent.Chan -import Control.Concurrent.MVar import Network.SimpleIRC.Messages import Data.Unique -import System.IO.Error +import Control.Exception (try) import System.Timeout import Data.Time import System.Locale import qualified Data.ByteString.Char8 as B import qualified Data.Map as Map +import qualified Data.Foldable as Foldable +internalEvents :: [IrcServer -> IrcMessage -> IO IrcServer] internalEvents = [joinChans, pong, trackChanges] +internalNormEvents :: [IrcEvent] internalNormEvents = [Privmsg ctcpHandler] type MIrc = MVar IrcServer @@ -98,12 +103,13 @@ , sCTCPVersion :: String , sCTCPTime :: IO String , sPingTimeoutInterval :: Int + , sFloodControlTimestamp :: UTCTime } -- When adding events here, remember add them in callEvents and in eventFunc -- AND also in the Show instance and Eq instance -data IrcEvent = +data IrcEvent = Privmsg EventFunc -- ^ PRIVMSG | Numeric EventFunc -- ^ Numeric, 001, 002, 372 etc. | Ping EventFunc -- ^ PING @@ -119,7 +125,7 @@ | RawMsg EventFunc -- ^ This event gets called on every message received | Disconnect (MIrc -> IO ()) -- ^ This event gets called whenever the -- connection with the server is dropped - + instance Show IrcEvent where show (Privmsg _) = "IrcEvent - Privmsg" show (Numeric _) = "IrcEvent - Numeric" @@ -146,24 +152,24 @@ connect config threaded debug = try $ do (when debug $ B.putStrLn $ "Connecting to " `B.append` B.pack (cAddr config)) - + h <- connectTo (cAddr config) (PortNumber $ fromIntegral $ cPort config) hSetBuffering h NoBuffering - + cmdChan <- newChan - + server <- toServer config h cmdChan debug -- Initialize connection with the server - greetServer server - + _ <- greetServer server + -- Create a new MVar res <- newMVar server - + -- Start the loops, listen and exec cmds if threaded then do listenId <- forkIO (listenLoop res) - cmdId <- forkIO (execCmdsLoop res) - modifyMVar_ res (\srv -> return $ srv {sListenThread = Just listenId}) + _ <- forkIO (execCmdsLoop res) + modifyMVar_ res (\srv -> return $ srv {sListenThread = Just listenId}) return res else do listenLoop res return res @@ -174,39 +180,38 @@ -> IO () disconnect server quitMsg = do s <- readMVar server - - let h = fromJust $ sSock s + write s $ "QUIT :" `B.append` quitMsg return () -- |Reconnects to the server. reconnect :: MIrc -> IO (Either IOError MIrc) -reconnect mServer = try $ do - server <- readMVar mServer - +reconnect mIrc = try $ do + server <- readMVar mIrc + h <- connectTo (B.unpack $ sAddr server) (PortNumber $ fromIntegral $ sPort server) hSetBuffering h NoBuffering - modifyMVar_ mServer (\s -> return $ s {sSock = Just h}) + modifyMVar_ mIrc (\s -> return $ s {sSock = Just h}) -- Initialize connection with the server - withMVar mServer greetServer + _ <- withMVar mIrc greetServer -- Restart the listen loop. - listenId <- forkIO (listenLoop mServer) - cmdId <- forkIO (execCmdsLoop mServer) - modifyMVar_ mServer (\s -> return $ s {sListenThread = Just listenId, + listenId <- forkIO (listenLoop mIrc) + cmdId <- forkIO (execCmdsLoop mIrc) + modifyMVar_ mIrc (\s -> return $ s {sListenThread = Just listenId, sCmdThread = Just cmdId}) - return mServer + return mIrc {- -- |Reconnects to the server. reconnect :: MIrc -> IO (Either IOError MIrc) reconnect server = do s <- readMVar server - - let conf = IrcConfig (B.unpack $ sAddr s) (sPort s) - (B.unpack $ sNickname s) (B.unpack $ sUsername s) - (B.unpack $ sRealname s) (map (B.unpack) (sChannels s)) + + let conf = IrcConfig (B.unpack $ sAddr s) (sPort s) + (B.unpack $ sNickname s) (B.unpack $ sUsername s) + (B.unpack $ sRealname s) (map (B.unpack) (sChannels s)) (elems $ sEvents s) (sCTCPVersion s) (sCTCPTime s) connect conf True (sDebug s) -} @@ -217,19 +222,20 @@ return (u, e) genUniqueMap :: [IrcEvent] -> IO (Map.Map Unique IrcEvent) -genUniqueMap events = do - uEvents <- mapM genUnique events +genUniqueMap evts = do + uEvents <- mapM genUnique evts return $ Map.fromList uEvents toServer :: IrcConfig -> Handle -> Chan SIrcCommand -> Bool -> IO IrcServer toServer config h cmdChan debug = do uniqueEvents <- genUniqueMap $ internalNormEvents ++ cEvents config + now <- getCurrentTime return $ IrcServer (B.pack $ cAddr config) (cPort config) - (B.pack $ cNick config) (B.pack `fmap` cPass config) (B.pack $ cUsername config) - (B.pack $ cRealname config) (map B.pack $ cChannels config) + (B.pack $ cNick config) (B.pack `fmap` cPass config) (B.pack $ cUsername config) + (B.pack $ cRealname config) (map B.pack $ cChannels config) uniqueEvents (Just h) Nothing Nothing cmdChan debug - (cCTCPVersion config) (cCTCPTime config) (cPingTimeoutInterval config) + (cCTCPVersion config) (cCTCPTime config) (cPingTimeoutInterval config) now greetServer :: IrcServer -> IO IrcServer greetServer server = do @@ -239,7 +245,7 @@ write server $ "NICK " `B.append` nick write server $ "USER " `B.append` user `B.append` " " `B.append` user `B.append` " " `B.append` addr `B.append` " :" `B.append` real - + return server where nick = sNickname server mpass = sPassword server @@ -252,14 +258,14 @@ server <- readMVar mIrc cmd <- readChan $ sCmdChan server case cmd of (SIrcAddEvent uEvent) -> do - swapMVar mIrc (server {sEvents = - (uncurry Map.insert uEvent) (sEvents server)}) + _ <- swapMVar mIrc (server {sEvents = + (uncurry Map.insert uEvent) (sEvents server)}) execCmdsLoop mIrc - (SIrcChangeEvents events) -> do - swapMVar mIrc (server {sEvents = events}) + (SIrcChangeEvents evts) -> do + _ <- swapMVar mIrc (server {sEvents = evts}) execCmdsLoop mIrc (SIrcRemoveEvent key) -> do - swapMVar mIrc (server {sEvents = + _ <- swapMVar mIrc (server {sEvents = Map.delete key (sEvents server)}) execCmdsLoop mIrc @@ -270,39 +276,38 @@ let h = fromJust $ sSock server eof <- timeout (sPingTimeoutInterval server) $ hIsEOF h - + -- If EOF then we are disconnected if (eof /= Just False) then do - let comp = (\a -> a `eqEvent` (Disconnect undefined)) - events = Map.filter comp (sEvents server) - eventCall = (\obj -> (eventFuncD $ snd obj) s) modifyMVar_ s (\serv -> return $ serv {sSock = Nothing}) - debugWrite server $ B.pack $ show $ length $ Map.toList events - mapM_ eventCall (Map.toList events) + Foldable.mapM_ (callDisconnectFunction s) (sEvents server) else do line <- B.hGetLine h - + server1 <- takeMVar s - + -- Print the received line. debugWrite server1 $ (B.pack ">> ") `B.append` line - + -- Call the internal events newServ <- foldM (\sr f -> f sr (parse line)) server1 internalEvents - + putMVar s newServ -- Put the MVar back. - + let parsed = (parse line) -- Call the events callEvents s parsed -- Call the RawMsg Events. events s (RawMsg undefined) parsed - + listenLoop s - + where + callDisconnectFunction mIrc (Disconnect f) = f mIrc + callDisconnectFunction _ _ = return () + -- Internal Events - They can edit the server joinChans :: IrcServer -> IrcMessage -> IO IrcServer joinChans server msg = @@ -310,8 +315,7 @@ then do mapM_ (\chan -> write server $ "JOIN " `B.append` chan) (sChannels server) return server {sChannels = []} else return server - where h = fromJust $ sSock server - code = mCode msg + where code = mCode msg pong :: IrcServer -> IrcMessage -> IO IrcServer pong server msg = @@ -320,9 +324,8 @@ write server $ "PONG :" `B.append` pingMsg return server else return server - - where h = fromJust $ sSock server - pingMsg = mMsg msg + + where pingMsg = mMsg msg code = mCode msg trackChanges :: IrcServer -> IrcMessage -> IO IrcServer @@ -338,21 +341,21 @@ newNick = mMsg msg if nick == sNickname server then return server { sNickname = newNick } - else return server - | code == "KICK" = do + else return server + | code == "KICK" = do let nick = (fromJust $ mOther msg) !! 0 chan = fromJust $ mChan msg if nick == sNickname server then return server { sChannels = delete chan (sChannels server) } else return server - | code == "PART" = do + | code == "PART" = do let nick = fromJust $ mNick msg chan = mMsg msg if nick == sNickname server then return server { sChannels = delete chan (sChannels server) } else return server | otherwise = return server - + where code = mCode msg -- Internal normal events @@ -360,21 +363,20 @@ ctcpHandler mServ iMsg | msg == "\x01VERSION\x01" = do server <- readMVar mServ - + sendCmd mServ (MNotice origin ("\x01VERSION " `B.append` B.pack (sCTCPVersion server) `B.append` "\x01")) | msg == "\x01TIME\x01" = do server <- readMVar mServ - + time <- sCTCPTime server sendCmd mServ (MNotice origin ("\x01TIME " `B.append` (B.pack time) `B.append` "\x01")) | "\x01PING " `B.isPrefixOf` msg = do - server <- readMVar mServ - + sendCmd mServ (MNotice origin msg) @@ -386,23 +388,23 @@ events mServ event msg = do server <- readMVar mServ let comp = (`eqEvent` event) - events = Map.filter comp (sEvents server) + evts = Map.filter comp (sEvents server) eventCall = (\obj -> (eventFunc $ snd obj) mServ msg) - mapM_ eventCall (Map.toList events) + mapM_ eventCall (Map.toList evts) callEvents :: MIrc -> IrcMessage -> IO () callEvents mServ msg | mCode msg == "PRIVMSG" = events mServ (Privmsg undefined) msg - + | mCode msg == "PING" = events mServ (Ping undefined) msg | mCode msg == "JOIN" = events mServ (Join undefined) msg - + | mCode msg == "PART" = events mServ (Part undefined) msg @@ -429,10 +431,11 @@ | B.all isNumber (mCode msg) = events mServ (Numeric undefined) msg - + | otherwise = return () - + +eqEvent :: IrcEvent -> IrcEvent -> Bool (Privmsg _) `eqEvent` (Privmsg _) = True (Numeric _) `eqEvent` (Numeric _) = True (Ping _) `eqEvent` (Ping _) = True @@ -463,8 +466,7 @@ eventFunc (Nick f) = f eventFunc (Notice f) = f eventFunc (RawMsg f) = f - -eventFuncD (Disconnect f) = f +eventFunc (Disconnect _) = error "SimpleIRC: unexpected event" -- |Sends a raw command to the server sendRaw :: MIrc -> B.ByteString -> IO () @@ -474,18 +476,24 @@ -- |Sends a message to a channel --- |Please note: As of now this function doesn't provide flood control. --- So be careful with \\n. -sendMsg :: MIrc +-- |Implements flood control according to RFC 2813, chapter 5.8 +sendMsg :: MIrc -> B.ByteString -- ^ Channel -> B.ByteString -- ^ Message -> IO () sendMsg mServ chan msg = mapM_ s lins where lins = B.lines msg - s m = sendCmd mServ (MPrivmsg chan m) - - + s m = do + now <- getCurrentTime + stamp <- (getFloodControlTimestamp mServ) + let latest = addUTCTime 2 $ max now stamp + diff = diffUTCTime latest now + setFloodControlTimestamp mServ latest + when (diff > 10) (threadDelay $ 1000000 * (round diff - 10)) + sendCmd mServ (MPrivmsg chan m) + + sendCmd :: MIrc -> Command -- Command to send -> IO () @@ -501,10 +509,10 @@ changeEvents :: MIrc -> [IrcEvent] -> IO () -changeEvents mIrc events = do +changeEvents mIrc evts = do s <- readMVar mIrc - uniqueEvents <- genUniqueMap events + uniqueEvents <- genUniqueMap evts writeChan (sCmdChan s) (SIrcChangeEvents uniqueEvents) remEvent :: MIrc -> Unique -> IO () @@ -522,60 +530,73 @@ debugWrite s $ "<< " `B.append` msg `B.append` "\\r\\n" B.hPutStr h (msg `B.append` "\r\n") where h = fromJust $ sSock s - -defaultConfig = IrcConfig - { cPort = 6667 +mkDefaultConfig :: String -> String -> IrcConfig +mkDefaultConfig addr nick = IrcConfig + { cAddr = addr + , cPort = 6667 + , cNick = nick , cPass = Nothing , cUsername = "simpleirc" , cRealname = "SimpleIRC Bot" , cChannels = [] , cEvents = [] - , cCTCPVersion = "SimpleIRC v0.2" + , cCTCPVersion = "SimpleIRC v0.3" , cCTCPTime = fmap (formatTime defaultTimeLocale "%c") getZonedTime - , cPingTimeoutInterval = 350 * 10^6 + , cPingTimeoutInterval = 350 * 10^(6::Int) } - + -- MIrc Accessors -- |Returns a list of channels currently joined. getChannels :: MIrc -> IO [B.ByteString] getChannels mIrc = do s <- readMVar mIrc - + return $ sChannels s -- |Returns the current nickname. getNickname :: MIrc -> IO B.ByteString getNickname mIrc = do s <- readMVar mIrc - + return $ sNickname s - + -- |Returns the address getAddress :: MIrc -> IO B.ByteString getAddress mIrc = do s <- readMVar mIrc - - return $ sAddr s + return $ sAddr s + -- |Returns the address getPort :: MIrc -> IO Int getPort mIrc = do s <- readMVar mIrc - + return $ sPort s -- |Returns the User name getUsername :: MIrc -> IO B.ByteString getUsername mIrc = do s <- readMVar mIrc - - return $ sUsername s + return $ sUsername s + -- |Returns the Real name getRealname :: MIrc -> IO B.ByteString getRealname mIrc = do s <- readMVar mIrc - - return $ sRealname s + return $ sRealname s + +-- |Returns the timestamp of the last sent message, possibly with flood control penalty +getFloodControlTimestamp :: MIrc -> IO UTCTime +getFloodControlTimestamp mIrc = do + s <- readMVar mIrc + + return $ sFloodControlTimestamp s + +-- |Updates the value of the flood control timestamp +setFloodControlTimestamp :: MIrc -> UTCTime -> IO () +setFloodControlTimestamp mIrc stamp = + modifyMVar_ mIrc (\i -> return i { sFloodControlTimestamp = stamp }) diff --git a/Network/SimpleIRC/Messages.hs b/Network/SimpleIRC/Messages.hs --- a/Network/SimpleIRC/Messages.hs +++ b/Network/SimpleIRC/Messages.hs @@ -17,10 +17,8 @@ , showCommand ) where -import Data.Maybe import qualified Data.ByteString.Char8 as B -import Control.Arrow -import Control.Applicative +import Control.Arrow hiding (first) import Data.Typeable -- PING :asimov.freenode.net @@ -33,9 +31,9 @@ -- :asimov.freenode.net 332 haskellTestBot #() :Parenthesis -- :asimov.freenode.net 333 haskellTestBot #() Raynes!~macr0@unaffiliated/raynes 1281221819 - -data Command = Command - | MPrivmsg B.ByteString B.ByteString -- ^ PRIVMSG #chan :msg + +data Command = + MPrivmsg B.ByteString B.ByteString -- ^ PRIVMSG #chan :msg | MJoin B.ByteString (Maybe B.ByteString) -- ^ JOIN #chan key | MPart B.ByteString B.ByteString -- ^ PART #chan :msg | MMode B.ByteString B.ByteString (Maybe B.ByteString) -- ^ MODE #chan +o user @@ -63,27 +61,28 @@ -- |Parse a raw IRC message parse :: B.ByteString -> IrcMessage -parse txt = - case length split of - 2 -> parse2 split noCarriage - 3 -> parse3 split noCarriage - 4 -> parse4 split noCarriage - 5 -> parse5 split noCarriage - _ -> parseOther split noCarriage - +parse txt = + case split of + [code, msg] -> parse2 code msg noCarriage + [first, code, msg] -> parse3 first code msg noCarriage + [first, code, chan, msg] -> parse4 first code chan msg noCarriage + [first, code, chan, other, msg] -> parse5 first code chan other msg noCarriage + server:code:nick:chan:other -> parseOther server code nick chan other noCarriage + _ -> error "SimpleIRC: unexpected message format" + where noCarriage = takeCarriageRet txt split = smartSplit noCarriage -- Nick, Host, Server parseFirst :: B.ByteString -> (Maybe B.ByteString, Maybe B.ByteString, Maybe B.ByteString, Maybe B.ByteString) -parseFirst first = +parseFirst first = if '!' `B.elem` first then let (nick, user_host) = B.break (== '!') (dropColon first) in if '@' `B.elem` user_host then let (user, host) = second B.tail $ B.break (== '@') $ B.tail user_host in (Just nick, Just user, Just host, Nothing) else (Just nick, Nothing, Just user_host, Nothing) - else (Nothing, Nothing, Nothing, Just $ dropColon first) + else (Nothing, Nothing, Nothing, Just $ dropColon first) getOrigin :: Maybe B.ByteString -> B.ByteString -> B.ByteString getOrigin (Just nick) chan = @@ -93,39 +92,56 @@ else nick getOrigin Nothing chan = chan -parse2 :: [B.ByteString] -> B.ByteString -> IrcMessage -parse2 (code:msg:_) = +parse2 :: B.ByteString -> B.ByteString -> B.ByteString -> IrcMessage +parse2 code msg = IrcMessage Nothing Nothing Nothing Nothing code (dropColon msg) Nothing Nothing Nothing - -parse3 :: [B.ByteString] -> B.ByteString -> IrcMessage -parse3 (first:code:msg:_) = + +parse3 :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -> IrcMessage +parse3 first code msg = let (nick, user, host, server) = parseFirst first in IrcMessage nick user host server code (dropColon msg) Nothing Nothing Nothing - -parse4 :: [B.ByteString] -> B.ByteString -> IrcMessage -parse4 (first:code:chan:msg:_) = + +parse4 :: B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> IrcMessage +parse4 first code chan msg = let (nick, user, host, server) = parseFirst first in IrcMessage nick user host server code (dropColon msg) (Just chan) (Just $ getOrigin nick chan) Nothing -parse5 :: [B.ByteString] -> B.ByteString -> IrcMessage -parse5 (first:code:chan:other:msg:_) = +parse5 :: B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> IrcMessage +parse5 first code chan other msg = let (nick, user, host, server) = parseFirst first in IrcMessage nick user host server code (dropColon msg) (Just chan) (Just $ getOrigin nick chan) (Just [other]) -parseOther :: [B.ByteString] -> B.ByteString -> IrcMessage -parseOther (server:code:nick:chan:other) = +parseOther :: B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> [B.ByteString] + -> B.ByteString + -> IrcMessage +parseOther server code nick chan other = IrcMessage (Just nick) Nothing Nothing (Just server) code (B.unwords other) (Just chan) (Just $ getOrigin (Just nick) chan) (Just other) smartSplit :: B.ByteString -> [B.ByteString] -smartSplit txt = +smartSplit txt = case B.breakSubstring (B.pack " :") (dropColon txt) of - (x,y) | B.null y -> + (x,y) | B.null y -> B.words txt - | otherwise -> + | otherwise -> let (_, msg) = B.break (== ':') y in B.words x ++ [msg] @@ -133,7 +149,7 @@ takeLast xs = B.take (B.length xs - 1) xs takeCarriageRet :: B.ByteString -> B.ByteString -takeCarriageRet xs = +takeCarriageRet xs = if B.drop (B.length xs - 1) xs == B.pack "\r" then takeLast xs else xs @@ -147,10 +163,10 @@ showCommand :: Command -> B.ByteString showCommand (MPrivmsg chan msg) = "PRIVMSG " `B.append` chan `B.append` " :" `B.append` msg -showCommand (MJoin chan (Just key)) = "JOIN " `B.append` chan `B.append` +showCommand (MJoin chan (Just key)) = "JOIN " `B.append` chan `B.append` " " `B.append` key showCommand (MJoin chan Nothing) = "JOIN " `B.append` chan -showCommand (MPart chan msg) = "PART " `B.append` chan `B.append` +showCommand (MPart chan msg) = "PART " `B.append` chan `B.append` " :" `B.append` msg showCommand (MMode chan mode (Just usr)) = "MODE " `B.append` chan `B.append` " " `B.append` mode `B.append` @@ -170,6 +186,6 @@ showCommand (MNotice chan msg) = "NOTICE " `B.append` chan `B.append` " :" `B.append` msg showCommand (MAction chan msg) = showCommand $ MPrivmsg chan - ("\x01 ACTION " `B.append` msg + ("\x01ACTION " `B.append` msg `B.append` "\x01") diff --git a/simpleirc.cabal b/simpleirc.cabal --- a/simpleirc.cabal +++ b/simpleirc.cabal @@ -1,5 +1,5 @@ Name: simpleirc -Version: 0.2.1 +Version: 0.3.0 Category: Network, IRC Synopsis: Simple IRC Library Maintainer: Dominik Picheta @@ -10,7 +10,7 @@ Homepage: http://github.com/dom96/SimpleIRC Build-type: Simple Stability: provisional -Cabal-version: >= 1.6 +Cabal-version: >= 1.8 Description: Simple IRC Library. This IRC Library aims to be simple and lightweight. @@ -21,7 +21,7 @@ Source-repository this Type: git Location: git://github.com/dom96/SimpleIRC.git - tag: v0.2.1 + tag: v0.3.0 Library Build-depends: @@ -35,3 +35,23 @@ Network.SimpleIRC Network.SimpleIRC.Core Network.SimpleIRC.Messages + ghc-options: + -Wall + +test-suite spec + type: + exitcode-stdio-1.0 + ghc-options: + -Wall -Werror + cpp-options: + -DTEST + hs-source-dirs: + ., tests + main-is: + Spec.hs + build-depends: + base + , bytestring + , hspec + , HUnit + , knob diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import Test.Hspec.Monadic +import qualified CoreSpec + +main :: IO () +main = hspecX $ do + describe "Core" CoreSpec.spec