diff --git a/Network/SimpleIRC.hs b/Network/SimpleIRC.hs --- a/Network/SimpleIRC.hs +++ b/Network/SimpleIRC.hs @@ -15,15 +15,9 @@ -- * Messages , module Network.SimpleIRC.Messages - - -- * Utils - , module Network.SimpleIRC.Utils - - -- * Types - , module Network.SimpleIRC.Types + + ) where import Network.SimpleIRC.Core import Network.SimpleIRC.Messages -import Network.SimpleIRC.Utils -import Network.SimpleIRC.Types diff --git a/Network/SimpleIRC/Core.hs b/Network/SimpleIRC/Core.hs --- a/Network/SimpleIRC/Core.hs +++ b/Network/SimpleIRC/Core.hs @@ -11,8 +11,14 @@ {-# LANGUAGE OverloadedStrings #-} module Network.SimpleIRC.Core ( + -- * Types + MIrc + , EventFunc + , IrcConfig(..) + , IrcEvent(..) + -- * Functions - connect + , connect , disconnect , sendRaw , sendMsg @@ -21,6 +27,16 @@ , changeEvents , remEvent , defaultConfig + + -- * Utils + , getDest + + -- * Accessors + , getChannels + , getNickname + , getAddress + , getUsername + , getRealname ) where import Network @@ -30,9 +46,8 @@ import Control.Monad import Control.Concurrent import Control.Concurrent.Chan +import Control.Concurrent.MVar import Network.SimpleIRC.Messages -import Network.SimpleIRC.Types -import Network.SimpleIRC.Utils import Data.Unique import System.IO.Error import Data.Time @@ -43,15 +58,90 @@ internalEvents = [joinChans, pong, onJoin] internalNormEvents = [Privmsg ctcpHandler] +type MIrc = MVar IrcServer + +data IrcConfig = IrcConfig + { cAddr :: String -- ^ Server address to connect to + , cPort :: Int -- ^ Server port to connect to + , cNick :: String -- ^ Nickname + , cUsername :: String -- ^ Username + , cRealname :: String -- ^ Realname + , cChannels :: [String] -- ^ List of channels to join on connect + , cEvents :: [IrcEvent] -- ^ Events to bind + , cCTCPVersion :: String -- ^ What to send on CTCP VERSION + , cCTCPTime :: IO String -- ^ What to send on CTCP TIME + } + +data SIrcCommand = + SIrcAddEvent (Unique, IrcEvent) + | SIrcChangeEvents (Map.Map Unique IrcEvent) + | SIrcRemoveEvent Unique + +data IrcServer = IrcServer + { sAddr :: B.ByteString + , sPort :: Int + , sNickname :: B.ByteString + , sUsername :: B.ByteString + , sRealname :: B.ByteString + , sChannels :: [B.ByteString] + , sEvents :: Map.Map Unique IrcEvent + , sSock :: Maybe Handle + , sListenThread :: Maybe ThreadId + , sCmdThread :: Maybe ThreadId + , sCmdChan :: Chan SIrcCommand + , sDebug :: Bool + -- Other info + , sCTCPVersion :: String + , sCTCPTime :: IO String + } + +-- When adding events here, remember add them in callEvents and in eventFunc +-- AND also in the Show instance and Eq instance + +data IrcEvent = + Privmsg EventFunc -- ^ PRIVMSG + | Numeric EventFunc -- ^ Numeric, 001, 002, 372 etc. + | Ping EventFunc -- ^ PING + | Join EventFunc -- ^ JOIN + | Part EventFunc -- ^ PART + | Mode EventFunc -- ^ MODE + | Topic EventFunc -- ^ TOPIC + | Invite EventFunc -- ^ INVITE + | Kick EventFunc -- ^ KICK + | Quit EventFunc -- ^ QUIT + | Nick EventFunc -- ^ NICK + | Notice EventFunc -- ^ NOTICE + | RawMsg EventFunc -- ^ This event gets called on every message received + | Disconnect (IrcServer -> 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" + show (Ping _) = "IrcEvent - Ping" + show (Join _) = "IrcEvent - Join" + show (Part _) = "IrcEvent - Part" + show (Mode _) = "IrcEvent - Mode" + show (Topic _) = "IrcEvent - Topic" + show (Invite _) = "IrcEvent - Invite" + show (Kick _) = "IrcEvent - Kick" + show (Quit _) = "IrcEvent - Quit" + show (Nick _) = "IrcEvent - Nick" + show (Notice _) = "IrcEvent - Notice" + show (RawMsg _) = "IrcEvent - RawMsg" + show (Disconnect _) = "IrcEvent - Disconnect" + +type EventFunc = (MIrc -> IrcMessage -> IO ()) + -- |Connects to a server connect :: IrcConfig -- ^ Configuration -> Bool -- ^ Run in a new thread -> Bool -- ^ Print debug messages - -> IO (Either IOError IrcServer) -- ^ IrcServer instance + -> IO (Either IOError MIrc) -- ^ IrcServer instance connect config threaded debug = try $ do - if debug - then B.putStrLn $ "Connecting to " `B.append` (B.pack $ cAddr config) - else return () + (when debug $ + B.putStrLn $ "Connecting to " `B.append` B.pack (cAddr config)) + h <- connectTo (cAddr config) (PortNumber $ fromIntegral $ cPort config) hSetBuffering h NoBuffering @@ -61,21 +151,28 @@ -- Initialize connection with the server greetServer server - -- Start listening + -- Create a new MVar + res <- newMVar server + + -- Start the loops, listen and exec cmds if threaded - then do listenId <- forkIO (listenLoop server) - return server {sListenThread = Just listenId} - else do listenLoop server - return server - + then do listenId <- forkIO (listenLoop res) + cmdId <- forkIO (execCmdsLoop res) + modifyMVar_ res (\srv -> return $ srv {sListenThread = Just listenId}) + return res + else do listenLoop res + return res + -- |Sends a QUIT command to the server. -disconnect :: IrcServer +disconnect :: MIrc -> B.ByteString -- ^ Quit message -> IO () disconnect server quitMsg = do - write server $ "QUIT :" `B.append` quitMsg + s <- readMVar server + + let h = fromJust $ sSock s + write s $ "QUIT :" `B.append` quitMsg return () - where h = fromJust $ sSock server genUnique :: IrcEvent -> IO (Unique, IrcEvent) genUnique e = do @@ -89,12 +186,12 @@ toServer :: IrcConfig -> Handle -> Chan SIrcCommand -> Bool -> IO IrcServer toServer config h cmdChan debug = do - uniqueEvents <- genUniqueMap $ internalNormEvents ++ (cEvents config) + uniqueEvents <- genUniqueMap $ internalNormEvents ++ cEvents config return $ IrcServer (B.pack $ cAddr config) (cPort config) (B.pack $ cNick config) (B.pack $ cUsername config) (B.pack $ cRealname config) (map B.pack $ cChannels config) - uniqueEvents (Just h) Nothing cmdChan debug + uniqueEvents (Just h) Nothing Nothing cmdChan debug (cCTCPVersion config) (cCTCPTime config) greetServer :: IrcServer -> IO IrcServer @@ -109,54 +206,70 @@ real = sRealname server addr = sAddr server --- TODO: I think this should execute all commands that are available. -execCmds :: IrcServer -> IO IrcServer -execCmds server = do - empty <- isEmptyChan $ sCmdChan server - if not $ empty - then do cmd <- readChan $ sCmdChan server - case cmd of (SIrcAddEvent uEvent) -> return server {sEvents = Map.insert (fst uEvent) (snd uEvent) (sEvents server)} - (SIrcChangeEvents events) -> return server {sEvents = events} - (SIrcRemoveEvent key) -> return server {sEvents = Map.delete key (sEvents server)} - else return server +execCmdsLoop :: MIrc -> IO () +execCmdsLoop mIrc = do + server <- readMVar mIrc + cmd <- readChan $ sCmdChan server + case cmd of (SIrcAddEvent uEvent) -> do + swapMVar mIrc (server {sEvents = + (uncurry Map.insert uEvent) (sEvents server)}) + execCmdsLoop mIrc + (SIrcChangeEvents events) -> do + swapMVar mIrc (server {sEvents = events}) + execCmdsLoop mIrc + (SIrcRemoveEvent key) -> do + swapMVar mIrc (server {sEvents = + Map.delete key (sEvents server)}) + execCmdsLoop mIrc -listenLoop :: IrcServer -> IO () + +listenLoop :: MIrc -> IO () listenLoop s = do - server <- execCmds s + server <- readMVar s let h = fromJust $ sSock server eof <- hIsEOF h + -- If EOF then we are disconnected if eof then do let comp = (\a -> a `eqEvent` (Disconnect undefined)) events = Map.filter comp (sEvents server) eventCall = (\obj -> (eventFuncD $ snd obj) server) - debugWrite s $ B.pack $ show $ length $ Map.toList events - mapM eventCall (Map.toList events) - return () + debugWrite server $ B.pack $ show $ length $ Map.toList events + mapM_ eventCall (Map.toList events) else do line <- B.hGetLine h - debugWrite s $ (B.pack ">> ") `B.append` line - newServ <- foldM (\s f -> f s (parse line)) server internalEvents + server1 <- takeMVar s - callEvents newServ (parse line) + -- 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. + + -- Call the events + callEvents s (parse line) - listenLoop newServ + + + listenLoop s -- Internal Events - They can edit the server joinChans :: IrcServer -> IrcMessage -> IO IrcServer -joinChans server msg = do +joinChans server msg = if code == "001" - then do mapM (\chan -> write server $ "JOIN " `B.append` chan) (sChannels server) + 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 pong :: IrcServer -> IrcMessage -> IO IrcServer -pong server msg = do +pong server msg = if code == "PING" then do write server $ "PONG :" `B.append` pingMsg @@ -167,6 +280,7 @@ pingMsg = mMsg msg code = mCode msg +-- TODO: Nick and Channels tracking. KICK, PART and NICK. onJoin :: IrcServer -> IrcMessage -> IO IrcServer onJoin server msg | code == "JOIN" = do @@ -181,68 +295,83 @@ -- Internal normal events ctcpHandler :: EventFunc -ctcpHandler server iMsg - | msg == "\x01VERSION\x01" = - sendCmd server +ctcpHandler mServ iMsg + | msg == "\x01VERSION\x01" = do + server <- readMVar mServ + + chan <- getDest mServ iMsg + sendCmd mServ (MNotice chan ("\x01VERSION " `B.append` - (B.pack $ sCTCPVersion server) `B.append` "\x01")) + B.pack (sCTCPVersion server) `B.append` "\x01")) | msg == "\x01TIME\x01" = do + server <- readMVar mServ + time <- sCTCPTime server - sendCmd server + chan <- getDest mServ iMsg + sendCmd mServ (MNotice chan ("\x01TIME " `B.append` (B.pack time) `B.append` "\x01")) + | "\x01PING " `B.isPrefixOf` msg = do + server <- readMVar mServ + + chan <- getDest mServ iMsg + sendCmd mServ + (MNotice chan msg) + | otherwise = return () - where msg = mMsg iMsg - chan = getChan server iMsg + where msg = mMsg iMsg + -- Event code -events :: IrcServer -> IrcEvent -> IrcMessage -> IO () -events server event msg = do - mapM eventCall (Map.toList events) - return () - where comp = (\a -> a `eqEvent` event) - events = Map.filter comp (sEvents server) - eventCall = (\obj -> (eventFunc $ snd obj) server msg) +events :: MIrc -> IrcEvent -> IrcMessage -> IO () +events mServ event msg = do + server <- readMVar mServ + let comp = (`eqEvent` event) + events = Map.filter comp (sEvents server) + eventCall = (\obj -> (eventFunc $ snd obj) mServ msg) -callEvents :: IrcServer -> IrcMessage -> IO () -callEvents server msg - | mCode msg == "PRIVMSG" = do - events server (Privmsg undefined) msg + mapM_ eventCall (Map.toList events) + + +callEvents :: MIrc -> IrcMessage -> IO () +callEvents mServ msg + | mCode msg == "PRIVMSG" = + events mServ (Privmsg undefined) msg - | mCode msg == "PING" = do - events server (Ping undefined) msg + | mCode msg == "PING" = + events mServ (Ping undefined) msg - | mCode msg == "JOIN" = do - events server (Join undefined) msg + | mCode msg == "JOIN" = + events mServ (Join undefined) msg - | mCode msg == "PART" = do - events server (Part undefined) msg + | mCode msg == "PART" = + events mServ (Part undefined) msg - | mCode msg == "MODE" = do - events server (Mode undefined) msg + | mCode msg == "MODE" = + events mServ (Mode undefined) msg - | mCode msg == "TOPIC" = do - events server (Topic undefined) msg + | mCode msg == "TOPIC" = + events mServ (Topic undefined) msg - | mCode msg == "INVITE" = do - events server (Invite undefined) msg + | mCode msg == "INVITE" = + events mServ (Invite undefined) msg - | mCode msg == "KICK" = do - events server (Kick undefined) msg + | mCode msg == "KICK" = + events mServ (Kick undefined) msg - | mCode msg == "QUIT" = do - events server (Quit undefined) msg + | mCode msg == "QUIT" = + events mServ (Quit undefined) msg - | mCode msg == "NICK" = do - events server (Nick undefined) msg + | mCode msg == "NICK" = + events mServ (Nick undefined) msg - | mCode msg == "NOTICE" = do - events server (Notice undefined) msg + | mCode msg == "NOTICE" = + events mServ (Notice undefined) msg - | B.all isNumber (mCode msg) = do - events server (Numeric undefined) msg + | B.all isNumber (mCode msg) = + events mServ (Numeric undefined) msg - | otherwise = do - events server (RawMsg undefined) msg + | otherwise = + events mServ (RawMsg undefined) msg (Privmsg _) `eqEvent` (Privmsg _) = True (Numeric _) `eqEvent` (Numeric _) = True @@ -278,48 +407,55 @@ eventFuncD (Disconnect f) = f -- |Sends a raw command to the server -sendRaw :: IrcServer -> B.ByteString -> IO () -sendRaw server msg = write server msg +sendRaw :: MIrc -> B.ByteString -> IO () +sendRaw mServ msg = do + server <- readMVar mServ + write server msg -- |Sends a message to a channel -- |Please note: As of now this function doesn't provide flood control. --- So be careful. -sendMsg :: IrcServer +-- So be careful with \\n. +sendMsg :: MIrc -> B.ByteString -- ^ Channel -> B.ByteString -- ^ Message -> IO () -sendMsg server chan msg = do - mapM (s) lins - return () +sendMsg mServ chan msg = + mapM_ s lins where lins = B.lines msg - s m = sendCmd server (MPrivmsg chan m) -sendCmd :: IrcServer + s m = sendCmd mServ (MPrivmsg chan m) + + +sendCmd :: MIrc -> Command -- Command to send -> IO () -sendCmd server cmd = - sendRaw server (showCommand cmd) +sendCmd mServ cmd = sendRaw mServ (showCommand cmd) -addEvent :: IrcServer -> IrcEvent -> IO Unique -addEvent s event = do +addEvent :: MIrc -> IrcEvent -> IO Unique +addEvent mIrc event = do + s <- readMVar mIrc + u <- newUnique writeChan (sCmdChan s) (SIrcAddEvent (u, event)) return u -changeEvents :: IrcServer -> [IrcEvent] -> IO () -changeEvents s events = do + +changeEvents :: MIrc -> [IrcEvent] -> IO () +changeEvents mIrc events = do + s <- readMVar mIrc + uniqueEvents <- genUniqueMap events writeChan (sCmdChan s) (SIrcChangeEvents uniqueEvents) -remEvent :: IrcServer -> Unique -> IO () -remEvent s uniq = do +remEvent :: MIrc -> Unique -> IO () +remEvent mIrc uniq = do + s <- readMVar mIrc + writeChan (sCmdChan s) (SIrcRemoveEvent uniq) debugWrite :: IrcServer -> B.ByteString -> IO () -debugWrite s msg = do - if sDebug s - then B.putStrLn msg - else return () +debugWrite s msg = + (when (sDebug s) $ B.putStrLn msg) write :: IrcServer -> B.ByteString -> IO () write s msg = do @@ -334,7 +470,61 @@ , cRealname = "SimpleIRC Bot" , cChannels = [] , cEvents = [] - , cCTCPVersion = "SimpleIRC v0.1" - , cCTCPTime = getZonedTime >>= - (\t -> return $ formatTime defaultTimeLocale "%c" t) + , cCTCPVersion = "SimpleIRC v0.2" + , cCTCPTime = fmap (formatTime defaultTimeLocale "%c") getZonedTime } + +-- Utils + +-- |Gets the destination, i.e if the IrcMessage was sent +-- directly to you returns the senders nick otherwise the channel. +getDest :: MIrc -> IrcMessage -> IO B.ByteString +getDest mIrc m = do + s <- readMVar mIrc + + if sNickname s == chan + then return (fromJust $ mNick m) + else return chan + + where chan = fromJust $ mChan m + +-- MIrc Accessors +-- |Returns a list of channels currently joined. +-- +-- Currently this is not updated on KICK or PART. +getChannels :: MIrc -> IO [B.ByteString] +getChannels mIrc = do + s <- readMVar mIrc + + return $ sChannels s + +-- |Returns the current nickname. +-- +-- Currently this is not updated on NICK. +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 + +-- |Returns the User name +getUsername :: MIrc -> IO B.ByteString +getUsername mIrc = do + s <- readMVar mIrc + + return $ sUsername s + +-- |Returns the Real name +getRealname :: MIrc -> IO B.ByteString +getRealname mIrc = do + s <- readMVar mIrc + + return $ sRealname s + diff --git a/Network/SimpleIRC/Messages.hs b/Network/SimpleIRC/Messages.hs --- a/Network/SimpleIRC/Messages.hs +++ b/Network/SimpleIRC/Messages.hs @@ -7,18 +7,20 @@ -- Stability : provisional -- Portability : portable -- --- Messages module +-- Messages (parsing) module -- -{-# LANGUAGE OverloadedStrings #-} -module Network.SimpleIRC.Messages - ( Command(..) +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} +module Network.SimpleIRC.Messages + ( IrcMessage(..) + , Command(..) , parse - , showCommand - ) + , showCommand + ) where import Data.Maybe -import Network.SimpleIRC.Types import qualified Data.ByteString.Char8 as B +import Control.Arrow +import Data.Typeable -- PING :asimov.freenode.net -- :haskellTestBot!~test@host86-177-151-242.range86-177.btcentralplus.com JOIN :#() @@ -30,89 +32,106 @@ -- :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 - | 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 - | MTopic B.ByteString (Maybe B.ByteString) -- ^ TOPIC #chan :topic - | MInvite B.ByteString B.ByteString -- ^ INVITE user #chan - | MKick B.ByteString B.ByteString B.ByteString -- ^ KICK #chan user :msg - | MQuit B.ByteString -- ^ QUIT :msg - | MNick B.ByteString -- ^ NICK newnick - | MNotice B.ByteString B.ByteString -- ^ NOTICE usr/#chan :msg - | MAction B.ByteString B.ByteString -- ^ PRIVMSG usr/#chan :\\x01ACTION msg\\x01 + | 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 + | MTopic B.ByteString (Maybe B.ByteString) -- ^ TOPIC #chan :topic + | MInvite B.ByteString B.ByteString -- ^ INVITE user #chan + | MKick B.ByteString B.ByteString B.ByteString -- ^ KICK #chan user :msg + | MQuit B.ByteString -- ^ QUIT :msg + | MNick B.ByteString -- ^ NICK newnick + | MNotice B.ByteString B.ByteString -- ^ NOTICE usr/#chan :msg + | MAction B.ByteString B.ByteString -- ^ PRIVMSG usr/#chan :ACTION msg deriving (Eq, Read, Show) +data IrcMessage = IrcMessage + { mNick :: Maybe B.ByteString + , mUser :: Maybe B.ByteString + , mHost :: Maybe B.ByteString + , mServer :: Maybe B.ByteString + , mCode :: B.ByteString + , mMsg :: B.ByteString + , mChan :: Maybe B.ByteString + , mOther :: Maybe [B.ByteString] + , mRaw :: B.ByteString + } deriving (Show, Typeable) + -- |Parse a raw IRC message parse :: B.ByteString -> IrcMessage parse txt = - case length split of 2 -> (parse2 split) txt - 3 -> (parse3 split) txt - 4 -> (parse4 split) txt - 5 -> (parse5 split) txt - otherwise -> (parseOther split) txt - + case length split of + 2 -> parse2 split txt + 3 -> parse3 split txt + 4 -> parse4 split txt + 5 -> parse5 split txt + _ -> parseOther split txt + where split = smartSplit (takeCarriageRet txt) -parse4 :: [B.ByteString] -> (B.ByteString -> IrcMessage) -parse4 (first:code:chan:msg:_) = - let (nick, host, server) = parseFirst first - in IrcMessage nick host server (code) - (dropColon msg) (Just chan) Nothing - -- Nick, Host, Server -parseFirst :: B.ByteString -> (Maybe B.ByteString, Maybe B.ByteString, Maybe B.ByteString) +parseFirst :: B.ByteString -> (Maybe B.ByteString, Maybe B.ByteString, Maybe B.ByteString, Maybe B.ByteString) parseFirst first = if '!' `B.elem` first - then let (nick, host) = B.break (== '!') (dropColon first) - in (Just nick, Just host, Nothing) - else (Nothing, Nothing, Just $ dropColon first) - -dropColon :: B.ByteString -> B.ByteString -dropColon xs = - if B.take 1 xs == (B.pack ":") - then B.drop 1 xs - else xs + 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) -parse2 :: [B.ByteString] -> (B.ByteString -> IrcMessage) +parse2 :: [B.ByteString] -> B.ByteString -> IrcMessage parse2 (code:msg:_) = - IrcMessage Nothing Nothing Nothing (code) + IrcMessage Nothing Nothing Nothing Nothing code (dropColon msg) Nothing Nothing -parse3 :: [B.ByteString] -> (B.ByteString -> IrcMessage) +parse3 :: [B.ByteString] -> B.ByteString -> IrcMessage parse3 (first:code:msg:_) = - let (nick, host, server) = parseFirst first - in IrcMessage nick host server (code) (dropColon msg) Nothing Nothing + let (nick, user, host, server) = parseFirst first + in IrcMessage nick user host server code (dropColon msg) Nothing Nothing -parse5 :: [B.ByteString] -> (B.ByteString -> IrcMessage) +parse4 :: [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) Nothing + +parse5 :: [B.ByteString] -> B.ByteString -> IrcMessage parse5 (server:code:nick:chan:msg:_) = - IrcMessage (Just nick) Nothing (Just server) (code) + IrcMessage (Just nick) Nothing Nothing (Just server) code (dropColon msg) (Just chan) Nothing -parseOther :: [B.ByteString] -> (B.ByteString -> IrcMessage) +parseOther :: [B.ByteString] -> B.ByteString -> IrcMessage parseOther (server:code:nick:chan:other) = - IrcMessage (Just nick) Nothing (Just server) (code) + IrcMessage (Just nick) Nothing Nothing (Just server) code (B.unwords other) (Just chan) (Just other) smartSplit :: B.ByteString -> [B.ByteString] -smartSplit txt - | ':' `B.elem` (dropColon txt) = - let (first, msg) = B.break (== ':') (dropColon txt) - in (B.words $ takeLast first) ++ [msg] - | otherwise = B.words $ txt +smartSplit txt = + case B.breakSubstring (B.pack " :") (dropColon txt) of + (x,y) | B.null y -> + B.words txt + | otherwise -> + let (_, msg) = B.break (== ':') y + in B.words x ++ [msg] takeLast :: B.ByteString -> B.ByteString takeLast xs = B.take (B.length xs - 1) xs takeCarriageRet :: B.ByteString -> B.ByteString takeCarriageRet xs = - if B.drop (B.length xs - 1) xs == (B.pack "\r") + if B.drop (B.length xs - 1) xs == B.pack "\r" then takeLast xs else xs +dropColon :: B.ByteString -> B.ByteString +dropColon xs = + if B.take 1 xs == B.pack ":" + then B.drop 1 xs + else xs + showCommand :: Command -> B.ByteString showCommand (MPrivmsg chan msg) = "PRIVMSG " `B.append` chan `B.append` " :" `B.append` msg @@ -141,3 +160,4 @@ showCommand (MAction chan msg) = showCommand $ MPrivmsg chan ("\x01 ACTION " `B.append` msg `B.append` "\x01") + diff --git a/Network/SimpleIRC/Types.hs b/Network/SimpleIRC/Types.hs deleted file mode 100644 --- a/Network/SimpleIRC/Types.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Network.SimpleIRC.Types - ( - -- * Datatypes - IrcConfig(..) - , IrcServer(..) - , SIrcCommand(..) - , IrcEvent(..) - , EventFunc - , IrcMessage(..) - ) where -import qualified Data.ByteString.Char8 as B -import Control.Concurrent (ThreadId) -import Control.Concurrent.Chan (Chan) -import System.IO (Handle) -import Data.Unique (Unique) -import Data.Map (Map) -import Data.Typeable - -data IrcConfig = IrcConfig - { cAddr :: String -- ^ Server address to connect to - , cPort :: Int -- ^ Server port to connect to - , cNick :: String -- ^ Nickname - , cUsername :: String -- ^ Username - , cRealname :: String -- ^ Realname - , cChannels :: [String] -- ^ List of channels to join on connect - , cEvents :: [IrcEvent] -- ^ Events to bind - , cCTCPVersion :: String -- ^ What to send on CTCP VERSION - , cCTCPTime :: IO String -- ^ What to send on CTCP TIME - } - - -data SIrcCommand = - SIrcAddEvent (Unique, IrcEvent) - | SIrcChangeEvents (Map Unique IrcEvent) - | SIrcRemoveEvent Unique - -data IrcServer = IrcServer - { sAddr :: B.ByteString - , sPort :: Int - , sNickname :: B.ByteString - , sUsername :: B.ByteString - , sRealname :: B.ByteString - , sChannels :: [B.ByteString] - , sEvents :: Map Unique IrcEvent - , sSock :: Maybe Handle - , sListenThread :: Maybe ThreadId - , sCmdChan :: Chan SIrcCommand - , sDebug :: Bool - -- Other info - , sCTCPVersion :: String - , sCTCPTime :: IO String - } - -type EventFunc = (IrcServer -> IrcMessage -> IO ()) - --- When adding events here, remember add them in callEvents and in eventFunc --- AND also in the Show instance and Eq instance - -data IrcEvent = - Privmsg EventFunc -- ^ PRIVMSG - | Numeric EventFunc -- ^ Numeric, 001, 002, 372 etc. - | Ping EventFunc -- ^ PING - | Join EventFunc -- ^ JOIN - | Part EventFunc -- ^ PART - | Mode EventFunc -- ^ MODE - | Topic EventFunc -- ^ TOPIC - | Invite EventFunc -- ^ INVITE - | Kick EventFunc -- ^ KICK - | Quit EventFunc -- ^ QUIT - | Nick EventFunc -- ^ NICK - | Notice EventFunc -- ^ NOTICE - | RawMsg EventFunc -- ^ This event gets called on every message received - | Disconnect (IrcServer -> 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" - show (Ping _) = "IrcEvent - Ping" - show (Join _) = "IrcEvent - Join" - show (Part _) = "IrcEvent - Part" - show (Mode _) = "IrcEvent - Mode" - show (Topic _) = "IrcEvent - Topic" - show (Invite _) = "IrcEvent - Invite" - show (Kick _) = "IrcEvent - Kick" - show (Quit _) = "IrcEvent - Quit" - show (Nick _) = "IrcEvent - Nick" - show (Notice _) = "IrcEvent - Notice" - show (RawMsg _) = "IrcEvent - RawMsg" - show (Disconnect _) = "IrcEvent - Disconnect" - -data IrcMessage = IrcMessage - { mNick :: Maybe B.ByteString - , mHost :: Maybe B.ByteString - , mServer :: Maybe B.ByteString - , mCode :: B.ByteString - , mMsg :: B.ByteString - , mChan :: Maybe B.ByteString - , mOther :: Maybe [B.ByteString] - , mRaw :: B.ByteString - } deriving (Show, Typeable) - - - diff --git a/Network/SimpleIRC/Utils.hs b/Network/SimpleIRC/Utils.hs deleted file mode 100644 --- a/Network/SimpleIRC/Utils.hs +++ /dev/null @@ -1,29 +0,0 @@ --- | --- Module : Network.SimpleIRC.Core --- Copyright : (c) Dominik Picheta 2010 --- License : BSD3 --- --- Maintainer : morfeusz8@gmail.com --- Stability : provisional --- Portability : portable --- --- Utils module --- - -module Network.SimpleIRC.Utils - ( - -- * Functions - getChan - ) where -import Network.SimpleIRC.Types -import qualified Data.ByteString.Char8 as B -import Data.Maybe (fromJust) - --- |If the IrcMessage was sent directly to you returns the nick otherwise the channel. -getChan :: IrcServer -> IrcMessage -> B.ByteString -getChan s m = - if sNickname s == chan - then (fromJust $ mNick m) - else chan - - where chan = fromJust $ mChan m diff --git a/simpleirc.cabal b/simpleirc.cabal --- a/simpleirc.cabal +++ b/simpleirc.cabal @@ -1,8 +1,7 @@ Name: simpleirc -Version: 0.1.0 +Version: 0.2.0 Category: Network, IRC Synopsis: Simple IRC Library -Package-URL: http://code.haskell.org/fastirc/ Maintainer: Dominik Picheta Author: Dominik Picheta Copyright: (c) 2010 Dominik Picheta @@ -22,13 +21,13 @@ Source-repository this Type: git Location: git://github.com/dom96/SimpleIRC.git - tag: V0.1.0 + tag: v0.2.0 Library Build-depends: base >= 4 && < 5, bytestring >= 0.9.1.7, - network >= 2.2.1.7, + network >= 2.2.1.5, containers >= 0.3.0.0, time >= 1.1.4, old-locale >= 1.0.0.2 @@ -36,5 +35,3 @@ Network.SimpleIRC Network.SimpleIRC.Core Network.SimpleIRC.Messages - Network.SimpleIRC.Utils - Network.SimpleIRC.Types