├── .ghci ├── .gitignore ├── Setup.hs ├── tests ├── Spec.hs ├── disconnecttest.hs ├── testbot.hs ├── eventChangeTest.hs ├── channelNickTracking.hs └── CoreSpec.hs ├── Network ├── SimpleIRC.hs └── SimpleIRC │ ├── Sasl.hs │ ├── Messages.hs │ └── Core.hs ├── example └── example.hs ├── simpleirc.cabal ├── license └── readme.markdown /.ghci: -------------------------------------------------------------------------------- 1 | :set -itests -i. -DTEST 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | haddock/ 4 | dist/ 5 | 6 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main :: IO () 4 | main = defaultMain 5 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Hspec.Monadic 4 | import qualified CoreSpec 5 | 6 | main :: IO () 7 | main = hspecX $ do 8 | describe "Core" CoreSpec.spec 9 | -------------------------------------------------------------------------------- /Network/SimpleIRC.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Network.SimpleIRC 3 | -- Copyright : (c) Dominik Picheta 2010 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : morfeusz8@gmail.com 7 | -- Stability : Alpha 8 | -- Portability : portable 9 | -- 10 | -- Simple and efficient IRC Library 11 | -- 12 | module Network.SimpleIRC ( 13 | -- * Core 14 | module Network.SimpleIRC.Core 15 | 16 | -- * Messages 17 | , module Network.SimpleIRC.Messages 18 | 19 | 20 | ) where 21 | 22 | import Network.SimpleIRC.Core 23 | import Network.SimpleIRC.Messages 24 | -------------------------------------------------------------------------------- /example/example.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Network.SimpleIRC 3 | import Data.Maybe 4 | import qualified Data.ByteString.Char8 as B 5 | 6 | onMessage :: EventFunc 7 | onMessage s m 8 | | msg == "|hai" = do 9 | sendMsg s chan "hai thar!" 10 | | B.isPrefixOf "|say" msg = do 11 | sendMsg s chan (B.drop 1 $ B.dropWhile (/= ' ') msg) 12 | | otherwise = putStrLn $ show m 13 | where chan = fromJust $ mChan m 14 | msg = mMsg m 15 | 16 | events = [(Privmsg onMessage)] 17 | 18 | freenode = (mkDefaultConfig "irc.freenode.net" "SimpleIRCBot") 19 | { cChannels = ["#()"] -- Channels to join on connect 20 | , cEvents = events -- Events to bind 21 | } 22 | 23 | main = do 24 | connect freenode False True 25 | -------------------------------------------------------------------------------- /tests/disconnecttest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Network.SimpleIRC 3 | import Data.Maybe 4 | import Control.Concurrent.Chan 5 | import Control.Concurrent (threadDelay) 6 | import qualified Data.ByteString.Char8 as B 7 | 8 | onDisconnect :: MIrc -> IO () 9 | onDisconnect mIrc = do 10 | addr <- getAddress mIrc 11 | putStrLn $ "Disconnected from " ++ (B.unpack addr) 12 | m <- reconnect mIrc 13 | either (\err -> putStrLn $ "Unable to reconnect: " ++ show err) 14 | (\_ -> putStrLn "Successfully reconnected!") 15 | m 16 | 17 | events = [(Disconnect onDisconnect)] 18 | 19 | freenode = (mkDefaultConfig "irc.ninthbit.net" "SimpleIRCBot") 20 | { cChannels = ["#bots"], cEvents = events } 21 | 22 | main = do 23 | connect freenode True True 24 | waitForever 25 | where waitForever = do 26 | threadDelay 50000 27 | waitForever 28 | -------------------------------------------------------------------------------- /tests/testbot.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Network.SimpleIRC 3 | import Data.Maybe 4 | import qualified Data.ByteString.Char8 as B 5 | 6 | privmsgTest :: EventFunc 7 | privmsgTest s msg = do 8 | putStrLn $ show $ privmsg 9 | putStrLn $ show $ privmsg == "|test" 10 | if privmsg == "|test" || privmsg == "$kill" 11 | then sendMsg s origin ("DIE!") 12 | else return () 13 | where privmsg = mMsg msg 14 | origin = fromJust $ mOrigin msg 15 | 16 | quitMsg :: EventFunc 17 | quitMsg s msg 18 | | mMsg msg == "|quit" = do 19 | disconnect s "Bai!" 20 | | otherwise = return () 21 | 22 | events = [(Privmsg privmsgTest) 23 | ,(Privmsg quitMsg) 24 | ] 25 | 26 | freenode = (mkDefaultConfig "irc.freenode.net" "SimpleIRCBot") 27 | {cChannels = ["#()"], cEvents = events} 28 | 29 | main = do 30 | --connect freenode True True 31 | connect freenode False True 32 | -------------------------------------------------------------------------------- /tests/eventChangeTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Network.SimpleIRC 3 | import Data.Maybe 4 | import Control.Concurrent.Chan 5 | import qualified Data.ByteString.Char8 as B 6 | 7 | onMessage1 :: EventFunc 8 | onMessage1 s m 9 | | msg == "|change" = do 10 | changeEvents s [(Privmsg onMessage1)] 11 | | msg == "|set" = do 12 | changeEvents s events 13 | | otherwise = return () 14 | where msg = mMsg m 15 | 16 | onMessage :: EventFunc 17 | onMessage s m 18 | | msg == "|hai" = do 19 | sendMsg s chan "hai thar!" 20 | | B.isPrefixOf "|say" msg = do 21 | sendMsg s chan (B.drop 1 $ B.dropWhile (/= ' ') msg) 22 | | otherwise = return () 23 | where chan = fromJust $ mChan m 24 | msg = mMsg m 25 | 26 | events = [(Privmsg onMessage), (Privmsg onMessage1)] 27 | 28 | freenode = (mkDefaultConfig "irc.freenode.net" "SimpleIRCBot") { 29 | cChannels = ["#()"], -- Channels to join on connect 30 | cEvents = events -- Events to bind 31 | } 32 | 33 | main = do 34 | connect freenode False True 35 | -------------------------------------------------------------------------------- /tests/channelNickTracking.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Network.SimpleIRC 3 | import Data.Maybe 4 | import Control.Concurrent.Chan 5 | import qualified Data.ByteString.Char8 as B 6 | 7 | onMessage :: EventFunc 8 | onMessage s m 9 | | msg == "|hai" = do 10 | sendMsg s chan "hai thar!" 11 | | B.isPrefixOf "|say" msg = do 12 | sendMsg s chan (B.drop 1 $ B.dropWhile (/= ' ') msg) 13 | | msg == "|nick" = do 14 | sendCmd s (MNick "SimpleIRCBot1") 15 | | msg == "|nick?" = do 16 | nick <- getNickname s 17 | sendMsg s chan nick 18 | | msg == "|chans?" = do 19 | chans <- getChannels s 20 | sendMsg s chan (B.pack $ show chans) 21 | | msg == "|part" = do 22 | sendCmd s (MPart chan "BAI") 23 | | B.isPrefixOf "|join" msg = do 24 | sendCmd s (MJoin (B.drop 1 $ B.dropWhile (/= ' ') msg) Nothing) 25 | | otherwise = return () 26 | where chan = fromJust $ mChan m 27 | msg = mMsg m 28 | 29 | events = [(Privmsg onMessage)] 30 | 31 | freenode = (mkDefaultConfig "irc.freenode.net" "SimpleIRCBot") 32 | { cChannels = ["#()", "#HSBotTest"], cEvents = events} 33 | 34 | main = do 35 | connect freenode False True 36 | -------------------------------------------------------------------------------- /simpleirc.cabal: -------------------------------------------------------------------------------- 1 | Name: simpleirc 2 | Version: 0.3.1 3 | Category: Network, IRC 4 | Synopsis: Simple IRC Library 5 | Maintainer: Dominik Picheta 6 | Author: Dominik Picheta 7 | Copyright: (c) 2010 Dominik Picheta 8 | License: BSD3 9 | License-file: license 10 | Homepage: http://github.com/dom96/SimpleIRC 11 | Build-type: Simple 12 | Stability: provisional 13 | Cabal-version: >= 1.8 14 | Description: 15 | Simple IRC Library. This IRC Library aims to be simple and lightweight. 16 | 17 | Source-repository head 18 | Type: git 19 | Location: git://github.com/dom96/SimpleIRC.git 20 | 21 | Source-repository this 22 | Type: git 23 | Location: git://github.com/dom96/SimpleIRC.git 24 | tag: v0.3.1 25 | 26 | Library 27 | Build-depends: 28 | base >= 4 && < 5, 29 | base64, 30 | bytestring >= 0.9.1.7, 31 | network >= 2.2.1.5, 32 | connection >= 0.2.4, 33 | containers >= 0.3.0.0, 34 | time >= 1.1.4, 35 | old-locale >= 1.0.0.2 36 | Exposed-modules: 37 | Network.SimpleIRC 38 | Network.SimpleIRC.Core 39 | Network.SimpleIRC.Messages 40 | Network.SimpleIRC.Sasl 41 | ghc-options: 42 | -Wall 43 | 44 | test-suite spec 45 | type: 46 | exitcode-stdio-1.0 47 | ghc-options: 48 | -Wall 49 | cpp-options: 50 | -DTEST 51 | hs-source-dirs: 52 | ., tests 53 | main-is: 54 | Spec.hs 55 | build-depends: 56 | base 57 | , bytestring 58 | , hspec 59 | , HUnit 60 | , knob 61 | -------------------------------------------------------------------------------- /license: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010, Dominik Picheta 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of the author nor the 12 | names of its contributors may be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL DOMINIK PICHETA BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | 26 | -------------------------------------------------------------------------------- /readme.markdown: -------------------------------------------------------------------------------- 1 | # SimpleIRC 2 | SimpleIRC is a simple IRC Library for haskell. 3 | 4 | ## Installation 5 | To install SimpleIRC as a library you need cabal. 6 | 7 | You can then use `cabal install` to install. 8 | 9 | ## Example 10 | For an example on how to use the library see example/example.hs and tests/testbot.hs 11 | 12 | I'm also creating an IRC Bot which uses this library. 13 | [Take a look at it](http://github.com/dom96/ElysiaBot "Take a look at it") for more practical usage of the lib. 14 | 15 | ### Usage 16 | The first step is to create an IrcConfig datatype. You have to specify the address of the server, 17 | the server port, nickname, username, realname, list of channels to join when connected, 18 | and a list of events which will be called when certain commands are received from the server. 19 | 20 | You can specify 0 events, if for some unlikely reason you want your bot to not respond to anything. 21 | But in the more likely event when you do want to specify functions, you can do that simply by creating a function with the type of _EventFunc_ 22 | 23 | onMessage :: EventFunc 24 | 25 | EventFunc has the type of `(IrcServer -> IrcMessage -> IO ())`. 26 | For Haskell beginners that's a function which takes two arguments; an IrcServer and an IrcMessage, and which returns a IO () 27 | 28 | onMessage server msg 29 | | m == "|hello" = do 30 | sendMsg server chan "hello!" 31 | | otherwise = return () 32 | where chan = fromJust $ mChan m 33 | m = mMsg msg 34 | 35 | This function will send "hello" to a channel whenever someone says "|hello". 36 | 37 | Then you can pass `[(Privmsg onMessage)]` to IrcConfig. 38 | 39 | Take a look at the ``IrcEvent`` type in Network/SimpleIRC/Core.hs to see other events. 40 | 41 | There is one(as of now) event which doesn't take a EventFunc function. 42 | You should be able to figure out what type of function it does take by looking at Network/SimpleIRC/Core.hs 43 | 44 | After you create a IrcConfig you can then call `connect`. Connect takes two arguments; the IrcConfig and a boolean. 45 | The boolean specifies whether to run the listenLoop in a new thread. 46 | 47 | If you have any questions you can ask them @ irc://irc.freenode.net/#() 48 | 49 | ## License 50 | SimpleIRC is licensed under the BSD3 license. Read the license file for more information. 51 | 52 | -------------------------------------------------------------------------------- /Network/SimpleIRC/Sasl.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Network.SimpleIRC.Sasl 3 | -- Copyright : (c) Dominik Picheta 2010 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : morfeusz8@gmail.com 7 | -- Stability : provisional 8 | -- Portability : portable 9 | -- 10 | -- An extensible way to implement Sasl authentication 11 | {-# LANGUAGE OverloadedStrings, CPP #-} 12 | module Network.SimpleIRC.Sasl 13 | ( SaslSend(..) 14 | , SaslAwait(..) 15 | , SaslMechanism(..) 16 | , SaslPlainArgs(..) 17 | , saslPlain 18 | , encodeAuthMsg 19 | , decodeAuthMsg 20 | ) where 21 | 22 | import Data.List.NonEmpty (NonEmpty(..)) 23 | import qualified Data.ByteString.Base64 as B64 24 | import qualified Data.ByteString.Char8 as B 25 | import qualified Data.List.NonEmpty as NE 26 | 27 | data SaslMechanism = SaslMechanism 28 | { saslMechanismName :: String 29 | , saslMechanismProc :: SaslAwait 30 | } 31 | 32 | -- | Send a message, then await a response. message provided in plaintext 33 | -- and will be encoded in base64 en-route 34 | data SaslSend = SaslSend (Maybe B.ByteString) SaslAwait 35 | 36 | -- | Await a response, then proceed. Response will be pre-decoded from 37 | -- base64 38 | data SaslAwait = 39 | SaslAwaitResp (B.ByteString -> Either String SaslSend) 40 | | SaslAwaitDone 41 | 42 | data SaslPlainArgs = SaslPlainArgs 43 | { saslPlainAuthz :: Maybe String -- ^ authorization id (usually blank) 44 | , saslPlainAuthn :: String -- ^ authentication id (name) 45 | , saslPlainPass :: String 46 | } 47 | 48 | saslPlain :: SaslPlainArgs -> SaslMechanism 49 | saslPlain (SaslPlainArgs authz authn pass) = SaslMechanism 50 | { saslMechanismName = "PLAIN" 51 | , saslMechanismProc = SaslAwaitResp $ \_ -> Right $ 52 | SaslSend (Just authMsg) SaslAwaitDone 53 | } 54 | where 55 | authMsg = B.pack $ concat 56 | [ concat authz, "\0", authn, "\0", pass ] 57 | 58 | splitMessage :: B.ByteString -> NonEmpty B.ByteString 59 | splitMessage bs = case B.length bs of 60 | 400 -> x `NE.cons` splitMessage y 61 | 0 -> "+" :| [] 62 | _ -> x :| [] 63 | where 64 | (x, y) = B.splitAt 400 bs 65 | 66 | encodeAuthMsg :: B.ByteString -> NonEmpty B.ByteString 67 | encodeAuthMsg = splitMessage . B64.encodeBase64' 68 | 69 | -- | ignores needed padding in base64 70 | decodeAuthMsg 71 | :: B.ByteString -- ^ currently seen so far 72 | -> B.ByteString -- ^ newly seen 73 | -> Either B.ByteString (Maybe B.ByteString) -- ^ 'Left' if more input needed 74 | decodeAuthMsg soFar = fmap (fmap B64.decodeBase64Lenient) . unsplitMsg soFar 75 | 76 | unsplitMsg 77 | :: B.ByteString -- ^ currently seen so far 78 | -> B.ByteString -- ^ newly seen 79 | -> Either B.ByteString (Maybe B.ByteString) -- ^ 'Left' if more input needed 80 | unsplitMsg soFar newMsg = case compare (B.length newMsg) 400 of 81 | LT 82 | | newMsg == "+" -> Right . Just $ soFar 83 | | otherwise -> Right . Just $ soFar `B.append` newMsg 84 | EQ -> Left $ soFar `B.append` newMsg 85 | GT -> Right Nothing 86 | -------------------------------------------------------------------------------- /tests/CoreSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 3 | 4 | module CoreSpec (main, spec) where 5 | 6 | import Control.Concurrent 7 | import Test.HUnit 8 | import Test.Hspec.Monadic 9 | import Test.Hspec.HUnit() 10 | import qualified Data.Knob as K 11 | import qualified Data.Map as Map 12 | import System.IO 13 | import qualified Data.ByteString.Char8 as B 14 | import Data.Unique 15 | import Data.Time.Clock 16 | 17 | import Network.SimpleIRC.Core 18 | 19 | appendMVar mList x = do 20 | modifyMVar_ mList (\l -> return (x:l)) 21 | 22 | mockMirc = do 23 | k <- K.newKnob "" 24 | h <- K.newFileHandle k "test connection" ReadWriteMode 25 | u1 <- newUnique 26 | u2 <- newUnique 27 | u3 <- newUnique 28 | resultList <- newMVar [] 29 | now <- getCurrentTime 30 | mIrc <- newMVar $ IrcServer 31 | { sAddr = B.pack "" 32 | , sPort = 0 33 | , sNickname = B.pack "" 34 | , sPassword = Nothing 35 | , sUsername = B.pack "" 36 | , sRealname = B.pack "" 37 | , sChannels = [] 38 | , sEvents = Map.fromList [ (u1, Disconnect $ \_ -> appendMVar resultList True) 39 | , (u2, Privmsg $ \_ _ -> appendMVar resultList False) 40 | , (u3, Disconnect $ \_ -> appendMVar resultList True) 41 | ] 42 | , sSock = Just h 43 | , sListenThread = Nothing 44 | , sCmdThread = Nothing 45 | , sCmdChan = undefined 46 | , sDebug = False 47 | -- Other info 48 | , sCTCPVersion = "" 49 | , sCTCPTime = return "" 50 | , sPingTimeoutInterval = 10 51 | , sFloodControlTimestamp = now 52 | } 53 | return (resultList, mIrc) 54 | 55 | -- executes a list of IO actions and returns the number of seconds 56 | -- it took to do so 57 | measureM :: [IO ()] -> IO Rational 58 | measureM actions = do 59 | start <- getCurrentTime 60 | sequence_ actions 61 | end <- getCurrentTime 62 | return $ toRational $ diffUTCTime end start 63 | 64 | main = hspecX spec 65 | 66 | spec :: Specs 67 | spec = do 68 | describe "listenLoop" $ do 69 | it "calls the function of all disconnect events on disconnect" $ do 70 | (mResultList, mIrc) <- mockMirc 71 | listenLoop mIrc 72 | resultList <- takeMVar mResultList 73 | assertEqual "exactly both disconnect events have added their value to the result list" [True, True] resultList 74 | 75 | describe "sendMsg flood control" $ do 76 | it "takes less than one second to send five messages" $ do 77 | (_, mIrc) <- mockMirc 78 | duration <- measureM $ replicate 5 $ sendMsg mIrc "a" "a" 79 | assertBool "it took less than one second to send 5 messages" $ duration < 1 80 | 81 | it "takes 4 seconds to send 7 messages" $ do 82 | (_, mIrc) <- mockMirc 83 | duration <- measureM $ replicate 7 $ sendMsg mIrc "a" "a" 84 | assertBool "it took roughly 4 seconds to send 7 messages" $ abs (4 - duration) < 0.5 85 | 86 | it "takes 30 seconds to send 20 messages" $ do 87 | (_, mIrc) <- mockMirc 88 | duration <- measureM $ replicate 20 $ sendMsg mIrc "a" "a" 89 | assertBool "it took roughly 30 seconds to send 20 messages" $ abs (30 - duration) < 0.5 90 | -------------------------------------------------------------------------------- /Network/SimpleIRC/Messages.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Network.SimpleIRC.Core 3 | -- Copyright : (c) Dominik Picheta 2010 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : morfeusz8@gmail.com 7 | -- Stability : provisional 8 | -- Portability : portable 9 | -- 10 | -- Messages (parsing) module 11 | -- 12 | {-# LANGUAGE DeriveDataTypeable #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | module Network.SimpleIRC.Messages 15 | ( IrcMessage(..) 16 | , Command(..) 17 | , parse 18 | , showCommand 19 | ) 20 | where 21 | import Control.Arrow hiding (first) 22 | import qualified Data.ByteString.Char8 as B 23 | import Data.Maybe (mapMaybe) 24 | import Data.Typeable 25 | 26 | -- PING :asimov.freenode.net 27 | -- :haskellTestBot!~test@host86-177-151-242.range86-177.btcentralplus.com JOIN :#() 28 | 29 | -- :dom96!~dom96@unaffiliated/dom96 PRIVMSG #() :it lives! 30 | -- :haskellTestBot MODE haskellTestBot :+i 31 | -- :asimov.freenode.net 376 haskellTestBot :End of /MOTD command. 32 | 33 | -- :asimov.freenode.net 332 haskellTestBot #() :Parenthesis 34 | 35 | -- :asimov.freenode.net 333 haskellTestBot #() Raynes!~macr0@unaffiliated/raynes 1281221819 36 | 37 | data Command = 38 | MPrivmsg B.ByteString B.ByteString -- ^ PRIVMSG #chan :msg 39 | | MJoin B.ByteString (Maybe B.ByteString) -- ^ JOIN #chan key 40 | | MPart B.ByteString B.ByteString -- ^ PART #chan :msg 41 | | MMode B.ByteString B.ByteString (Maybe B.ByteString) -- ^ MODE #chan +o user 42 | | MTopic B.ByteString (Maybe B.ByteString) -- ^ TOPIC #chan :topic 43 | | MInvite B.ByteString B.ByteString -- ^ INVITE user #chan 44 | | MKick B.ByteString B.ByteString B.ByteString -- ^ KICK #chan user :msg 45 | | MQuit B.ByteString -- ^ QUIT :msg 46 | | MNick B.ByteString -- ^ NICK newnick 47 | | MNotice B.ByteString B.ByteString -- ^ NOTICE usr/#chan :msg 48 | | MAction B.ByteString B.ByteString -- ^ PRIVMSG usr/#chan :ACTION msg 49 | deriving (Eq, Read, Show) 50 | 51 | data IrcMessage = IrcMessage 52 | { mNick :: Maybe B.ByteString 53 | , mUser :: Maybe B.ByteString 54 | , mHost :: Maybe B.ByteString 55 | , mServer :: Maybe B.ByteString 56 | , mCode :: B.ByteString 57 | , mMsg :: B.ByteString 58 | , mChan :: Maybe B.ByteString 59 | , mOrigin :: Maybe B.ByteString -- ^ Origin of the message, this is mNick if a message was sent directly to the bot, otherwise if it got sent to the channel it's mChan. 60 | , mOther :: Maybe [B.ByteString] 61 | , mTags :: [(B.ByteString, B.ByteString)] 62 | , mRaw :: B.ByteString 63 | } deriving (Show, Typeable) 64 | 65 | -- |Parse a raw IRC message 66 | parse :: B.ByteString -> IrcMessage 67 | parse txt = 68 | case split of 69 | [code, msg] -> parse2 tags code msg noCarriage 70 | [first, code, msg] -> parse3 tags first code msg noCarriage 71 | [first, code, chan, msg] -> parse4 tags first code chan msg noCarriage 72 | [first, code, chan, other, msg] -> parse5 tags first code chan other msg noCarriage 73 | server:code:nick:chan:other -> parseOther tags server code nick chan other noCarriage 74 | _ -> error "SimpleIRC: unexpected message format" 75 | 76 | where noCarriage = takeCarriageRet rest 77 | split = smartSplit noCarriage 78 | (tags, rest) = parseTags txt 79 | 80 | -- Nick, Host, Server 81 | parseFirst :: B.ByteString -> (Maybe B.ByteString, Maybe B.ByteString, Maybe B.ByteString, Maybe B.ByteString) 82 | parseFirst first = 83 | if '!' `B.elem` first 84 | then let (nick, user_host) = B.break (== '!') (dropColon first) 85 | in if '@' `B.elem` user_host 86 | then let (user, host) = second B.tail $ B.break (== '@') $ B.tail user_host 87 | in (Just nick, Just user, Just host, Nothing) 88 | else (Just nick, Nothing, Just user_host, Nothing) 89 | else (Nothing, Nothing, Nothing, Just $ dropColon first) 90 | 91 | parseTags :: B.ByteString -> ([(B.ByteString, B.ByteString)], B.ByteString) 92 | parseTags str 93 | | "@" `B.isPrefixOf` str = (mapMaybe (lstToPair . B.split '=') $ B.split ';' tagPart, rest) 94 | | otherwise = ([], str) 95 | where 96 | tagPart = B.drop 1 $ B.takeWhile (/= ' ') str 97 | rest = B.drop (B.length tagPart + 2) str 98 | lstToPair [a, b] = Just (a, b) 99 | lstToPair _ = Nothing 100 | 101 | getOrigin :: Maybe B.ByteString -> B.ByteString -> B.ByteString 102 | getOrigin (Just nick) chan = 103 | if "#" `B.isPrefixOf` chan || "&" `B.isPrefixOf` chan || "+" `B.isPrefixOf` chan 104 | || "!" `B.isPrefixOf` chan 105 | then chan 106 | else nick 107 | getOrigin Nothing chan = chan 108 | 109 | parse2 :: [(B.ByteString, B.ByteString)] -> B.ByteString -> B.ByteString -> B.ByteString -> IrcMessage 110 | parse2 tags code msg = 111 | IrcMessage Nothing Nothing Nothing Nothing code 112 | (dropColon msg) Nothing Nothing Nothing tags 113 | 114 | parse3 :: [(B.ByteString, B.ByteString)] -> B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -> IrcMessage 115 | parse3 tags first code msg = 116 | let (nick, user, host, server) = parseFirst first 117 | in IrcMessage nick user host server code (dropColon msg) Nothing Nothing Nothing tags 118 | 119 | parse4 :: [(B.ByteString, B.ByteString)] 120 | -> B.ByteString 121 | -> B.ByteString 122 | -> B.ByteString 123 | -> B.ByteString 124 | -> B.ByteString 125 | -> IrcMessage 126 | parse4 tags first code chan msg = 127 | let (nick, user, host, server) = parseFirst first 128 | in IrcMessage nick user host server code 129 | (dropColon msg) (Just chan) (Just $ getOrigin nick chan) Nothing tags 130 | 131 | parse5 :: [(B.ByteString, B.ByteString)] 132 | -> B.ByteString 133 | -> B.ByteString 134 | -> B.ByteString 135 | -> B.ByteString 136 | -> B.ByteString 137 | -> B.ByteString 138 | -> IrcMessage 139 | parse5 tags first code chan other msg = 140 | let (nick, user, host, server) = parseFirst first 141 | in IrcMessage nick user host server code 142 | (dropColon msg) (Just chan) (Just $ getOrigin nick chan) (Just [other]) tags 143 | 144 | parseOther :: [(B.ByteString, B.ByteString)] 145 | -> B.ByteString 146 | -> B.ByteString 147 | -> B.ByteString 148 | -> B.ByteString 149 | -> [B.ByteString] 150 | -> B.ByteString 151 | -> IrcMessage 152 | parseOther tags server code nick chan other = 153 | IrcMessage (Just nick) Nothing Nothing (Just server) code 154 | (B.unwords other) (Just chan) (Just $ getOrigin (Just nick) chan) (Just other) tags 155 | 156 | smartSplit :: B.ByteString -> [B.ByteString] 157 | smartSplit txt = 158 | case B.breakSubstring (B.pack " :") (dropColon txt) of 159 | (x,y) | B.null y -> 160 | B.words txt 161 | | otherwise -> 162 | let (_, msg) = B.break (== ':') y 163 | in B.words x ++ [msg] 164 | 165 | takeLast :: B.ByteString -> B.ByteString 166 | takeLast xs = B.take (B.length xs - 1) xs 167 | 168 | takeCarriageRet :: B.ByteString -> B.ByteString 169 | takeCarriageRet xs = 170 | if B.drop (B.length xs - 1) xs == B.pack "\r" 171 | then takeLast xs 172 | else xs 173 | 174 | dropColon :: B.ByteString -> B.ByteString 175 | dropColon xs = 176 | if B.take 1 xs == B.pack ":" 177 | then B.drop 1 xs 178 | else xs 179 | 180 | showCommand :: Command -> B.ByteString 181 | showCommand (MPrivmsg chan msg) = "PRIVMSG " `B.append` chan `B.append` 182 | " :" `B.append` msg 183 | showCommand (MJoin chan (Just key)) = "JOIN " `B.append` chan `B.append` 184 | " " `B.append` key 185 | showCommand (MJoin chan Nothing) = "JOIN " `B.append` chan 186 | showCommand (MPart chan msg) = "PART " `B.append` chan `B.append` 187 | " :" `B.append` msg 188 | showCommand (MMode chan mode (Just usr)) = "MODE " `B.append` chan `B.append` 189 | " " `B.append` mode `B.append` 190 | " " `B.append` usr 191 | showCommand (MMode chan mode Nothing) = "MODE " `B.append` chan `B.append` 192 | " " `B.append` mode 193 | showCommand (MTopic chan (Just msg)) = "TOPIC " `B.append` chan `B.append` 194 | " :" `B.append` msg 195 | showCommand (MTopic chan Nothing) = "TOPIC " `B.append` chan 196 | showCommand (MInvite usr chan) = "INVITE " `B.append` usr `B.append` 197 | " " `B.append` chan 198 | showCommand (MKick chan usr msg) = "KICK " `B.append` chan `B.append` 199 | " " `B.append` usr `B.append` 200 | " :" `B.append` msg 201 | showCommand (MQuit msg) = "QUIT :" `B.append` msg 202 | showCommand (MNick nick) = "NICK " `B.append` nick 203 | showCommand (MNotice chan msg) = "NOTICE " `B.append` chan `B.append` 204 | " :" `B.append` msg 205 | showCommand (MAction chan msg) = showCommand $ MPrivmsg chan 206 | ("\SOHACTION " `B.append` msg 207 | `B.append` "\SOH") 208 | -------------------------------------------------------------------------------- /Network/SimpleIRC/Core.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Network.SimpleIRC.Core 3 | -- Copyright : (c) Dominik Picheta 2010 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : morfeusz8@gmail.com 7 | -- Stability : provisional 8 | -- Portability : portable 9 | -- 10 | -- For information on how to use this library please take a look at the readme file on github, . 11 | {-# LANGUAGE OverloadedStrings, CPP, PatternGuards #-} 12 | module Network.SimpleIRC.Core 13 | ( 14 | -- * Types 15 | MIrc 16 | , EventFunc 17 | , IrcConfig(..) 18 | , IrcEvent(..) 19 | , SaslMechanism(..) 20 | 21 | -- * Functions 22 | , connect 23 | , disconnect 24 | , reconnect 25 | , sendRaw 26 | , sendMsg 27 | , sendCmd 28 | , addEvent 29 | , changeEvents 30 | , remEvent 31 | , mkDefaultConfig 32 | 33 | -- * Accessors 34 | , getChannels 35 | , getNickname 36 | , getAddress 37 | , getPort 38 | , getUsername 39 | , getRealname 40 | #ifdef TEST 41 | , IrcServer(..) 42 | , listenLoop 43 | #endif 44 | ) where 45 | 46 | import Network.Connection 47 | import Network.Socket (HostName, PortNumber) 48 | 49 | import Data.Maybe 50 | import Data.List (delete) 51 | import Data.Char (isNumber) 52 | import Control.Monad 53 | import Control.Concurrent 54 | import Network.SimpleIRC.Messages 55 | import Network.SimpleIRC.Sasl 56 | import Data.Unique 57 | import Control.Exception (try, SomeException) 58 | import System.Timeout 59 | import Data.Time 60 | #if ! MIN_VERSION_time(1,5,0) 61 | import System.Locale 62 | #endif 63 | import qualified Data.ByteString.Char8 as B 64 | import qualified Data.Map as Map 65 | import qualified Data.Foldable as Foldable 66 | 67 | internalEvents :: [IrcServer -> IrcMessage -> IO IrcServer] 68 | internalEvents = [joinChans, pong, trackChanges, handleSasl] 69 | internalNormEvents :: [IrcEvent] 70 | internalNormEvents = [Privmsg ctcpHandler] 71 | 72 | type MIrc = MVar IrcServer 73 | 74 | data IrcConfig = IrcConfig 75 | { cAddr :: String -- ^ Server address to connect to 76 | , cPort :: Int -- ^ Server port to connect to 77 | , cSecure :: Bool -- ^ Use secure transport 78 | , cNick :: String -- ^ Nickname 79 | , cPass :: Maybe String -- ^ Optional server password 80 | , cSasl :: Maybe SaslMechanism -- ^ sasl 81 | , cUsername :: String -- ^ Username 82 | , cRealname :: String -- ^ Realname 83 | , cChannels :: [String] -- ^ List of channels to join on connect 84 | , cEvents :: [IrcEvent] -- ^ Events to bind 85 | , cCTCPVersion :: String -- ^ What to send on CTCP VERSION 86 | , cCTCPTime :: IO String -- ^ What to send on CTCP TIME 87 | , cPingTimeoutInterval :: Int -- The time between server messages that causes ping timeout 88 | } 89 | 90 | data SIrcCommand = 91 | SIrcAddEvent (Unique, IrcEvent) 92 | | SIrcChangeEvents (Map.Map Unique IrcEvent) 93 | | SIrcRemoveEvent Unique 94 | 95 | data IrcServer = IrcServer 96 | { sAddr :: B.ByteString 97 | , sPort :: Int 98 | , sSecure :: Bool 99 | , sNickname :: B.ByteString 100 | , sPassword :: Maybe B.ByteString 101 | , sSasl :: Maybe SaslState 102 | , sUsername :: B.ByteString 103 | , sRealname :: B.ByteString 104 | , sChannels :: [B.ByteString] 105 | , sEvents :: Map.Map Unique IrcEvent 106 | , sSock :: Maybe Connection 107 | , sListenThread :: Maybe ThreadId 108 | , sCmdThread :: Maybe ThreadId 109 | , sCmdChan :: Chan SIrcCommand 110 | , sDebug :: Bool 111 | -- Other info 112 | , sCTCPVersion :: String 113 | , sCTCPTime :: IO String 114 | , sPingTimeoutInterval :: Int 115 | , sFloodControlTimestamp :: UTCTime 116 | } 117 | 118 | -- When adding events here, remember add them in callEvents and in eventFunc 119 | -- AND also in the Show instance and Eq instance 120 | 121 | data IrcEvent = 122 | Privmsg EventFunc -- ^ PRIVMSG 123 | | Numeric EventFunc -- ^ Numeric, 001, 002, 372 etc. 124 | | Ping EventFunc -- ^ PING 125 | | Join EventFunc -- ^ JOIN 126 | | Part EventFunc -- ^ PART 127 | | Mode EventFunc -- ^ MODE 128 | | Topic EventFunc -- ^ TOPIC 129 | | Invite EventFunc -- ^ INVITE 130 | | Kick EventFunc -- ^ KICK 131 | | Quit EventFunc -- ^ QUIT 132 | | Nick EventFunc -- ^ NICK 133 | | Notice EventFunc -- ^ NOTICE 134 | | RawMsg EventFunc -- ^ This event gets called on every message received 135 | | Disconnect (MIrc -> IO ()) -- ^ This event gets called whenever the 136 | -- connection with the server is dropped 137 | 138 | data SaslState = 139 | -- | Should always move from NotStarted to Running, never backwards 140 | SaslNotStarted SaslMechanism 141 | -- | Because messages are sent in multiple chunks, the bytestring is 142 | -- the message (base-64) seen "so far", before the Await can be run 143 | | SaslRunning B.ByteString SaslAwait 144 | 145 | instance Show IrcEvent where 146 | show (Privmsg _) = "IrcEvent - Privmsg" 147 | show (Numeric _) = "IrcEvent - Numeric" 148 | show (Ping _) = "IrcEvent - Ping" 149 | show (Join _) = "IrcEvent - Join" 150 | show (Part _) = "IrcEvent - Part" 151 | show (Mode _) = "IrcEvent - Mode" 152 | show (Topic _) = "IrcEvent - Topic" 153 | show (Invite _) = "IrcEvent - Invite" 154 | show (Kick _) = "IrcEvent - Kick" 155 | show (Quit _) = "IrcEvent - Quit" 156 | show (Nick _) = "IrcEvent - Nick" 157 | show (Notice _) = "IrcEvent - Notice" 158 | show (RawMsg _) = "IrcEvent - RawMsg" 159 | show (Disconnect _) = "IrcEvent - Disconnect" 160 | 161 | type EventFunc = (MIrc -> IrcMessage -> IO ()) 162 | 163 | connect' :: HostName -> PortNumber -> Bool -> IO Connection 164 | connect' host port secure = do 165 | ctx <- initConnectionContext 166 | conn <- connectTo ctx $ ConnectionParams host port (tlsSettings secure) Nothing 167 | return conn 168 | where 169 | tlsSettings True = Just $ TLSSettingsSimple True True False 170 | tlsSettings False = Nothing 171 | 172 | -- |Connects to a server 173 | connect :: IrcConfig -- ^ Configuration 174 | -> Bool -- ^ Run in a new thread 175 | -> Bool -- ^ Print debug messages 176 | -> IO (Either IOError MIrc) -- ^ IrcServer instance 177 | connect config threaded debug = try $ do 178 | (when debug $ 179 | B.putStrLn $ "Connecting to " `B.append` B.pack (cAddr config)) 180 | 181 | conn <- connect' (cAddr config) (fromIntegral $ cPort config) (cSecure config) 182 | 183 | cmdChan <- newChan 184 | 185 | server <- toServer config conn cmdChan debug 186 | -- Initialize connection with the server 187 | _ <- greetServer server 188 | 189 | -- Create a new MVar 190 | res <- newMVar server 191 | 192 | -- Start the loops, listen and exec cmds 193 | if threaded 194 | then do listenId <- forkIO (listenLoop res) 195 | _ <- forkIO (execCmdsLoop res) 196 | modifyMVar_ res (\srv -> return $ srv {sListenThread = Just listenId}) 197 | return res 198 | else do listenLoop res 199 | return res 200 | 201 | -- |Sends a QUIT command to the server. 202 | disconnect :: MIrc 203 | -> B.ByteString -- ^ Quit message 204 | -> IO () 205 | disconnect server quitMsg = do 206 | s <- readMVar server 207 | 208 | write s $ "QUIT :" `B.append` quitMsg 209 | connectionClose (fromJust $ sSock s) 210 | 211 | -- |Reconnects to the server. 212 | reconnect :: MIrc -> IO (Either IOError MIrc) 213 | reconnect mIrc = try $ do 214 | server <- readMVar mIrc 215 | 216 | conn <- connect' (B.unpack $ sAddr server) (fromIntegral $ sPort server) (sSecure server) 217 | 218 | modifyMVar_ mIrc (\s -> return $ s {sSock = Just conn}) 219 | 220 | -- Initialize connection with the server 221 | _ <- withMVar mIrc greetServer 222 | 223 | -- Restart the listen loop. 224 | listenId <- forkIO (listenLoop mIrc) 225 | cmdId <- forkIO (execCmdsLoop mIrc) 226 | modifyMVar_ mIrc (\s -> return $ s {sListenThread = Just listenId, 227 | sCmdThread = Just cmdId}) 228 | return mIrc 229 | 230 | {- 231 | -- |Reconnects to the server. 232 | reconnect :: MIrc -> IO (Either IOError MIrc) 233 | reconnect server = do 234 | s <- readMVar server 235 | 236 | let conf = IrcConfig (B.unpack $ sAddr s) (sPort s) 237 | (B.unpack $ sNickname s) (B.unpack $ sUsername s) 238 | (B.unpack $ sRealname s) (map (B.unpack) (sChannels s)) 239 | (elems $ sEvents s) (sCTCPVersion s) (sCTCPTime s) 240 | connect conf True (sDebug s) 241 | -} 242 | 243 | genUnique :: IrcEvent -> IO (Unique, IrcEvent) 244 | genUnique e = do 245 | u <- newUnique 246 | return (u, e) 247 | 248 | genUniqueMap :: [IrcEvent] -> IO (Map.Map Unique IrcEvent) 249 | genUniqueMap evts = do 250 | uEvents <- mapM genUnique evts 251 | return $ Map.fromList uEvents 252 | 253 | toServer :: IrcConfig -> Connection -> Chan SIrcCommand -> Bool -> IO IrcServer 254 | toServer config conn cmdChan debug = do 255 | uniqueEvents <- genUniqueMap $ internalNormEvents ++ cEvents config 256 | now <- getCurrentTime 257 | 258 | return $ IrcServer (B.pack $ cAddr config) (cPort config) (cSecure config) 259 | (B.pack $ cNick config) (B.pack `fmap` cPass config) 260 | (SaslNotStarted `fmap` cSasl config) (B.pack $ cUsername config) 261 | (B.pack $ cRealname config) (map B.pack $ cChannels config) 262 | uniqueEvents (Just conn) Nothing Nothing cmdChan debug 263 | (cCTCPVersion config) (cCTCPTime config) 264 | (cPingTimeoutInterval config) now 265 | 266 | greetServer :: IrcServer -> IO IrcServer 267 | greetServer server = do 268 | when (isJust sasl) $ write server "CAP REQ :sasl" 269 | case mpass of 270 | Nothing -> return () 271 | Just pass -> write server $ "PASS " `B.append` pass 272 | write server $ "NICK " `B.append` nick 273 | write server $ "USER " `B.append` user `B.append` " " `B.append` 274 | user `B.append` " " `B.append` addr `B.append` " :" `B.append` real 275 | 276 | return server 277 | where nick = sNickname server 278 | mpass = sPassword server 279 | user = sUsername server 280 | real = sRealname server 281 | addr = sAddr server 282 | sasl = sSasl server 283 | 284 | execCmdsLoop :: MIrc -> IO () 285 | execCmdsLoop mIrc = do 286 | server <- readMVar mIrc 287 | cmd <- readChan $ sCmdChan server 288 | case cmd of (SIrcAddEvent uEvent) -> do 289 | _ <- swapMVar mIrc (server {sEvents = 290 | (uncurry Map.insert uEvent) (sEvents server)}) 291 | execCmdsLoop mIrc 292 | (SIrcChangeEvents evts) -> do 293 | _ <- swapMVar mIrc (server {sEvents = evts}) 294 | execCmdsLoop mIrc 295 | (SIrcRemoveEvent key) -> do 296 | _ <- swapMVar mIrc (server {sEvents = 297 | Map.delete key (sEvents server)}) 298 | execCmdsLoop mIrc 299 | 300 | 301 | listenLoop :: MIrc -> IO () 302 | listenLoop s = do 303 | server <- readMVar s 304 | 305 | let c = fromJust $ sSock server 306 | 307 | -- RFC 2812, max message line length 308 | lineOrCleanup <- timeout (sPingTimeoutInterval server) (try $ connectionGetLine 512 c :: IO (Either SomeException B.ByteString)) 309 | 310 | case lineOrCleanup of 311 | Nothing -> do 312 | debugWrite server $ "Timeout reached" 313 | cleanup server 314 | Just (Left ex) -> do 315 | debugWrite server $ B.pack $ "Exception caught: " ++ show ex 316 | cleanup server 317 | 318 | Just (Right line) -> do 319 | server1 <- takeMVar s 320 | 321 | -- Print the received line. 322 | debugWrite server1 $ (B.pack ">> ") `B.append` line 323 | let parsed = parse line 324 | 325 | -- Call the internal events 326 | newServ <- foldM (\sr f -> f sr parsed) server1 internalEvents 327 | 328 | putMVar s newServ -- Put the MVar back. 329 | 330 | -- Call the events 331 | callEvents s parsed 332 | 333 | -- Call the RawMsg Events. 334 | events s (RawMsg undefined) parsed 335 | 336 | 337 | listenLoop s 338 | where 339 | cleanup server = do 340 | modifyMVar_ s (\serv -> return $ serv {sSock = Nothing}) 341 | Foldable.mapM_ (callDisconnectFunction s) (sEvents server) 342 | callDisconnectFunction mIrc (Disconnect f) = f mIrc 343 | callDisconnectFunction _ _ = return () 344 | 345 | -- Internal Events - They can edit the server 346 | joinChans :: IrcServer -> IrcMessage -> IO IrcServer 347 | joinChans server msg = 348 | if code == "001" 349 | then do mapM_ (\chan -> write server $ "JOIN " `B.append` chan) (sChannels server) 350 | return server {sChannels = []} 351 | else return server 352 | where code = mCode msg 353 | 354 | pong :: IrcServer -> IrcMessage -> IO IrcServer 355 | pong server msg = 356 | if code == "PING" 357 | then do 358 | write server $ "PONG :" `B.append` pingMsg 359 | return server 360 | else return server 361 | 362 | where pingMsg = mMsg msg 363 | code = mCode msg 364 | 365 | trackChanges :: IrcServer -> IrcMessage -> IO IrcServer 366 | trackChanges server msg 367 | | code == "JOIN" = do 368 | let nick = fromJust $ mNick msg 369 | chan = mMsg msg 370 | if nick == sNickname server 371 | then return server { sChannels = chan:(sChannels server) } 372 | else return server 373 | | code == "NICK" = do 374 | let nick = fromJust $ mNick msg 375 | newNick = mMsg msg 376 | if nick == sNickname server 377 | then return server { sNickname = newNick } 378 | else return server 379 | | code == "KICK" = do 380 | let nick = (fromJust $ mOther msg) !! 0 381 | chan = fromJust $ mChan msg 382 | if nick == sNickname server 383 | then return server { sChannels = delete chan (sChannels server) } 384 | else return server 385 | | code == "PART" = do 386 | let nick = fromJust $ mNick msg 387 | chan = mMsg msg 388 | if nick == sNickname server 389 | then return server { sChannels = delete chan (sChannels server) } 390 | else return server 391 | | otherwise = return server 392 | 393 | where code = mCode msg 394 | 395 | handleSasl :: IrcServer -> IrcMessage -> IO IrcServer 396 | handleSasl s0 msg = answerSasl =<< checkSasl =<< beginSasl s0 397 | where 398 | code = mCode msg 399 | other = mOther msg 400 | contents = mMsg msg 401 | runSend server s = case s of 402 | SaslSend mg nxt -> do 403 | mapM_ (mapM_ (write server . ("AUTHENTICATE " `B.append`)) . encodeAuthMsg) mg 404 | return server { sSasl = Just (SaslRunning B.empty nxt) } 405 | beginSasl server = case (sasl, code, other) of 406 | (Just (SaslNotStarted (SaslMechanism nm mc)), "CAP", Just ("ACK":_)) -> do 407 | write server $ "AUTHENTICATE " `B.append` B.pack nm 408 | return server { sSasl = Just (SaslRunning B.empty mc) } 409 | _ -> return server 410 | where sasl = sSasl server 411 | checkSasl server = case sasl of 412 | Just _ 413 | | code == "903" || code == "907" || code == "906" -> do 414 | write server "CAP END" 415 | return server { sSasl = Nothing } 416 | | code == "904" -> do 417 | debugWrite server "SASL Authentication Failed" 418 | return server 419 | _ -> return server 420 | where sasl = sSasl server 421 | answerSasl server = case sasl of 422 | Just (SaslRunning soFar (SaslAwaitResp f)) 423 | | code == "AUTHENTICATE" -> 424 | case decodeAuthMsg soFar contents of 425 | Left waitMore -> return server 426 | { sSasl = Just (SaslRunning waitMore (SaslAwaitResp f)) } 427 | Right Nothing -> do 428 | write server $ "AUTHENTICATE *" 429 | debugWrite server 430 | "SASL Authentication Aborted: AUTHENTICATE command over 400 bytes received" 431 | return server 432 | Right (Just fullMsg) -> case f fullMsg of 433 | Left e -> do 434 | write server $ "AUTHENTICATE *" 435 | debugWrite server $ "SASL Authentication Aborted: " <> B.pack e 436 | return server 437 | Right x -> runSend server x 438 | | otherwise -> return server 439 | -- this is handled by checkSasl 440 | Just (SaslRunning _ SaslAwaitDone) -> return server 441 | _ -> return server 442 | where sasl = sSasl server 443 | 444 | -- Internal normal events 445 | ctcpHandler :: EventFunc 446 | ctcpHandler mServ iMsg 447 | | msg == "\x01VERSION\x01" = do 448 | server <- readMVar mServ 449 | 450 | sendCmd mServ 451 | (MNotice origin ("\x01VERSION " `B.append` 452 | B.pack (sCTCPVersion server) `B.append` "\x01")) 453 | 454 | | msg == "\x01TIME\x01" = do 455 | server <- readMVar mServ 456 | 457 | time <- sCTCPTime server 458 | sendCmd mServ 459 | (MNotice origin ("\x01TIME " `B.append` 460 | (B.pack time) `B.append` "\x01")) 461 | | "\x01PING " `B.isPrefixOf` msg = do 462 | 463 | sendCmd mServ 464 | (MNotice origin msg) 465 | 466 | | otherwise = return () 467 | where msg = mMsg iMsg 468 | origin = fromJust $ mOrigin iMsg 469 | -- Event code 470 | events :: MIrc -> IrcEvent -> IrcMessage -> IO () 471 | events mServ event msg = do 472 | server <- readMVar mServ 473 | let comp = (`eqEvent` event) 474 | evts = Map.filter comp (sEvents server) 475 | eventCall = (\obj -> (eventFunc $ snd obj) mServ msg) 476 | 477 | mapM_ eventCall (Map.toList evts) 478 | 479 | 480 | callEvents :: MIrc -> IrcMessage -> IO () 481 | callEvents mServ msg 482 | | mCode msg == "PRIVMSG" = 483 | events mServ (Privmsg undefined) msg 484 | 485 | | mCode msg == "PING" = 486 | events mServ (Ping undefined) msg 487 | 488 | | mCode msg == "JOIN" = 489 | events mServ (Join undefined) msg 490 | 491 | | mCode msg == "PART" = 492 | events mServ (Part undefined) msg 493 | 494 | | mCode msg == "MODE" = 495 | events mServ (Mode undefined) msg 496 | 497 | | mCode msg == "TOPIC" = 498 | events mServ (Topic undefined) msg 499 | 500 | | mCode msg == "INVITE" = 501 | events mServ (Invite undefined) msg 502 | 503 | | mCode msg == "KICK" = 504 | events mServ (Kick undefined) msg 505 | 506 | | mCode msg == "QUIT" = 507 | events mServ (Quit undefined) msg 508 | 509 | | mCode msg == "NICK" = 510 | events mServ (Nick undefined) msg 511 | 512 | | mCode msg == "NOTICE" = 513 | events mServ (Notice undefined) msg 514 | 515 | | B.all isNumber (mCode msg) = 516 | events mServ (Numeric undefined) msg 517 | 518 | | otherwise = return () 519 | 520 | 521 | eqEvent :: IrcEvent -> IrcEvent -> Bool 522 | (Privmsg _) `eqEvent` (Privmsg _) = True 523 | (Numeric _) `eqEvent` (Numeric _) = True 524 | (Ping _) `eqEvent` (Ping _) = True 525 | (Join _) `eqEvent` (Join _) = True 526 | (Part _) `eqEvent` (Part _) = True 527 | (Mode _) `eqEvent` (Mode _) = True 528 | (Topic _) `eqEvent` (Topic _) = True 529 | (Invite _) `eqEvent` (Invite _) = True 530 | (Kick _) `eqEvent` (Kick _) = True 531 | (Quit _) `eqEvent` (Quit _) = True 532 | (Nick _) `eqEvent` (Nick _) = True 533 | (Notice _) `eqEvent` (Notice _) = True 534 | (RawMsg _) `eqEvent` (RawMsg _) = True 535 | (Disconnect _) `eqEvent` (Disconnect _) = True 536 | _ `eqEvent` _ = False 537 | 538 | eventFunc :: IrcEvent -> EventFunc 539 | eventFunc (Privmsg f) = f 540 | eventFunc (Numeric f) = f 541 | eventFunc (Ping f) = f 542 | eventFunc (Join f) = f 543 | eventFunc (Part f) = f 544 | eventFunc (Mode f) = f 545 | eventFunc (Topic f) = f 546 | eventFunc (Invite f) = f 547 | eventFunc (Kick f) = f 548 | eventFunc (Quit f) = f 549 | eventFunc (Nick f) = f 550 | eventFunc (Notice f) = f 551 | eventFunc (RawMsg f) = f 552 | eventFunc (Disconnect _) = error "SimpleIRC: unexpected event" 553 | 554 | -- |Sends a raw command to the server 555 | sendRaw :: MIrc -> B.ByteString -> IO () 556 | sendRaw mServ msg = do 557 | server <- readMVar mServ 558 | write server msg 559 | 560 | -- |Sends a message to a channel 561 | 562 | -- |Implements flood control according to RFC 2813, chapter 5.8 563 | sendMsg :: MIrc 564 | -> B.ByteString -- ^ Channel 565 | -> B.ByteString -- ^ Message 566 | -> IO () 567 | sendMsg mServ chan msg = 568 | mapM_ s lins 569 | where lins = B.lines msg 570 | s m = do 571 | now <- getCurrentTime 572 | stamp <- (getFloodControlTimestamp mServ) 573 | let latest = addUTCTime 2 $ max now stamp 574 | diff = diffUTCTime latest now 575 | setFloodControlTimestamp mServ latest 576 | when (diff > 10) (threadDelay $ 1000000 * (round diff - 10)) 577 | sendCmd mServ (MPrivmsg chan m) 578 | 579 | 580 | sendCmd :: MIrc 581 | -> Command -- Command to send 582 | -> IO () 583 | sendCmd mServ cmd = sendRaw mServ (showCommand cmd) 584 | 585 | addEvent :: MIrc -> IrcEvent -> IO Unique 586 | addEvent mIrc event = do 587 | s <- readMVar mIrc 588 | 589 | u <- newUnique 590 | writeChan (sCmdChan s) (SIrcAddEvent (u, event)) 591 | return u 592 | 593 | 594 | changeEvents :: MIrc -> [IrcEvent] -> IO () 595 | changeEvents mIrc evts = do 596 | s <- readMVar mIrc 597 | 598 | uniqueEvents <- genUniqueMap evts 599 | writeChan (sCmdChan s) (SIrcChangeEvents uniqueEvents) 600 | 601 | remEvent :: MIrc -> Unique -> IO () 602 | remEvent mIrc uniq = do 603 | s <- readMVar mIrc 604 | 605 | writeChan (sCmdChan s) (SIrcRemoveEvent uniq) 606 | 607 | debugWrite :: IrcServer -> B.ByteString -> IO () 608 | debugWrite s msg = 609 | (when (sDebug s) $ B.putStrLn msg) 610 | 611 | write :: IrcServer -> B.ByteString -> IO () 612 | write s msg = do 613 | debugWrite s $ "<< " `B.append` msg `B.append` "\\r\\n" 614 | connectionPut conn msg' 615 | where 616 | conn = fromJust $ sSock s 617 | msg' = msg `B.append` "\r\n" 618 | 619 | mkDefaultConfig :: String -> String -> IrcConfig 620 | mkDefaultConfig addr nick = IrcConfig 621 | { cAddr = addr 622 | , cPort = 6667 623 | , cSecure = False 624 | , cNick = nick 625 | , cPass = Nothing 626 | , cSasl = Nothing 627 | , cUsername = "simpleirc" 628 | , cRealname = "SimpleIRC Bot" 629 | , cChannels = [] 630 | , cEvents = [] 631 | , cCTCPVersion = "SimpleIRC v0.3" 632 | , cCTCPTime = fmap (formatTime defaultTimeLocale "%c") getZonedTime 633 | , cPingTimeoutInterval = 350 * 10^(6::Int) 634 | } 635 | 636 | -- MIrc Accessors 637 | -- |Returns a list of channels currently joined. 638 | getChannels :: MIrc -> IO [B.ByteString] 639 | getChannels mIrc = do 640 | s <- readMVar mIrc 641 | 642 | return $ sChannels s 643 | 644 | -- |Returns the current nickname. 645 | getNickname :: MIrc -> IO B.ByteString 646 | getNickname mIrc = do 647 | s <- readMVar mIrc 648 | 649 | return $ sNickname s 650 | 651 | -- |Returns the address 652 | getAddress :: MIrc -> IO B.ByteString 653 | getAddress mIrc = do 654 | s <- readMVar mIrc 655 | 656 | return $ sAddr s 657 | 658 | -- |Returns the address 659 | getPort :: MIrc -> IO Int 660 | getPort mIrc = do 661 | s <- readMVar mIrc 662 | 663 | return $ sPort s 664 | 665 | -- |Returns the User name 666 | getUsername :: MIrc -> IO B.ByteString 667 | getUsername mIrc = do 668 | s <- readMVar mIrc 669 | 670 | return $ sUsername s 671 | 672 | -- |Returns the Real name 673 | getRealname :: MIrc -> IO B.ByteString 674 | getRealname mIrc = do 675 | s <- readMVar mIrc 676 | 677 | return $ sRealname s 678 | 679 | -- |Returns the timestamp of the last sent message, possibly with flood control penalty 680 | getFloodControlTimestamp :: MIrc -> IO UTCTime 681 | getFloodControlTimestamp mIrc = do 682 | s <- readMVar mIrc 683 | 684 | return $ sFloodControlTimestamp s 685 | 686 | -- |Updates the value of the flood control timestamp 687 | setFloodControlTimestamp :: MIrc -> UTCTime -> IO () 688 | setFloodControlTimestamp mIrc stamp = 689 | modifyMVar_ mIrc (\i -> return i { sFloodControlTimestamp = stamp }) 690 | 691 | --------------------------------------------------------------------------------