diff --git a/Network/IRC.hs b/Network/IRC.hs
--- a/Network/IRC.hs
+++ b/Network/IRC.hs
@@ -20,7 +20,7 @@
--
-- Maintainer : trevor@geekgateway.com
-- Stability : experimental
--- Portability : non-portable (GADT's)
+-- Portability : non-portable
--
-- library for parsing IRC messages
--
@@ -28,9 +28,13 @@
-- * Parsers
module Network.IRC.Parser
- -- * Types
- , module Network.IRC.Types
+ -- * Base
+ , module Network.IRC.Base
+
+ -- * Message API
+ , module Network.IRC.Commands
) where
import Network.IRC.Parser
-import Network.IRC.Types
+import Network.IRC.Base
+import Network.IRC.Commands
diff --git a/Network/IRC/Base.hs b/Network/IRC/Base.hs
new file mode 100644
--- /dev/null
+++ b/Network/IRC/Base.hs
@@ -0,0 +1,228 @@
+-- This file is part of irc.
+
+-- irc is free software; you can redistribute it and/or modify
+-- it under the terms of the GNU Lesser General Public License as published by
+-- the Free Software Foundation; either version 3 of the License, or
+-- (at your option) any later version.
+
+-- irc is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU Lesser General Public License for more details.
+
+-- You should have received a copy of the GNU Lesser General Public License
+-- along with this program. If not, see .
+
+-- | Datatypes for representing IRC messages, as well as formatting them.
+module Network.IRC.Base (
+ -- * Type Synonyms
+ Parameter
+ , ServerName
+ , UserName
+ , RealName
+ , Command
+
+ -- * IRC Datatypes
+ , Prefix(Server, NickName)
+ , Message(Message)
+
+ -- * Formatting functions
+ , encode -- :: Message -> String
+ , showMessage, showPrefix, showParameters
+ , translateReply -- :: String -> String
+ , replyTable -- :: [(String,String)]
+
+ -- * Deprecated
+ , render
+ ) where
+
+import Data.Maybe
+
+-- ---------------------------------------------------------
+-- Data Types
+
+type Parameter = String
+type ServerName = String
+type UserName = String
+type RealName = String
+type Command = String
+
+
+-- | IRC messages are parsed as:
+-- [ ':' prefix space ] command { space param } crlf
+data Message
+ = -- | IRC Message
+ Message (Maybe Prefix) Command [Parameter]
+ deriving (Show,Read,Eq)
+
+
+-- | The optional beginning of an IRC messages
+data Prefix
+ = -- | Server Prefix
+ Server ServerName
+ | -- | Nickname Prefix
+ NickName String (Maybe UserName) (Maybe ServerName)
+ deriving (Show,Read,Eq)
+
+
+-- ---------------------------------------------------------
+-- Formatting
+
+
+-- | Encode a message to its string representation
+encode :: Message -> String
+encode m = showMessage m
+
+-- | This is the deprecated version of encode
+render :: Message -> String
+render = encode
+
+showMessage :: Message -> String
+showMessage (Message p c ps) = showMaybe p ++ c ++ showParameters ps
+ where showMaybe = maybe "" ((++ " ") . (':':) . showPrefix)
+
+showPrefix :: Prefix -> String
+showPrefix (Server s) = s
+showPrefix (NickName n u h) = n ++ showMaybe '!' u ++ showMaybe '@' h
+ where showMaybe c e = maybe "" (c:) e
+
+showParameters :: [Parameter] -> String
+showParameters [] = []
+showParameters ps = " " ++ (unwords $ showp ps)
+ where showp [] = []
+ showp p@(x:xs) | ' ' `elem` x = [':' : unwords p]
+ | otherwise = x : showp xs
+
+
+-- ---------------------------------------------------------
+-- Message Translation
+
+-- | Translate a reply into its text description.
+-- If no text is available, the argument is returned.
+translateReply :: Command -- ^ Reply
+ -> String -- ^ Text translation
+translateReply r = fromMaybe r $ lookup r replyTable
+
+
+-- One big lookup table of codes and errors
+replyTable :: [(String,String)]
+replyTable =
+ [ ("401","ERR_NOSUCHNICK")
+ , ("402","ERR_NOSUCHSERVER")
+ , ("403","ERR_NOSUCHCHANNEL")
+ , ("404","ERR_CANNOTSENDTOCHAN")
+ , ("405","ERR_TOOMANYCHANNELS")
+ , ("406","ERR_WASNOSUCHNICK")
+ , ("407","ERR_TOOMANYTARGETS")
+ , ("409","ERR_NOORIGIN")
+ , ("411","ERR_NORECIPIENT")
+ , ("412","ERR_NOTEXTTOSEND")
+ , ("413","ERR_NOTOPLEVEL")
+ , ("414","ERR_WILDTOPLEVEL")
+ , ("421","ERR_UNKNOWNCOMMAND")
+ , ("422","ERR_NOMOTD")
+ , ("423","ERR_NOADMININFO")
+ , ("424","ERR_FILEERROR")
+ , ("431","ERR_NONICKNAMEGIVEN")
+ , ("432","ERR_ERRONEUSNICKNAME")
+ , ("433","ERR_NICKNAMEINUSE")
+ , ("436","ERR_NICKCOLLISION")
+ , ("441","ERR_USERNOTINCHANNEL")
+ , ("442","ERR_NOTONCHANNEL")
+ , ("443","ERR_USERONCHANNEL")
+ , ("444","ERR_NOLOGIN")
+ , ("445","ERR_SUMMONDISABLED")
+ , ("446","ERR_USERSDISABLED")
+ , ("451","ERR_NOTREGISTERED")
+ , ("461","ERR_NEEDMOREPARAMS")
+ , ("462","ERR_ALREADYREGISTRED")
+ , ("463","ERR_NOPERMFORHOST")
+ , ("464","ERR_PASSWDMISMATCH")
+ , ("465","ERR_YOUREBANNEDCREEP")
+ , ("467","ERR_KEYSET")
+ , ("471","ERR_CHANNELISFULL")
+ , ("472","ERR_UNKNOWNMODE")
+ , ("473","ERR_INVITEONLYCHAN")
+ , ("474","ERR_BANNEDFROMCHAN")
+ , ("475","ERR_BADCHANNELKEY")
+ , ("481","ERR_NOPRIVILEGES")
+ , ("482","ERR_CHANOPRIVSNEEDED")
+ , ("483","ERR_CANTKILLSERVER")
+ , ("491","ERR_NOOPERHOST")
+ , ("501","ERR_UMODEUNKNOWNFLAG")
+ , ("502","ERR_USERSDONTMATCH")
+ , ("300","RPL_NONE")
+ , ("302","RPL_USERHOST")
+ , ("303","RPL_ISON")
+ , ("301","RPL_AWAY")
+ , ("305","RPL_UNAWAY")
+ , ("306","RPL_NOWAWAY")
+ , ("311","RPL_WHOISUSER")
+ , ("312","RPL_WHOISSERVER")
+ , ("313","RPL_WHOISOPERATOR")
+ , ("317","RPL_WHOISIDLE")
+ , ("318","RPL_ENDOFWHOIS")
+ , ("319","RPL_WHOISCHANNELS")
+ , ("314","RPL_WHOWASUSER")
+ , ("369","RPL_ENDOFWHOWAS")
+ , ("321","RPL_LISTSTART")
+ , ("322","RPL_LIST")
+ , ("323","RPL_LISTEND")
+ , ("324","RPL_CHANNELMODEIS")
+ , ("331","RPL_NOTOPIC")
+ , ("332","RPL_TOPIC")
+ , ("341","RPL_INVITING")
+ , ("342","RPL_SUMMONING")
+ , ("351","RPL_VERSION")
+ , ("352","RPL_WHOREPLY")
+ , ("315","RPL_ENDOFWHO")
+ , ("353","RPL_NAMREPLY")
+ , ("366","RPL_ENDOFNAMES")
+ , ("364","RPL_LINKS")
+ , ("365","RPL_ENDOFLINKS")
+ , ("367","RPL_BANLIST")
+ , ("368","RPL_ENDOFBANLIST")
+ , ("371","RPL_INFO")
+ , ("374","RPL_ENDOFINFO")
+ , ("375","RPL_MOTDSTART")
+ , ("372","RPL_MOTD")
+ , ("376","RPL_ENDOFMOTD")
+ , ("381","RPL_YOUREOPER")
+ , ("382","RPL_REHASHING")
+ , ("391","RPL_TIME")
+ , ("392","RPL_USERSSTART")
+ , ("393","RPL_USERS")
+ , ("394","RPL_ENDOFUSERS")
+ , ("395","RPL_NOUSERS")
+ , ("200","RPL_TRACELINK")
+ , ("201","RPL_TRACECONNECTING")
+ , ("202","RPL_TRACEHANDSHAKE")
+ , ("203","RPL_TRACEUNKNOWN")
+ , ("204","RPL_TRACEOPERATOR")
+ , ("205","RPL_TRACEUSER")
+ , ("206","RPL_TRACESERVER")
+ , ("208","RPL_TRACENEWTYPE")
+ , ("261","RPL_TRACELOG")
+ , ("211","RPL_STATSLINKINFO")
+ , ("212","RPL_STATSCOMMANDS")
+ , ("213","RPL_STATSCLINE")
+ , ("214","RPL_STATSNLINE")
+ , ("215","RPL_STATSILINE")
+ , ("216","RPL_STATSKLINE")
+ , ("218","RPL_STATSYLINE")
+ , ("219","RPL_ENDOFSTATS")
+ , ("241","RPL_STATSLLINE")
+ , ("242","RPL_STATSUPTIME")
+ , ("243","RPL_STATSOLINE")
+ , ("244","RPL_STATSHLINE")
+ , ("221","RPL_UMODEIS")
+ , ("251","RPL_LUSERCLIENT")
+ , ("252","RPL_LUSEROP")
+ , ("253","RPL_LUSERUNKNOWN")
+ , ("254","RPL_LUSERCHANNELS")
+ , ("255","RPL_LUSERME")
+ , ("256","RPL_ADMINME")
+ , ("257","RPL_ADMINLOC1")
+ , ("258","RPL_ADMINLOC2")
+ , ("259","RPL_ADMINEMAIL")
+ ]
diff --git a/Network/IRC/Commands.hs b/Network/IRC/Commands.hs
new file mode 100644
--- /dev/null
+++ b/Network/IRC/Commands.hs
@@ -0,0 +1,43 @@
+module Network.IRC.Commands (
+ -- * Types
+ Channel
+ , Password
+
+ -- * IRC Functions
+ , nick
+ , user
+ , joinChan
+ , part
+ , quit
+ , privmsg
+ ) where
+
+import Network.IRC.Base
+
+type Channel = String
+type Password = String
+
+mkMessage :: String -> [Parameter] -> Message
+mkMessage cmd params = Message Nothing cmd params
+
+
+
+
+nick :: UserName -> Message
+nick u = mkMessage "NICK" [u]
+
+user :: UserName -> ServerName -> ServerName -> RealName -> Message
+user u h s r = mkMessage "USER" [u,h,s,r]
+
+joinChan :: Channel -> Message
+joinChan c = mkMessage "JOIN" [c]
+
+part :: Channel -> Message
+part c = mkMessage "PART" [c]
+
+quit :: Maybe String -> Message
+quit (Just m) = mkMessage "QUIT" [m]
+quit Nothing = mkMessage "QUIT" []
+
+privmsg :: String -> String -> Message
+privmsg c m = mkMessage "PRIVMSG" [c,m]
diff --git a/Network/IRC/Parser.hs b/Network/IRC/Parser.hs
--- a/Network/IRC/Parser.hs
+++ b/Network/IRC/Parser.hs
@@ -16,42 +16,44 @@
-- | Parsec parsers and a general parsing interface for IRC messages
module Network.IRC.Parser (
-- * Parsing and Formatting Functions
- parseMessage -- :: String -> Maybe Message
+ 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 ()
+ , 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
- , maybeP -- :: GenParser tok st a -> GenParser tok st (Maybe a)
, tokenize -- :: CharParser st a -> CharParser st a
, takeUntil -- :: String -> CharParser st String
+
+ -- * Deprecated Functions
+ , parseMessage
) where
+import Network.IRC.Base
+
import Control.Monad
import Data.Maybe
import Text.ParserCombinators.Parsec hiding (spaces)
-import Network.IRC.Types
-
-- | Parse a String into a Message.
-parseMessage :: String -- ^ Message string
- -> Maybe Message -- ^ Parsed message
-parseMessage = (either (const Nothing) Just) . (parse message "")
+decode :: String -- ^ Message string
+ -> Maybe Message -- ^ Parsed message
+decode = (either (const Nothing) Just) . (parse message "")
+-- | The deprecated version of decode
+parseMessage :: String -> Maybe Message
+parseMessage = decode
+
-- | Take all tokens until one character from a given string is found
takeUntil :: String -> CharParser st String
-takeUntil = many1 . noneOf
-
--- | Convert a parser into an optional one that returns a Maybe
-maybeP :: GenParser tok st a -> GenParser tok st (Maybe a)
-maybeP p = option Nothing (liftM Just p)
+takeUntil s = anyChar `manyTill` (lookAhead (oneOf s))
-- | Convert a parser that consumes all space after it
tokenize :: CharParser st a -> CharParser st a
@@ -75,13 +77,13 @@
n <- takeUntil " .!@\r\n"
p <- option False (char '.' >> return True)
when p (fail "")
- u <- maybeP $ char '!' >> takeUntil " @\r\n"
- s <- maybeP $ char '@' >> takeUntil " \r\n"
+ u <- optionMaybe $ char '!' >> takeUntil " @\r\n"
+ s <- optionMaybe $ char '@' >> takeUntil " \r\n"
return $ NickName n u s
-- | Parse a command. Either a string of capital letters, or 3 digits.
command :: CharParser st Command
-command = many1 upper
+command = (many1 upper)
<|> do x <- digit
y <- digit
z <- digit
@@ -99,7 +101,7 @@
-- | Parse a Message
message :: CharParser st Message
message = do
- p <- maybeP $ tokenize prefix
+ p <- optionMaybe $ tokenize prefix
c <- command
ps <- many (spaces >> parameter)
crlf >> eof
diff --git a/Network/IRC/Types.hs b/Network/IRC/Types.hs
deleted file mode 100644
--- a/Network/IRC/Types.hs
+++ /dev/null
@@ -1,283 +0,0 @@
--- This file is part of irc.
-
--- irc is free software; you can redistribute it and/or modify
--- it under the terms of the GNU Lesser General Public License as published by
--- the Free Software Foundation; either version 3 of the License, or
--- (at your option) any later version.
-
--- irc is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of
--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
--- GNU Lesser General Public License for more details.
-
--- You should have received a copy of the GNU Lesser General Public License
--- along with this program. If not, see .
-
--- | Datatypes for representing IRC messages, as well as formatting them.
-module Network.IRC.Types (
- -- * Type Synonyms
- Parameter
- , ServerName
- , UserName
- , RealName
- , Command
-
- -- * Properties
- , Prop(renderProp)
- , Mode(Add, Remove)
- , UserProp(..)
- , ChanProp(..)
-
- -- * IRC Datatypes
- , Prefix(Server, NickName)
- , Message(Message)
-
- -- * Formatting functions
- , render -- :: Message -> String
- , renderMode -- :: (Prop p) => Mode p -> String
- , translateReply -- :: String -> String
- ) where
-
-import Data.Maybe
-
-type Command = String
-type Parameter = String
-type ServerName = String
-type UserName = String
-type RealName = String
-
--- | IRC messages are parsed as:
--- [ ':' prefix space ] command { space param } crlf
-data Message
- = -- | IRC Message
- Message (Maybe Prefix) Command [Parameter]
- deriving (Show,Read,Eq)
-
--- | The optional beginning of an IRC messages
-data Prefix
- = -- | Server Prefix
- Server ServerName
- | -- | Nickname Prefix
- NickName String (Maybe UserName) (Maybe ServerName)
- deriving (Show,Read,Eq)
-
--- | IRC Modes
-data Mode p where
- Add :: (Prop p) => [p] -> Mode p
- Remove :: (Prop p) => [p] -> Mode p
-
-instance Show p => Show (Mode p) where
- show (Add ps) = "Add " ++ show ps
- show (Remove ps) = "Remove " ++ show ps
-
--- Render a mode string
-renderMode :: (Prop p) => Mode p -> String
-renderMode (Add ps) = "+" ++ (concat $ map renderProp ps)
-renderMode (Remove ps) = "-" ++ (concat $ map renderProp ps)
-
--- | Property class
-class Prop a where
- renderProp :: a -> String
-
--- | User properties
-data UserProp
- = UserOp
- | Invisible
- | ServerNotices
- | Wallops
- deriving (Show,Eq)
-
-instance Prop UserProp where
- renderProp p = fromMaybe "" (p `lookup` userPropTable)
-
-userPropTable :: [(UserProp,String)]
-userPropTable =
- [ (UserOp, "o")
- , (Invisible, "i")
- , (ServerNotices, "s")
- , (Wallops, "w")
- ]
-
--- | Channel properties
-data ChanProp
- = ChanOp
- | Private
- | Secret
- | InviteOnly
- | TopicOpOnly
- | NoOutsideMessages
- | Moderated
- | UserLimit
- | BanMask
- | Speak
- | Password
- deriving (Show,Eq)
-
-instance Prop ChanProp where
- renderProp p = fromMaybe "" (p `lookup` chanPropTable)
-
-chanPropTable :: [(ChanProp,String)]
-chanPropTable =
- [ (ChanOp, "o")
- , (Private, "p")
- , (Secret, "s")
- , (InviteOnly, "i")
- , (TopicOpOnly, "t")
- , (NoOutsideMessages, "n")
- , (Moderated, "m")
- , (UserLimit, "l")
- , (BanMask, "b")
- , (Speak, "v")
- , (Password, "k")
- ]
-
--- | Message rendering
-render :: Message -- ^ IRC Message
- -> String -- ^ Rendered message
-render (Message p c args) =
- (maybe "" (\p' -> formatPrefix p' ++ " ") p) ++ c ++ " "
- ++ formatArgs args
-
-formatPrefix :: Prefix -> String
-formatPrefix (Server n) = ":" ++ n
-formatPrefix (NickName n u s) = ":" ++ n
- ++ maybe "" (\u' -> "!" ++ u') u
- ++ maybe "" (\s' -> "@" ++ s') s
-
--- Format a parameter string
-formatArgs :: [Parameter] -> String
-formatArgs = unwords . formatArgs' . filter ((>0) . length)
-
-formatArgs' :: [Parameter] -> [String]
-formatArgs' [] = []
-formatArgs' l@(p:ps) | elem ' ' p = [":" ++ unwords l]
- | otherwise = p : formatArgs' ps
-
--- | Translate a reply into the text version of the reply.
--- If no text version is available, the argument is returned.
-translateReply :: Command -- ^ Reply
- -> String -- ^ Text translation
-translateReply r = fromMaybe r $ lookup r replyTable
-
--- One big lookup table of codes and errors
-replyTable :: [(String,String)]
-replyTable =
- [ ("401","ERR_NOSUCHNICK")
- , ("402","ERR_NOSUCHSERVER")
- , ("403","ERR_NOSUCHCHANNEL")
- , ("404","ERR_CANNOTSENDTOCHAN")
- , ("405","ERR_TOOMANYCHANNELS")
- , ("406","ERR_WASNOSUCHNICK")
- , ("407","ERR_TOOMANYTARGETS")
- , ("409","ERR_NOORIGIN")
- , ("411","ERR_NORECIPIENT")
- , ("412","ERR_NOTEXTTOSEND")
- , ("413","ERR_NOTOPLEVEL")
- , ("414","ERR_WILDTOPLEVEL")
- , ("421","ERR_UNKNOWNCOMMAND")
- , ("422","ERR_NOMOTD")
- , ("423","ERR_NOADMININFO")
- , ("424","ERR_FILEERROR")
- , ("431","ERR_NONICKNAMEGIVEN")
- , ("432","ERR_ERRONEUSNICKNAME")
- , ("433","ERR_NICKNAMEINUSE")
- , ("436","ERR_NICKCOLLISION")
- , ("441","ERR_USERNOTINCHANNEL")
- , ("442","ERR_NOTONCHANNEL")
- , ("443","ERR_USERONCHANNEL")
- , ("444","ERR_NOLOGIN")
- , ("445","ERR_SUMMONDISABLED")
- , ("446","ERR_USERSDISABLED")
- , ("451","ERR_NOTREGISTERED")
- , ("461","ERR_NEEDMOREPARAMS")
- , ("462","ERR_ALREADYREGISTRED")
- , ("463","ERR_NOPERMFORHOST")
- , ("464","ERR_PASSWDMISMATCH")
- , ("465","ERR_YOUREBANNEDCREEP")
- , ("467","ERR_KEYSET")
- , ("471","ERR_CHANNELISFULL")
- , ("472","ERR_UNKNOWNMODE")
- , ("473","ERR_INVITEONLYCHAN")
- , ("474","ERR_BANNEDFROMCHAN")
- , ("475","ERR_BADCHANNELKEY")
- , ("481","ERR_NOPRIVILEGES")
- , ("482","ERR_CHANOPRIVSNEEDED")
- , ("483","ERR_CANTKILLSERVER")
- , ("491","ERR_NOOPERHOST")
- , ("501","ERR_UMODEUNKNOWNFLAG")
- , ("502","ERR_USERSDONTMATCH")
- , ("300","RPL_NONE")
- , ("302","RPL_USERHOST")
- , ("303","RPL_ISON")
- , ("301","RPL_AWAY")
- , ("305","RPL_UNAWAY")
- , ("306","RPL_NOWAWAY")
- , ("311","RPL_WHOISUSER")
- , ("312","RPL_WHOISSERVER")
- , ("313","RPL_WHOISOPERATOR")
- , ("317","RPL_WHOISIDLE")
- , ("318","RPL_ENDOFWHOIS")
- , ("319","RPL_WHOISCHANNELS")
- , ("314","RPL_WHOWASUSER")
- , ("369","RPL_ENDOFWHOWAS")
- , ("321","RPL_LISTSTART")
- , ("322","RPL_LIST")
- , ("323","RPL_LISTEND")
- , ("324","RPL_CHANNELMODEIS")
- , ("331","RPL_NOTOPIC")
- , ("332","RPL_TOPIC")
- , ("341","RPL_INVITING")
- , ("342","RPL_SUMMONING")
- , ("351","RPL_VERSION")
- , ("352","RPL_WHOREPLY")
- , ("315","RPL_ENDOFWHO")
- , ("353","RPL_NAMREPLY")
- , ("366","RPL_ENDOFNAMES")
- , ("364","RPL_LINKS")
- , ("365","RPL_ENDOFLINKS")
- , ("367","RPL_BANLIST")
- , ("368","RPL_ENDOFBANLIST")
- , ("371","RPL_INFO")
- , ("374","RPL_ENDOFINFO")
- , ("375","RPL_MOTDSTART")
- , ("372","RPL_MOTD")
- , ("376","RPL_ENDOFMOTD")
- , ("381","RPL_YOUREOPER")
- , ("382","RPL_REHASHING")
- , ("391","RPL_TIME")
- , ("392","RPL_USERSSTART")
- , ("393","RPL_USERS")
- , ("394","RPL_ENDOFUSERS")
- , ("395","RPL_NOUSERS")
- , ("200","RPL_TRACELINK")
- , ("201","RPL_TRACECONNECTING")
- , ("202","RPL_TRACEHANDSHAKE")
- , ("203","RPL_TRACEUNKNOWN")
- , ("204","RPL_TRACEOPERATOR")
- , ("205","RPL_TRACEUSER")
- , ("206","RPL_TRACESERVER")
- , ("208","RPL_TRACENEWTYPE")
- , ("261","RPL_TRACELOG")
- , ("211","RPL_STATSLINKINFO")
- , ("212","RPL_STATSCOMMANDS")
- , ("213","RPL_STATSCLINE")
- , ("214","RPL_STATSNLINE")
- , ("215","RPL_STATSILINE")
- , ("216","RPL_STATSKLINE")
- , ("218","RPL_STATSYLINE")
- , ("219","RPL_ENDOFSTATS")
- , ("241","RPL_STATSLLINE")
- , ("242","RPL_STATSUPTIME")
- , ("243","RPL_STATSOLINE")
- , ("244","RPL_STATSHLINE")
- , ("221","RPL_UMODEIS")
- , ("251","RPL_LUSERCLIENT")
- , ("252","RPL_LUSEROP")
- , ("253","RPL_LUSERUNKNOWN")
- , ("254","RPL_LUSERCHANNELS")
- , ("255","RPL_LUSERME")
- , ("256","RPL_ADMINME")
- , ("257","RPL_ADMINLOC1")
- , ("258","RPL_ADMINLOC2")
- , ("259","RPL_ADMINEMAIL")
- ]
diff --git a/irc.cabal b/irc.cabal
--- a/irc.cabal
+++ b/irc.cabal
@@ -1,13 +1,21 @@
-name: irc
-synopsis: A small library for parsing IRC messages.
-description: A set of combinators and types for parsing IRC messages.
-version: 0.2.3
-category: Data
-license: LGPL
-license-file: COPYING
-author: Trevor Elliott
-maintainer: trevor@geekgateway.com
-extra-source-files: COPYING.LESSER
-build-depends: base, parsec >= 2.0
-exposed-Modules: Network.IRC, Network.IRC.Parser, Network.IRC.Types
-ghc-options: -Wall -fglasgow-exts
+name: irc
+synopsis: A small library for parsing IRC messages.
+description: A set of combinators and types for parsing IRC messages.
+version: 0.4
+category: Data
+license: LGPL
+license-file: COPYING
+author: Trevor Elliott
+maintainer: trevor@geekgateway.com
+extra-source-files: COPYING.LESSER,
+ tests/Makefile,
+ tests/Tests.hs
+cabal-version: >= 1.2.0
+
+library
+ ghc-options: -Wall
+ build-depends: base, parsec >= 2.0
+ exposed-Modules: Network.IRC,
+ Network.IRC.Base,
+ Network.IRC.Commands,
+ Network.IRC.Parser
diff --git a/tests/Makefile b/tests/Makefile
new file mode 100644
--- /dev/null
+++ b/tests/Makefile
@@ -0,0 +1,14 @@
+ODIR = .ghc
+TARGET = Tests
+
+all : $(ODIR)
+ ghc --make -odir=$(ODIR) -hidir=$(ODIR) $(TARGET)
+ ./$(TARGET)
+
+$(ODIR) :
+ mkdir $(ODIR)
+
+clean :
+ $(RM) -r $(ODIR) $(TARGET)
+
+.PHONY: all clean
diff --git a/tests/Tests.hs b/tests/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Tests.hs
@@ -0,0 +1,150 @@
+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
+ coarbitrary = undefined
+ 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
+ coarbitrary = undefined
+ 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
+ coarbitrary = undefined
+
+
+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
+ ]
+ coarbitrary = undefined
+
+
+instance Arbitrary Message where
+ arbitrary =
+ let params = map unIdentifier <$> sized vector
+ cmd = unCmd <$> arbitrary
+ in Message <$> arbitrary <*> cmd <*> params
+ coarbitrary = undefined
+
+
+-- ---------------------------------------------------------
+-- 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