irc 0.4.4.2 → 0.6.1.1
raw patch · 7 files changed
Files
- Network/IRC/Base.hs +34/−23
- Network/IRC/Commands.hs +20/−6
- Network/IRC/Parser.hs +115/−58
- irc.cabal +13/−5
- tests/Main.hs +179/−0
- tests/Makefile +0/−14
- tests/Tests.hs +0/−145
Network/IRC/Base.hs view
@@ -22,15 +22,19 @@ ) where import Data.Maybe+import Data.Char+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as B8 -- --------------------------------------------------------- -- Data Types -type Parameter = String-type ServerName = String-type UserName = String-type RealName = String-type Command = String+type Parameter = ByteString+type ServerName = ByteString+type UserName = ByteString+type RealName = ByteString+type Command = ByteString -- | IRC messages are parsed as:@@ -47,7 +51,7 @@ = -- | Server Prefix Server ServerName | -- | Nickname Prefix- NickName String (Maybe UserName) (Maybe ServerName)+ NickName ByteString (Maybe UserName) (Maybe ServerName) deriving (Show,Read,Eq) @@ -56,27 +60,32 @@ -- | Encode a message to its string representation-encode :: Message -> String-encode m = showMessage m+encode :: Message -> ByteString+encode = showMessage -- | This is the deprecated version of encode-render :: Message -> String+render :: Message -> ByteString render = encode -showMessage :: Message -> String-showMessage (Message p c ps) = showMaybe p ++ c ++ showParameters ps- where showMaybe = maybe "" ((++ " ") . (':':) . showPrefix)+showMessage :: Message -> ByteString+showMessage (Message p c ps) = showMaybe p `BS.append` c `BS.append` showParameters ps+ where showMaybe Nothing = BS.empty+ showMaybe (Just prefix) = BS.concat [ B8.pack ":"+ , showPrefix prefix+ , B8.pack " " ] -showPrefix :: Prefix -> String+bsConsAscii :: Char -> ByteString -> ByteString+bsConsAscii c = BS.cons (fromIntegral . ord $ c)++showPrefix :: Prefix -> ByteString showPrefix (Server s) = s-showPrefix (NickName n u h) = n ++ showMaybe '!' u ++ showMaybe '@' h- where showMaybe c e = maybe "" (c:) e+showPrefix (NickName n u h) = BS.concat [n, showMaybe '!' u, showMaybe '@' h]+ where showMaybe c e = maybe BS.empty (bsConsAscii c) e -showParameters :: [Parameter] -> String-showParameters [] = []-showParameters params = " " ++ (unwords $ showp params)- where showp [p] | ' ' `elem` p || null p || head p == ':' = [':' : p]- | otherwise = [p]+showParameters :: [Parameter] -> ByteString+showParameters [] = BS.empty+showParameters params = BS.intercalate (B8.pack " ") (BS.empty : showp params)+ where showp [p] = [bsConsAscii ':' p] showp (p:ps) = p : showp ps showp [] = [] @@ -86,13 +95,13 @@ -- | Translate a reply into its text description. -- If no text is available, the argument is returned. translateReply :: Command -- ^ Reply- -> String -- ^ Text translation+ -> ByteString -- ^ Text translation translateReply r = fromMaybe r $ lookup r replyTable -- One big lookup table of codes and errors-replyTable :: [(String,String)]-replyTable =+replyTable :: [(ByteString, ByteString)]+replyTable = map mkPair [ ("401","ERR_NOSUCHNICK") , ("402","ERR_NOSUCHSERVER") , ("403","ERR_NOSUCHCHANNEL")@@ -212,3 +221,5 @@ , ("258","RPL_ADMINLOC2") , ("259","RPL_ADMINEMAIL") ]+ where+ mkPair (a,b) = (B8.pack a, B8.pack b)
Network/IRC/Commands.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module Network.IRC.Commands ( -- * Types Channel@@ -10,15 +12,20 @@ , part , quit , privmsg+ , kick+ , pong ) where +import Data.ByteString+ import Network.IRC.Base -type Channel = String-type Password = String+type Channel = ByteString+type Password = ByteString+type Reason = ByteString -mkMessage :: String -> [Parameter] -> Message-mkMessage cmd params = Message Nothing cmd params+mkMessage :: Command -> [Parameter] -> Message+mkMessage = Message Nothing @@ -32,12 +39,19 @@ joinChan :: Channel -> Message joinChan c = mkMessage "JOIN" [c] +kick :: Channel -> UserName -> Maybe Reason -> Message+kick c u (Just r) = mkMessage "KICK" [c,u,r]+kick c u Nothing = mkMessage "KICK" [c,u]+ part :: Channel -> Message part c = mkMessage "PART" [c] -quit :: Maybe String -> Message+quit :: Maybe Reason -> Message quit (Just m) = mkMessage "QUIT" [m] quit Nothing = mkMessage "QUIT" [] -privmsg :: String -> String -> Message+privmsg :: Channel -> ByteString -> Message privmsg c m = mkMessage "PRIVMSG" [c,m]++pong :: ServerName -> Message+pong s = mkMessage "PONG" [s]
Network/IRC/Parser.hs view
@@ -4,18 +4,14 @@ decode -- :: String -> Maybe Message -- * Parsec Combinators for Parsing IRC messages- , prefix -- :: CharParser st Prefix- , serverPrefix -- :: CharParser st Prefix- , nicknamePrefix -- :: CharParser st Prefix- , command -- :: CharParser st Command- , parameter -- :: CharParser st Parameter- , message -- :: CharParser st Message- , crlf -- :: CharParser st ()- , spaces -- :: CharParser st ()-- -- * Other Parser Combinators- , tokenize -- :: CharParser st a -> CharParser st a- , takeUntil -- :: String -> CharParser st String+ , prefix -- :: Parser Prefix+ , serverPrefix -- :: Parser Prefix+ , nicknamePrefix -- :: Parser Prefix+ , command -- :: Parser Command+ , parameter -- :: Parser Parameter+ , message -- :: Parser Message+ , crlf -- :: Parser ()+ , spaces -- :: Parser () -- * Deprecated Functions , parseMessage@@ -23,73 +19,134 @@ import Network.IRC.Base -import Control.Monad-import Data.Maybe-import Text.ParserCombinators.Parsec hiding (spaces)+import Data.Char+import Data.Word+import Data.ByteString hiding (elem, map, empty) +import Control.Monad (void)+import Control.Applicative+import Data.Attoparsec.ByteString++-- | Casts a character (assumed to be ASCII) to its corresponding byte.+asciiToWord8 :: Char -> Word8+asciiToWord8 = fromIntegral . ord++wSpace :: Word8+wSpace = asciiToWord8 ' '++wTab :: Word8+wTab = asciiToWord8 '\t'++wBell :: Word8+wBell = asciiToWord8 '\b'++wDot :: Word8+wDot = asciiToWord8 '.'++wExcl :: Word8+wExcl = asciiToWord8 '!'++wAt :: Word8+wAt = asciiToWord8 '@'++wCR :: Word8+wCR = asciiToWord8 '\r'++wLF :: Word8+wLF = asciiToWord8 '\n'++wColon :: Word8+wColon = asciiToWord8 ':'+ -- | Parse a String into a Message.-decode :: String -- ^ Message string+decode :: ByteString -- ^ Message string -> Maybe Message -- ^ Parsed message-decode = (either (const Nothing) Just) . (parse message "")+decode str = case parseOnly message str of+ Left _ -> Nothing+ Right r -> Just r -- | The deprecated version of decode-parseMessage :: String -> Maybe Message+parseMessage :: ByteString -> Maybe Message parseMessage = decode --- | Take all tokens until one character from a given string is found-takeUntil :: String -> CharParser st String-takeUntil s = anyChar `manyTill` (lookAhead (oneOf s))- -- | Convert a parser that consumes all space after it-tokenize :: CharParser st a -> CharParser st a-tokenize p = p >>= \x -> spaces >> return x+tokenize :: Parser a -> Parser a+tokenize p = p <* spaces --- | Consume only spaces tabs or the bell character-spaces :: CharParser st ()-spaces = skipMany1 (oneOf " \t\b")+-- | Consume only spaces, tabs, or the bell character+spaces :: Parser ()+spaces = skip (\w -> w == wSpace ||+ w == wTab ||+ w == wBell) -- | Parse a Prefix-prefix :: CharParser st Prefix-prefix = char ':' >> (try nicknamePrefix <|> serverPrefix)+prefix :: Parser Prefix+prefix = word8 wColon *> (try nicknamePrefix <|> serverPrefix)+ <?> "prefix" -- | Parse a Server prefix-serverPrefix :: CharParser st Prefix-serverPrefix = takeUntil " " >>= return . Server+serverPrefix :: Parser Prefix+serverPrefix = Server <$> takeTill (== wSpace)+ <?> "serverPrefix" +-- | optionMaybe p tries to apply parser p. If p fails without consuming input,+-- | it return Nothing, otherwise it returns Just the value returned by p.+optionMaybe :: Parser a -> Parser (Maybe a)+optionMaybe p = option Nothing (Just <$> p)+ -- | Parse a NickName prefix-nicknamePrefix :: CharParser st Prefix+nicknamePrefix :: Parser Prefix nicknamePrefix = do- n <- takeUntil " .!@\r\n"- p <- option False (char '.' >> return True)- when p (fail "")- u <- optionMaybe $ char '!' >> takeUntil " @\r\n"- s <- optionMaybe $ char '@' >> takeUntil " \r\n"- return $ NickName n u s+ n <- takeTill (inClass " .!@\r\n")+ p <- peekWord8+ case p of+ Just c | c == wDot -> empty+ _ -> NickName n <$>+ optionMaybe (word8 wExcl *> takeTill (\w -> w == wSpace ||+ w == wAt ||+ w == wCR ||+ w == wLF))+ <*> optionMaybe (word8 wAt *> takeTill (\w -> w == wSpace ||+ w == wCR ||+ w == wLF))+ <?> "nicknamePrefix" +isWordAsciiUpper :: Word8 -> Bool+isWordAsciiUpper w = asciiToWord8 'A' <= w && w <= asciiToWord8 'Z'++digit :: Parser Word8+digit = satisfy (\w -> asciiToWord8 '0' <= w && w <= asciiToWord8 '9')+ -- | Parse a command. Either a string of capital letters, or 3 digits.-command :: CharParser st Command-command = (many1 upper)- <|> do x <- digit- y <- digit- z <- digit- return [x,y,z]+command :: Parser Command+command = takeWhile1 isWordAsciiUpper+ <|> digitsToByteString <$>+ digit+ <*> digit+ <*> digit+ <?> "command"+ where digitsToByteString x y z = pack [x,y,z] -- | Parse a command parameter.-parameter :: CharParser st Parameter-parameter = (char ':' >> takeUntil "\r\n")- <|> (takeUntil " \r\n")+parameter :: Parser Parameter+parameter = (word8 wColon *> takeTill (\w -> w == wCR ||+ w == wLF))+ <|> takeTill (\w -> w == wSpace ||+ w == wCR ||+ w == wLF)+ <?> "parameter" -- | Parse a cr lf-crlf :: CharParser st ()-crlf = (char '\r' >> optional (char '\n'))- <|> (char '\n' >> return () )-+crlf :: Parser ()+crlf = void (word8 wCR *> optional (word8 wLF))+ <|> void (word8 wLF) -- | Parse a Message-message :: CharParser st Message-message = do- p <- optionMaybe $ tokenize prefix- c <- command- ps <- many (spaces >> parameter)- crlf >> eof- return $ Message p c ps+message :: Parser Message+message = Message <$>+ optionMaybe (tokenize prefix)+ <*> command+ <*> many (some spaces *> parameter)+ <* optional crlf+ <* endOfInput+ <?> "message"
irc.cabal view
@@ -1,15 +1,13 @@ name: irc synopsis: A small library for parsing IRC messages. description: A set of combinators and types for parsing IRC messages.-version: 0.4.4.2+version: 0.6.1.1 category: Data, Network license: BSD3 license-file: LICENSE author: Trevor Elliott maintainer: trevor@geekgateway.com-extra-source-files: tests/Makefile,- tests/Tests.hs-cabal-version: >= 1.6.0+cabal-version: >= 1.10 build-type: Simple source-repository head@@ -18,8 +16,18 @@ library ghc-options: -Wall- build-depends: base == 4.*, parsec == 2.1.*+ default-language: Haskell2010+ build-depends: base == 4.*, attoparsec, bytestring exposed-Modules: Network.IRC, Network.IRC.Base, Network.IRC.Commands, Network.IRC.Parser++test-suite Main+ type: exitcode-stdio-1.0+ x-uses-tf: true+ build-depends: base == 4.*, HUnit >= 1.2 && < 2, QuickCheck >= 2.4, test-framework >= 0.4.1, test-framework-quickcheck2, test-framework-hunit, bytestring, irc+ ghc-options: -Wall+ hs-source-dirs: tests+ default-language: Haskell2010+ main-is: Main.hs
+ tests/Main.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE OverloadedStrings #-}+module Main+ (+ main+ ) where++import Network.IRC++import Data.ByteString (ByteString, append, pack)+import Data.Word (Word8)+import Data.Char (ord)++import Control.Applicative (liftA)++import Test.HUnit+import Test.QuickCheck++import Test.Framework as TF (defaultMain, testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2 (testProperty)++-- ---------------------------------------------------------+-- Helpful Wrappers++-- An identifier starts with a letter, and consists of interspersed numbers+-- and special characters+newtype Identifier = Identifier { unIdentifier :: ByteString }+ deriving (Read,Show,Eq)++instance Arbitrary Identifier where+ arbitrary = do+ l <- letter+ ls <- sized $ \n -> loop n+ return $ Identifier (pack (l:ls))+ where loop n | n <= 0 = return []+ | otherwise = do i <- identifier+ is <- loop (n-1)+ return (i:is)++-- A hostname is a string that starts and ends with an identifier, and has+-- periods peppered in the middle.+newtype Host = Host { unHost :: ByteString }++instance Arbitrary Host where+ arbitrary = do+ l <- identifier+ ls <- sized $ \n -> loop n+ js <- sized $ \n -> loop n+ e <- identifier+ return $ Host (pack (l:ls ++ (w8 '.':js) ++ [e]))+ where loop n | n <= 0 = return []+ | otherwise = do i <- host+ is <- loop (n-1)+ return (i:is)+++w8 :: Char -> Word8+w8 = fromIntegral . ord++letter :: Gen Word8+letter = frequency+ [ (50, choose (w8 'a', w8 'z'))+ , (50, choose (w8 'A', w8 'Z'))+ ]++digit :: Gen Word8+digit = choose (w8 '0', w8 '9')++special :: Gen Word8+special = elements [w8 '_', w8 '-']++identifier :: Gen Word8+identifier = frequency+ [ (50, letter)+ , (30, digit)+ , (10, special)+ ]++host :: Gen Word8+host = frequency+ [ (90, identifier)+ , (20, return (w8 '.'))+ ]++-- ---------------------------------------------------------+-- IRC Types++newtype Cmd = Cmd { unCmd :: ByteString }+ deriving (Read,Show,Eq)++instance Arbitrary Cmd where+ arbitrary =+ let c = (replyTable !!) <$> choose (0, length replyTable - 1)+ in Cmd . fst <$> c++instance Arbitrary Prefix where+ arbitrary = oneof+ [ NickName+ <$> fmap unIdentifier arbitrary+ <*> fmap (liftA unIdentifier) arbitrary+ <*> fmap (liftA unIdentifier) arbitrary+ , Server+ <$> fmap unHost arbitrary+ ]++instance Arbitrary Message where+ arbitrary =+ let params = map unIdentifier <$> sized vector+ cmd = unCmd <$> arbitrary+ in Message <$> arbitrary <*> cmd <*> params++-- ---------------------------------------------------------+-- Properties++prop_encodeDecode :: Message -> Bool+prop_encodeDecode msg = (decode . appendCRLF . encode $ msg)+ == Just msg+ where appendCRLF bs = append bs (pack [w8 '\r', w8 '\n'])++properties :: TF.Test+properties = testGroup "QuickCheck Network.IRC"+ [ testProperty "encodeDecode" prop_encodeDecode+ ]++-- ---------------------------------------------------------+-- Unit Tests++unitTests :: TF.Test+unitTests = testGroup "HUnit tests Network.IRC"+ [ -- Decoding tests+ testCase "PRIVMSG foo :bar baz"+ ( decode "PRIVMSG foo :bar baz"+ @=? Just (Message Nothing "PRIVMSG" ["foo", "bar baz"]))+ , testCase ":foo.bar NOTICE baz baz :baz baz"+ ( decode ":foo.bar NOTICE baz baz :baz baz"+ @=? Just (Message (Just (Server "foo.bar")) "NOTICE" ["baz", "baz", "baz baz"]))+ , testCase ":foo.bar 001 baz baz :baz baz"+ ( decode ":foo.bar 001 baz baz :baz baz"+ @=? Just (Message (Just (Server "foo.bar")) "001" ["baz", "baz", "baz baz"]))+ , testCase ":foo!bar@baz PRIVMSG #foo :bar baz"+ ( decode ":foo!bar@baz PRIVMSG #foo :bar baz"+ @=? Just (Message (Just (NickName "foo" (Just "bar") (Just "baz"))) "PRIVMSG" ["#foo", "bar baz"]))+ , testCase ":foo@baz PRIVMSG #foo :bar baz"+ ( decode ":foo@baz PRIVMSG #foo :bar baz"+ @=? Just (Message (Just (NickName "foo" Nothing (Just "baz"))) "PRIVMSG" ["#foo", "bar baz"]))+ , testCase ":foo!bar PRIVMSG #foo :bar baz"+ ( decode ":foo!bar PRIVMSG #foo :bar baz"+ @=? Just (Message (Just (NickName "foo" (Just "bar") Nothing)) "PRIVMSG" ["#foo", "bar baz"]))+ , testCase ":foo PRIVMSG #foo :bar baz"+ ( decode ":foo PRIVMSG #foo :bar baz"+ @=? Just (Message (Just (NickName "foo" Nothing Nothing)) "PRIVMSG" ["#foo", "bar baz"]))++ -- Decoding tests++ -- Initial colon encoding tests+ , testCase "Message Nothing \"PRIVMSG\" [\"#foo\", \":bar bas\"]"+ ( encode (Message Nothing "PRIVMSG" ["#foo", ":bar bas"])+ @?= "PRIVMSG #foo ::bar bas")+ , testCase "Message Nothing \"PRIVMSG\" [\"#foo\", \":bar\"]"+ ( encode (Message Nothing "PRIVMSG" ["#foo", ":bar"])+ @?= "PRIVMSG #foo ::bar")++ -- Corrected case+ , testCase ":talon.nl.eu.SwiftIRC.net 332 foo #bar :\n"+ ( decode ":talon.nl.eu.SwiftIRC.net 332 foo #bar :\n"+ @?= Just (Message (Just $ Server "talon.nl.eu.SwiftIRC.net") "332" ["foo","#bar",""]))+ ]++-- ---------------------------------------------------------+-- Test List++tests :: [TF.Test]+tests = [ properties+ , unitTests+ ]++main :: IO ()+main = defaultMain tests+
− tests/Makefile
@@ -1,14 +0,0 @@-ODIR = .ghc-TARGET = Tests--all : $(ODIR)- ghc --make -odir=$(ODIR) -hidir=$(ODIR) $(TARGET) -i../- ./$(TARGET)--$(ODIR) :- mkdir $(ODIR)--clean :- $(RM) -r $(ODIR) $(TARGET)--.PHONY: all clean
− tests/Tests.hs
@@ -1,145 +0,0 @@-module Main where---- Friends-import Network.IRC---- Libraries-import Control.Applicative-import Control.Monad-import System.Random-import Test.QuickCheck-import Test.HUnit---instance Applicative Gen where- (<*>) = ap- pure = return---- ------------------------------------------------------------ Helpful Wrappers---- An identifier starts with a letter, and consists of interspersed numbers--- and special characters-newtype Identifier = Identifier { unIdentifier :: String }- deriving (Read,Show,Eq)--instance Arbitrary Identifier where- arbitrary = do- l <- letter- ls <- sized $ \n -> loop n- return $ Identifier (l:ls)- where loop n | n <= 0 = return []- | otherwise = do i <- identifier- is <- loop (n-1)- return (i:is)---- A hostname is a string that starts and ends with an identifier, and has--- periods peppered in the middle.-newtype Host = Host { unHost :: String }--instance Arbitrary Host where- arbitrary = do- l <- identifier- ls <- sized $ \n -> loop n- js <- sized $ \n -> loop n- e <- identifier- return $ Host (l:ls ++ ('.':js) ++ [e])- where loop n | n <= 0 = return []- | otherwise = do i <- host- is <- loop (n-1)- return (i:is)---letter :: Gen Char-letter = frequency- [ (50, choose ('a','z'))- , (50, choose ('A','Z'))- ]--digit :: Gen Char-digit = choose ('0','9')--special :: Gen Char-special = elements ['_','-']--identifier :: Gen Char-identifier = frequency- [ (50, letter)- , (30, digit)- , (10, special)- ]--host :: Gen Char-host = frequency- [ (90, identifier)- , (20, return '.')- ]---- ------------------------------------------------------------ IRC Types--newtype Cmd = Cmd { unCmd :: String }- deriving (Read,Show,Eq)--instance Arbitrary Cmd where- arbitrary =- let c = (replyTable !!) <$> choose (0, length replyTable - 1)- in Cmd . fst <$> c---instance Arbitrary Prefix where- arbitrary = oneof- [ do name <- unIdentifier <$> arbitrary- user <- (liftM unIdentifier) <$> arbitrary- host <- (liftM unIdentifier) <$> arbitrary- return $ NickName name user host- , do host <- unHost <$> arbitrary- return $ Server host- ]---instance Arbitrary Message where- arbitrary =- let params = map unIdentifier <$> sized vector- cmd = unCmd <$> arbitrary- in Message <$> arbitrary <*> cmd <*> params----- ------------------------------------------------------------ Properties--prop_ircId :: Message -> Bool-prop_ircId msg = (decode . (++ "\r\n") . encode $ msg) == Just msg----- ------------------------------------------------------------ Unit Tests--tests :: Test-tests = TestList $ map TestCase- -- Initial colon encoding tests- [ encode (Message Nothing "PRIVMSG" ["#foo", ":bar bas"]) @?=- "PRIVMSG #foo ::bar bas"- , encode (Message Nothing "PRIVMSG" ["#foo", ":bar"]) @?=- "PRIVMSG #foo ::bar"-- -- Corrected case- , decode ":talon.nl.eu.SwiftIRC.net 332 foo #bar :\n" @?=- Just (Message (Just $ Server "talon.nl.eu.SwiftIRC.net")- "332" ["foo","#bar",""])- ]----- ------------------------------------------------------------ Test Running--header :: String -> IO ()-header s = putStrLn "" >> putStrLn s >> putStrLn (replicate 60 '*')--main :: IO Counts-main = do- header "Checking irc encode/decode identity"- quickCheck prop_ircId-- header "Checking individual test cases"- runTestTT tests