pinealservo
/
pipes-irc-server
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Misc refresh and cleanup, added some QuickCheck props

master
Levi Pearson 2014-06-12 03:33:09 -06:00
parent 45eb76c8af
commit fd141d09fb
10 changed files with 827 additions and 712 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
pipes-irc-server.cabal
View File

@ -23,26 +23,26 @@ executable pipes-irc-server
, Pipes.IRC.Server.Types , Pipes.IRC.Server.Types
, Pipes.IRC.Server.MessageHandler , Pipes.IRC.Server.MessageHandler
-- other-extensions: -- other-extensions:
build-depends: base >= 4.6 && < 4.7 build-depends: base
, mtl >= 2.1 && < 3 , mtl
, errors >= 1.4 && < 2 , errors
, mmorph >= 1 && < 2 , mmorph
, containers >= 0.5 && < 1 , containers
, bytestring >= 0.10 && < 0.11 , bytestring
, text >= 0.11.3 && < 0.12 , text
, attoparsec >= 0.10 && < 0.11 , attoparsec
, network >= 2.4 && < 2.5 , network
, pipes >= 4 && < 5 , pipes
, pipes-concurrency >= 2 && < 3 , pipes-concurrency
, pipes-bytestring >= 1.0 && < 2 , pipes-bytestring
, pipes-parse >= 2.0 && < 3 , pipes-parse
, pipes-attoparsec >= 0.3 && < 1 , pipes-attoparsec
, pipes-network >= 0.6 && < 1 , pipes-network
, stm >= 2 && < 3 , stm
, time >= 1.4 && < 1.5 , time
, async >= 2 && < 3 , async
, free >= 3 && < 4 , free
, lens >= 3 && < 4 , lens
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
@ -50,21 +50,23 @@ executable pipes-irc-server
test-suite tests test-suite tests
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: Main.hs main-is: Main.hs
build-depends: base >= 4.6 && < 4.7 build-depends: base
, mtl >= 2.1 && < 3 , mtl
, containers >= 0.5 && < 1 , containers
, bytestring >= 0.10 && < 0.11 , bytestring
, text >= 0.11.3 && < 0.12 , text
, attoparsec >= 0.10 && < 0.11 , attoparsec
, pipes >= 4 && < 5 , pipes
, pipes-concurrency >= 2 && < 3 , pipes-concurrency
, pipes-bytestring >= 1.0 && < 2 , pipes-bytestring
, pipes-parse >= 2.0 && < 3 , pipes-parse
, pipes-attoparsec >= 0.3 && < 1 , pipes-attoparsec
, pipes-network >= 0.6 && < 1 , pipes-network
, stm >= 2 && < 3 , stm
, async >= 2 && < 3 , async
, free >= 3 && < 4 , free
, lens
, time
build-depends: tasty build-depends: tasty
, tasty-hspec , tasty-hspec
, tasty-hunit , tasty-hunit

9
src/Pipes/IRC/Server.hs
View File

@ -35,10 +35,10 @@ version = "0.1a"
parseMessage :: Producer ByteString IO () parseMessage :: Producer ByteString IO ()
-> Producer (Either ByteString IrcMessage) IO () -> Producer (Either ByteString IrcMessage) IO ()
parseMessage prod = do parseMessage prod = do
void $ for (parseMany parseMsgOrLine prod) $ \res -> void $ for (parsed parseMsgOrLine prod) $ \res ->
case res of case res of
(_, Left _) -> yield $ Left "ERROR Bad Parse" (Left _) -> yield $ Left "ERROR Bad Parse"
(_, Right val) -> yield $ Right val (Right val) -> yield $ Right val
return () return ()
renderMessage :: Pipe IrcMessage ByteString IO () renderMessage :: Pipe IrcMessage ByteString IO ()
@ -153,7 +153,8 @@ idlePinger srv cid =
atomically $ do atomically $ do
conns <- readTVar (srv ^. ircConnections) conns <- readTVar (srv ^. ircConnections)
PC.send (conns ! cid ^. out) pingMsg void $ PC.send (conns ! cid ^. out) pingMsg
return ()
threadDelay oneMinute threadDelay oneMinute

61
src/Pipes/IRC/Server/Channel.hs
View File

@ -15,6 +15,7 @@ module Pipes.IRC.Server.Channel
, chanSigil , chanSigil
, chanUserSigil , chanUserSigil
, chanSetPass , chanSetPass
, chanClearPass
, chanHasPass , chanHasPass
, chanCheckPass , chanCheckPass
, chanAddOper , chanAddOper
@ -74,21 +75,21 @@ chanAddUser, chanDelUser :: NickKey -- ^ user to add to channel
-- | Add a user to the channel's list of users. This does not change -- | Add a user to the channel's list of users. This does not change
-- the set of set of channels on the user or perform any checking; -- the set of set of channels on the user or perform any checking;
-- this just performs the low-level change to the channel. -- this just performs the low-level change to the channel.
chanAddUser un = chanUsers %~ insert un chanAddUser uname = chanUsers %~ insert uname
-- | Delete a user from the channel's list of users. This does not -- | Delete a user from the channel's list of users. This does not
-- change the set of channels on the user or perform any checking; -- change the set of channels on the user or perform any checking;
-- this just performs the low-level change to the channel. -- this just performs the low-level change to the channel.
chanDelUser un = (chanUsers %~ delete un) chanDelUser uname = (chanUsers %~ delete uname)
. (chanOpers %~ delete un) . (chanOpers %~ delete uname)
. (chanVoices %~ delete un) . (chanVoices %~ delete uname)
-- | Is the user owning the given nick on the channel? Returns 'True' -- | Is the user owning the given nick on the channel? Returns 'True'
-- if the user is in fact on the channel. -- if the user is in fact on the channel.
chanHasUser :: NickKey -- ^ user to check presence of on the channel chanHasUser :: NickKey -- ^ user to check presence of on the channel
-> IrcChannel -- ^ channel in which to look for the user -> IrcChannel -- ^ channel in which to look for the user
-> Bool -- ^ 'True' if the user is in the channel -> Bool -- ^ 'True' if the user is in the channel
chanHasUser un ch = member un (ch ^. chanUsers) chanHasUser uname ch = member uname (ch ^. chanUsers)
-- | Set the topic of discussion in the channel. This does not do any -- | Set the topic of discussion in the channel. This does not do any
-- permission or size checking; it just performs the low-level action. -- permission or size checking; it just performs the low-level action.
@ -123,9 +124,9 @@ chanSigil ch | chanHasModeFlag Secret ch = "@"
chanUserSigil :: NickKey -- ^ nickname of user of which to find sigil chanUserSigil :: NickKey -- ^ nickname of user of which to find sigil
-> IrcChannel -- ^ channel the user may have status in -> IrcChannel -- ^ channel the user may have status in
-> ByteString -- ^ the sigil associated with the user's status -> ByteString -- ^ the sigil associated with the user's status
chanUserSigil un ch | member un $ ch ^. chanOpers = "@" chanUserSigil uname ch | member uname $ ch ^. chanOpers = "@"
| member un $ ch ^. chanVoices = "+" | member uname $ ch ^. chanVoices = "+"
| otherwise = "" | otherwise = ""
-- | Set a password key that must be given with a JOIN command in -- | Set a password key that must be given with a JOIN command in
-- order to join the channel. This does no permission or error -- order to join the channel. This does no permission or error
@ -135,6 +136,12 @@ chanSetPass :: PassKey -- ^ password key to set for a channel
-> IrcChannel -- ^ channel with the password set -> IrcChannel -- ^ channel with the password set
chanSetPass pwd = chanPass .~ Just pwd chanSetPass pwd = chanPass .~ Just pwd
-- | Clear password key for the channel. This does not do permission or
-- error checking, it just performs the low-level operation.
chanClearPass :: IrcChannel -- ^ channel to clear the password key
-> IrcChannel -- ^ channel with the password cleared
chanClearPass = chanPass .~ Nothing
-- | Does the channel have a password key set? Returns 'True' if the -- | Does the channel have a password key set? Returns 'True' if the
-- channel does have a password key set. -- channel does have a password key set.
chanHasPass :: IrcChannel -- ^ channel on which to look for password key chanHasPass :: IrcChannel -- ^ channel on which to look for password key
@ -158,12 +165,12 @@ chanAddOper, chanDelOper :: NickKey -- ^ nickname of user
-- | Add the given nickname as an operator on the channel. This does -- | Add the given nickname as an operator on the channel. This does
-- not perform any permission or error checks, it just performs the -- not perform any permission or error checks, it just performs the
-- low-level operation. -- low-level operation.
chanAddOper un = chanOpers %~ insert un chanAddOper uname = chanOpers %~ insert uname
-- | Remove the given nickname as an operator on the channel. This -- | Remove the given nickname as an operator on the channel. This
-- does not perform any permission or error checks, it just performs -- does not perform any permission or error checks, it just performs
-- the low-level operation. -- the low-level operation.
chanDelOper un = chanOpers %~ delete un chanDelOper uname = chanOpers %~ delete uname
chanAddVoice, chanDelVoice :: NickKey -- ^ nickname of user chanAddVoice, chanDelVoice :: NickKey -- ^ nickname of user
-> IrcChannel -- ^ channel to change voice on -> IrcChannel -- ^ channel to change voice on
@ -172,12 +179,12 @@ chanAddVoice, chanDelVoice :: NickKey -- ^ nickname of user
-- | Give voice status to the given nickname on the channel. This -- | Give voice status to the given nickname on the channel. This
-- does not perform any permission or error checks, it just performs -- does not perform any permission or error checks, it just performs
-- the low-level operation. -- the low-level operation.
chanAddVoice un = chanVoices %~ insert un chanAddVoice uname = chanVoices %~ insert uname
-- | Remove voice status from the given nickname on the channel. This -- | Remove voice status from the given nickname on the channel. This
-- does not perform any permission or error checks, it just performs -- does not perform any permission or error checks, it just performs
-- the low-level operation. -- the low-level operation.
chanDelVoice un = chanVoices %~ delete un chanDelVoice uname = chanVoices %~ delete uname
chanAddInvite, chanDelInvite :: NickKey -- ^ nickname of user chanAddInvite, chanDelInvite :: NickKey -- ^ nickname of user
-> IrcChannel -- ^ channel to change invitation -> IrcChannel -- ^ channel to change invitation
@ -187,12 +194,12 @@ chanAddInvite, chanDelInvite :: NickKey -- ^ nickname of user
-- This will allow the user to join when the channel is invite-only. -- This will allow the user to join when the channel is invite-only.
-- This does not perform any permission or error checks, it just does -- This does not perform any permission or error checks, it just does
-- the operation. -- the operation.
chanAddInvite un = chanInvites %~ insert un chanAddInvite uname = chanInvites %~ insert uname
-- | Remove record of the invitation for the nickname to join the -- | Remove record of the invitation for the nickname to join the
-- channel. This does not perform permission or error checks, it just -- channel. This does not perform permission or error checks, it just
-- does the low-level operation. -- does the low-level operation.
chanDelInvite un = chanInvites %~ delete un chanDelInvite uname = chanInvites %~ delete uname
-- | Change the nick of a user on the channel. This will replace the -- | Change the nick of a user on the channel. This will replace the
-- old name with the news name in the member list, invitation list, -- old name with the news name in the member list, invitation list,
@ -223,7 +230,7 @@ chanChangeNick old new ch = (chOps . chVoice . chInvite . chUsers) ch
chanUserIsOper :: NickKey -- ^ nickname to check chanUserIsOper :: NickKey -- ^ nickname to check
-> IrcChannel -- ^ channel to check -> IrcChannel -- ^ channel to check
-> Bool -- ^ 'True' if nickname has ops on channel -> Bool -- ^ 'True' if nickname has ops on channel
chanUserIsOper un ch = member un $ ch ^. chanOpers chanUserIsOper uname ch = member uname $ ch ^. chanOpers
-- | Does the nickname have voice on the channel? Returns 'True' if -- | Does the nickname have voice on the channel? Returns 'True' if
-- the user has the voice mode flag. This does not consider any other -- the user has the voice mode flag. This does not consider any other
@ -231,7 +238,7 @@ chanUserIsOper un ch = member un $ ch ^. chanOpers
chanUserHasVoice :: NickKey -- ^ nickname to check chanUserHasVoice :: NickKey -- ^ nickname to check
-> IrcChannel -- ^ channel to check -> IrcChannel -- ^ channel to check
-> Bool -- ^ 'True' if nickname has voice on channel -> Bool -- ^ 'True' if nickname has voice on channel
chanUserHasVoice un ch = member un $ ch ^. chanVoices chanUserHasVoice uname ch = member uname $ ch ^. chanVoices
-- | Has the nickname been invited to the channel? Returns 'True' if -- | Has the nickname been invited to the channel? Returns 'True' if
-- the user has been invited. This does not consider any other -- the user has been invited. This does not consider any other
@ -239,7 +246,7 @@ chanUserHasVoice un ch = member un $ ch ^. chanVoices
chanUserIsInvited :: NickKey -- ^ nickname to check chanUserIsInvited :: NickKey -- ^ nickname to check
-> IrcChannel -- ^ channel to check -> IrcChannel -- ^ channel to check
-> Bool -- ^ 'True' if nickname has been invited -> Bool -- ^ 'True' if nickname has been invited
chanUserIsInvited un ch = member un $ ch ^. chanInvites chanUserIsInvited uname ch = member uname $ ch ^. chanInvites
-- | Is the nickname allowed to speak on the channel? Returns 'True' -- | Is the nickname allowed to speak on the channel? Returns 'True'
-- if the relevant permission checks all pass. The checks consider -- if the relevant permission checks all pass. The checks consider
@ -248,11 +255,11 @@ chanUserIsInvited un ch = member un $ ch ^. chanInvites
chanUserMaySpeak :: NickKey -- ^ nickname to check chanUserMaySpeak :: NickKey -- ^ nickname to check
-> IrcChannel -- ^ channel to check -> IrcChannel -- ^ channel to check
-> Bool -- ^ 'True' if nickname may speak on channel -> Bool -- ^ 'True' if nickname may speak on channel
chanUserMaySpeak un ch chanUserMaySpeak uname ch
| (chanHasUser un ch || not (chanHasModeFlag NoOutsideMsgs ch)) | (chanHasUser uname ch || not (chanHasModeFlag NoOutsideMsgs ch))
&& not (chanHasModeFlag Moderated ch) = True && not (chanHasModeFlag Moderated ch) = True
| chanUserIsOper un ch = True | chanUserIsOper uname ch = True
| chanUserHasVoice un ch = True | chanUserHasVoice uname ch = True
| otherwise = False | otherwise = False
-- | Is the nickname allowed to join the channel? Returns 'True' if -- | Is the nickname allowed to join the channel? Returns 'True' if
@ -261,9 +268,9 @@ chanUserMaySpeak un ch
chanUserMayJoin :: NickKey -- ^ nickname to check chanUserMayJoin :: NickKey -- ^ nickname to check
-> IrcChannel -- ^ channel to check -> IrcChannel -- ^ channel to check
-> Bool -- ^ 'True' if nickname may join the channel -> Bool -- ^ 'True' if nickname may join the channel
chanUserMayJoin un ch chanUserMayJoin uname ch
| not $ chanHasModeFlag InviteOnly ch = True | not $ chanHasModeFlag InviteOnly ch = True
| chanUserIsInvited un ch = True | chanUserIsInvited uname ch = True
| otherwise = False | otherwise = False
-- | Is the nickname allowed to set the topic for the channel? -- | Is the nickname allowed to set the topic for the channel?
@ -271,8 +278,8 @@ chanUserMayJoin un ch
chanUserMaySetTopic :: NickKey -- ^ nickname to check chanUserMaySetTopic :: NickKey -- ^ nickname to check
-> IrcChannel -- ^ channel to check -> IrcChannel -- ^ channel to check
-> Bool -- ^ 'True' if nickname may set the topic -> Bool -- ^ 'True' if nickname may set the topic
chanUserMaySetTopic un ch chanUserMaySetTopic uname ch
| not (chanHasModeFlag TopicOperOnly ch) && | not (chanHasModeFlag TopicOperOnly ch) &&
chanHasUser un ch = True chanHasUser uname ch = True
| chanUserIsOper un ch = True | chanUserIsOper uname ch = True
| otherwise = False | otherwise = False

7
src/Pipes/IRC/Server/EventHandler.hs
View File

@ -4,6 +4,7 @@ module Pipes.IRC.Server.EventHandler
( ircEventHandler ) ( ircEventHandler )
where where
import Control.Applicative ((<$>))
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Lens import Control.Lens
@ -25,12 +26,10 @@ ircEventHandler srv evt =
case evt of case evt of
Close connId -> do Close connId -> do
outConns <- readTVarIO $ srv ^. ircConnections outConns <- readTVarIO $ srv ^. ircConnections
case M.lookup connId outConns of return $ isJust (M.lookup connId outConns)
Just IrcConnection{..} -> return False
_ -> return True
Msg {..} -> do Msg {..} -> do
outConns <- readTVarIO $ srv ^. ircConnections outConns <- readTVarIO $ srv ^. ircConnections
let os = fmap _out $ DM.mapMaybe (`M.lookup` outConns) _outDest let os = _out <$> DM.mapMaybe (`M.lookup` outConns) _outDest
sendToMany _outMsg os sendToMany _outMsg os
logOutMsg _outMsg _outDest logOutMsg _outMsg _outDest
return True return True

2
src/Pipes/IRC/Server/IrcMonad.hs
View File

@ -97,7 +97,7 @@ channelTargets chname = do
let cUsers chan = S.elems (S.delete mynick $ chan ^. chanUsers) let cUsers chan = S.elems (S.delete mynick $ chan ^. chanUsers)
let chmap = srv ^. ircChannels let chmap = srv ^. ircChannels
case M.lookup chname chmap of case M.lookup chname chmap of
Just chan -> fmap catMaybes $ forM (cUsers chan) userTarget Just chan -> catMaybes <$> forM (cUsers chan) userTarget
_ -> do tellNumeric err_nosuchnick [chname, ":No such nick/channel"] _ -> do tellNumeric err_nosuchnick [chname, ":No such nick/channel"]
return [] return []

4
src/Pipes/IRC/Server/MessageHandler.hs
View File

@ -5,7 +5,7 @@ module Pipes.IRC.Server.MessageHandler
( ircMessageHandler ) ( ircMessageHandler )
where where
import Control.Applicative (pure, (<$>), (<|>)) import Control.Applicative ((<|>))
import Control.Error import Control.Error
import Control.Lens import Control.Lens
import Control.Monad.RWS import Control.Monad.RWS
@ -144,7 +144,7 @@ doJoin msg chans = forM_ chans $ \(c, k) -> runValidation $ do
nick <- checkRegistration nick <- checkRegistration
-- If the channel is absent, joining it will create it -- If the channel is absent, joining it will create it
checkChannelAbsence c checkChannelAbsence c
-- If it already exists, do some sanity checks first -- If it already exists, do some sanity checks first
<|> do chan <- checkChannelPresence c <|> do chan <- checkChannelPresence c
checkUserNotOnChan nick c chan checkUserNotOnChan nick c chan
checkInvitation nick c chan checkInvitation nick c chan

32
src/Pipes/IRC/Server/Server.hs
View File

@ -53,9 +53,9 @@ ircDelUser nn srv =
uchans = S.elems (usr ^. userChannels) uchans = S.elems (usr ^. userChannels)
ichans = S.elems (usr ^. userInvites) ichans = S.elems (usr ^. userInvites)
in in
(ircUsers %~ M.delete nn) . (ircUsers %~ M.delete nn)
(ircChannels %~ alterAtKeys (ircPartChan nn) uchans) . . (ircChannels %~ alterAtKeys (ircPartChan nn) uchans)
(ircChannels %~ adjustAtKeys (chanDelInvite nn) ichans) . (ircChannels %~ adjustAtKeys (chanDelInvite nn) ichans)
-- | Check whether a user with the given nickname is known by the -- | Check whether a user with the given nickname is known by the
-- server. This only checks for fully-registered users; the nick -- server. This only checks for fully-registered users; the nick
@ -79,18 +79,20 @@ ircJoin :: NickKey -- ^ nickname of the joining user
-> ChanKey -- ^ name of the channel to join -> ChanKey -- ^ name of the channel to join
-> IrcServer -- ^ server to perform the join on -> IrcServer -- ^ server to perform the join on
-> IrcServer -- ^ new server with join completed -> IrcServer -- ^ new server with join completed
ircJoin un cn = (ircChannels %~ M.alter alterChan cn) ircJoin uname cn = (ircChannels %~ M.alter alterChan cn)
. (ircUsers %~ M.adjust (userAddChan cn) un) . (ircUsers %~ M.adjust (userAddChan cn) uname)
where where
alterChan mChan = Just $ chanAddUser un (fromMaybe (newChannel un) mChan) alterChan mChan = Just $
chanAddUser uname (fromMaybe (newChannel uname) mChan)
-- Helper 'alter' function for ircPart, not exported -- Helper 'alter' function for ircPart, not exported
ircPartChan :: NickKey -> Maybe IrcChannel -> Maybe IrcChannel ircPartChan :: NickKey -> Maybe IrcChannel -> Maybe IrcChannel
ircPartChan un (Just chan) = case chanDelUser un chan of ircPartChan uname (Just chan) =
IrcChannel{ _chanUsers = us } case chanDelUser uname chan of
| us == S.empty -> Nothing IrcChannel{ _chanUsers = us }
chan' -> Just chan' | us == S.empty -> Nothing
ircPartChan _ Nothing = Nothing chan' -> Just chan'
ircPartChan _ Nothing = Nothing
-- | Remove the user with the given nickname from the named -- | Remove the user with the given nickname from the named
-- channel. If this causes the channel to become empty, it will be -- channel. If this causes the channel to become empty, it will be
@ -99,8 +101,8 @@ ircPart :: NickKey -- ^ nickname of parting user
-> ChanKey -- ^ name of the channel to part from -> ChanKey -- ^ name of the channel to part from
-> IrcServer -- ^ server to perform the part on -> IrcServer -- ^ server to perform the part on
-> IrcServer -- ^ new server with part completed -> IrcServer -- ^ new server with part completed
ircPart un cn srv = ircPart uname cn srv =
srv & (ircChannels %~ (M.alter $ ircPartChan un) cn) srv & (ircChannels %~ (M.alter $ ircPartChan uname) cn)
& (ircUsers %~ adjustAtKeys (userDelInvite cn) iusers) & (ircUsers %~ adjustAtKeys (userDelInvite cn) iusers)
where where
chan = (srv ^. ircChannels) ! cn chan = (srv ^. ircChannels) ! cn
@ -112,8 +114,8 @@ ircInvite :: NickKey -- ^ nickname of user to invite
-> ChanKey -- ^ name of channel user is invited to -> ChanKey -- ^ name of channel user is invited to
-> IrcServer -- ^ server to perform the invitation on -> IrcServer -- ^ server to perform the invitation on
-> IrcServer -- ^ new server with invite completed -> IrcServer -- ^ new server with invite completed
ircInvite un cn = (ircChannels %~ M.adjust (chanAddInvite un) cn) ircInvite uname cn = (ircChannels %~ M.adjust (chanAddInvite uname) cn)
. (ircUsers %~ M.adjust (userAddInvite cn) un) . (ircUsers %~ M.adjust (userAddInvite cn) uname)
-- | Determine whether the user with the given nickname is disallowed -- | Determine whether the user with the given nickname is disallowed
-- from joining the channel due to the 'InviteOnly' flag and lack of -- from joining the channel due to the 'InviteOnly' flag and lack of

4
src/Pipes/IRC/Server/Types.hs
View File

@ -62,7 +62,7 @@ data IrcUserMode = Away -- ^ the user is marked as away from keyboard
| Oper -- ^ the user is an IRC operator | Oper -- ^ the user is an IRC operator
| LocalOper -- ^ the user is a local server operator | LocalOper -- ^ the user is a local server operator
| ServerNotices -- ^ the user receives server notices | ServerNotices -- ^ the user receives server notices
deriving (Show, Eq, Enum, Ord) deriving (Show, Eq, Enum, Ord, Bounded)
-- | An 'IrcUser' record tracks the state of a registered user that is not -- | An 'IrcUser' record tracks the state of a registered user that is not
-- channel-specific. -- channel-specific.
@ -90,7 +90,7 @@ data IrcChanModeFlags = Anonymous -- ^ all communication is anonymized
| Private -- ^ channel shows up as private in list | Private -- ^ channel shows up as private in list
| Secret -- ^ channel does not appear in list | Secret -- ^ channel does not appear in list
| TopicOperOnly -- ^ topic may only be set by ops | TopicOperOnly -- ^ topic may only be set by ops
deriving (Show, Eq, Enum, Ord) deriving (Show, Eq, Enum, Ord, Bounded)
-- | An 'IrcChannel' record tracks the state of a channel. -- | An 'IrcChannel' record tracks the state of a channel.
data IrcChannel = data IrcChannel =

751
tests/Main.hs
View File

@ -3,27 +3,27 @@
module Main where module Main where
import Test.Tasty import Test.Tasty
import Test.Tasty.Hspec as HS import Test.Tasty.Hspec as HS
--import Test.Tasty.HUnit as HU import Test.Tasty.QuickCheck as QC
--import Test.Tasty.QuickCheck as QC
--import Test.Tasty.SmallCheck as SC
import Data.Attoparsec.ByteString.Char8 as P import Control.Applicative
import Data.ByteString.Char8 as C8
import qualified Data.ByteString.Char8 as C8
import Data.List import Data.List
import Data.Ord import Data.Monoid
import Pipes.IRC.Message.Parse import ParseTests
import Pipes.IRC.Message.Render
import Pipes.IRC.Message.Types import Pipes.IRC.Server.Channel
import Pipes.IRC.Server.Server
import Pipes.IRC.Server.Types
import Pipes.IRC.Server.User
main :: IO () main :: IO ()
main = defaultMain tests main = defaultMain tests
tests :: TestTree tests :: TestTree
tests = testGroup "Tests" [specs] tests = testGroup "Tests" [specs, userProperties, chanProperties]
--tests = testGroup "Tests" [specs, properties, unitTests]
-- Hspec Tests -- Hspec Tests
@ -33,617 +33,8 @@ specs = testGroup "Specifications"
-- , HS.testCase "Message Rendering" msgRenderSpec -- , HS.testCase "Message Rendering" msgRenderSpec
] ]
msgParseSpec :: Spec
msgParseSpec = do
describe "Parsing" $ do
describe "parseMsgOrLine" $ do
it "succeeds parsing an empty line, returning a Left value" $
pMsgOrLine "\r\n"
`shouldBe`
Right (Left "\r\n")
it "succeeds parsing an IRC message, returning a Right value" $
pMsgOrLine "PRIVMSG #haskell :Hi, guys!\r\n"
`shouldBe`
Right
(Right (IrcMessage Nothing (Left PRIVMSG) ["#haskell", "Hi, guys!"]))
describe "parseIrcMessage" $ do
context "Messages with no prefix" $ do
it "matches with no parameters" $
pMsg "NAMES\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NAMES) [])
it "matches with one parameter (without spaces)" $
pMsg "NICK WiZ\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NICK) ["WiZ"])
it "matches with one parameter (with spaces)" $
pMsg "QUIT :Goodbye, cruel world!\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left QUIT) ["Goodbye, cruel world!"])
context "Messages with server name prefix" $ do
it "matches with server name prefixes" $
pMsg ":foo.domain.com ERROR :Oh no!\r\n"
`shouldBe`
Right (IrcMessage (Just (Left "foo.domain.com"))
(Left ERROR)
["Oh no!"] )
it "matches with hyphenated server name prefixes" $
pMsg ":my-domain.org ERROR :Oh no!\r\n"
`shouldBe`
Right (IrcMessage (Just (Left "my-domain.org"))
(Left ERROR)
["Oh no!"] )
context "Messages with nickname prefix" $ do
it "matches with just nick" $
pMsg ":WiZ PRIVMSG #haskell :Hello\r\n"
`shouldBe`
Right (IrcMessage (Just (Right (NickName "WiZ" Nothing Nothing)))
(Left PRIVMSG)
["#haskell", "Hello"] )
it "matches with nick and user" $
pMsg ":WiZ!wiz PRIVMSG #haskell :Hello\r\n"
`shouldBe`
Right (IrcMessage (Just (Right (NickName "WiZ" (Just "wiz") Nothing)))
(Left PRIVMSG)
["#haskell", "Hello"] )
it "matches with nick, user, and host" $
pMsg ":WiZ!wiz@wiz-host.com PRIVMSG #haskell :Hello\r\n"
`shouldBe`
Right (IrcMessage (Just (Right
(NickName
"WiZ"
(Just "wiz")
(Just "wiz-host.com"))))
(Left PRIVMSG)
["#haskell", "Hello"] )
context "Examples from RFC1459" $ do
it "matches PASS example" $
pMsg "PASS secretpasswordhere\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PASS) ["secretpasswordhere"])
it "matches NICK example 1" $
pMsg "NICK Wiz\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NICK) ["Wiz"])
it "matches NICK example 2" $
pMsg ":WiZ NICK Kilroy\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left NICK) ["Kilroy"])
it "matches USER example 1" $
pMsg "USER guest tolmoon tolsun :Ronnie Reagan\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left USER)
["guest", "tolmoon", "tolsun", "Ronnie Reagan"])
it "matches USER example 2" $
pMsg ":testnick USER guest tolmoon tolsun :Ronnie Reagan\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "testnick" Nothing Nothing)))
(Left USER) ["guest", "tolmoon", "tolsun", "Ronnie Reagan"])
it "matches SERVER example 1" $
pMsg "SERVER test.oulu.fi 1 :[tolsun.oulu.fi] Experimental server\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left SERVER)
["test.oulu.fi", "1", "[tolsun.oulu.fi] Experimental server"])
it "matches SERVER example 2" $
pMsg ":tolsun.oulu.fi SERVER csd.bu.edu 5 :BU Central Server\r\n"
`shouldBe`
Right (IrcMessage
(Just (Left "tolsun.oulu.fi"))
(Left SERVER) ["csd.bu.edu", "5", "BU Central Server"])
it "matches OPER example" $
pMsg "OPER foo bar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left OPER) ["foo", "bar"])
it "matches QUIT example" $
pMsg "QUIT :Gone to have lunch\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left QUIT) ["Gone to have lunch"])
it "matches SQUIT example 1" $
pMsg "SQUIT tolsun.oulu.fi :Bad Link ?\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left SQUIT)
["tolsun.oulu.fi", "Bad Link ?"])
it "matches SQUIT example 2" $
pMsg ":Trillian SQUIT cm22.eng.umd.edu :Server out of control\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Trillian" Nothing Nothing)))
(Left SQUIT) ["cm22.eng.umd.edu", "Server out of control"])
it "matches JOIN example 1" $
pMsg "JOIN #foobar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["#foobar"])
it "matches JOIN example 2" $
pMsg "JOIN &foo fubar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["&foo", "fubar"])
it "matches JOIN example 3" $
pMsg "JOIN #foo,&bar fubar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["#foo,&bar", "fubar"])
it "matches JOIN example 4" $
pMsg "JOIN #foo,&bar fubar,foobar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["#foo,&bar", "fubar,foobar"])
it "matches JOIN example 5" $
pMsg "JOIN #foo,#bar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["#foo,#bar"])
it "matches JOIN example 6" $
pMsg ":WiZ JOIN #Twilight_zone\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left JOIN) ["#Twilight_zone"])
it "matches PART example 1" $
pMsg "PART #twilight_zone\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PART) ["#twilight_zone"])
it "matches PART example 2" $
pMsg "PART #oz-ops,&group5\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PART) ["#oz-ops,&group5"])
it "matches MODE example 1" $
pMsg "MODE #Finnish +im\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#Finnish", "+im"])
it "matches MODE example 2" $
pMsg "MODE #Finnish +o Kilroy\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#Finnish", "+o", "Kilroy"])
it "matches MODE example 3" $
pMsg "MODE #Finnish +v Wiz\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#Finnish", "+v", "Wiz"])
it "matches MODE example 4" $
pMsg "MODE #Fins -s\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#Fins", "-s"])
it "matches MODE example 5" $
pMsg "MODE #42 +k oulu\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#42", "+k", "oulu"])
it "matches MODE example 6" $
pMsg "MODE #eu-opers +l 10\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#eu-opers", "+l", "10"])
it "matches MODE example 7" $
pMsg "MODE &oulu +b\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["&oulu", "+b"])
it "matches MODE example 8" $
pMsg "MODE &oulu +b *!*@*\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["&oulu", "+b", "*!*@*"])
it "matches MODE example 9" $
pMsg "MODE &oulu +b *!*@*.edu\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["&oulu", "+b", "*!*@*.edu"])
it "matches MODE example 10" $
pMsg "MODE WiZ -w\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["WiZ", "-w"])
it "matches MODE example 11" $
pMsg ":Angel MODE Angel +i\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Angel" Nothing Nothing)))
(Left MODE) ["Angel", "+i"])
it "matches MODE example 12" $
pMsg "MODE WiZ -o\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["WiZ", "-o"])
it "matches TOPIC example 1" $
pMsg ":WiZ TOPIC #test :New topic\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left TOPIC) ["#test", "New topic"])
it "matches TOPIC example 2" $
pMsg "TOPIC #test :another topic\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left TOPIC) ["#test", "another topic"])
it "matches TOPIC example 3" $
pMsg "TOPIC #test\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left TOPIC) ["#test"])
it "matches NAMES example 1" $
pMsg "NAMES #twilight_zone,#42\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NAMES) ["#twilight_zone,#42"])
it "matches NAMES example 2" $
pMsg "NAMES\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NAMES) [])
it "matches LIST example 1" $
pMsg "LIST\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left LIST) [])
it "matches LIST example 2" $
pMsg "LIST #twilight_zone,#42\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left LIST) ["#twilight_zone,#42"])
it "matches INVITE example 1" $
pMsg ":Angel INVITE Wiz #Dust\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Angel" Nothing Nothing)))
(Left INVITE) ["Wiz", "#Dust"])
it "matches INVITE example 2" $
pMsg "INVITE Wiz #Twilight_Zone\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left INVITE) ["Wiz", "#Twilight_Zone"])
it "matches KICK example 1" $
pMsg "KICK &Melbourne Matthew\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left KICK) ["&Melbourne", "Matthew"])
it "matches KICK example 2" $
pMsg "KICK #Finnish John :Speaking English\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left KICK)
["#Finnish", "John", "Speaking English"])
it "matches KICK example 3" $
pMsg ":WiZ KICK #Finnish John\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left KICK) ["#Finnish", "John"])
it "matches VERSION example 1" $
pMsg ":WiZ VERSION *.se\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left VERSION) ["*.se"])
it "matches VERSION example 2" $
pMsg "VERSION tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left VERSION) ["tolsun.oulu.fi"])
it "matches STATS example 1" $
pMsg "STATS m\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left STATS) ["m"])
it "matches STATS example 2" $
pMsg ":Wiz STATS c eff.org\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Wiz" Nothing Nothing)))
(Left STATS) ["c", "eff.org"])
it "matches LINKS example 1" $
pMsg "LINKS *.au\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left LINKS) ["*.au"])
it "matches LINKS example 2" $
pMsg ":WiZ LINKS *.bu.edu *.edu\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left LINKS) ["*.bu.edu", "*.edu"])
it "matches TIME example 1" $
pMsg "TIME tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left TIME) ["tolsun.oulu.fi"])
it "matches TIME example 2" $
pMsg ":Angel TIME *.au\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Angel" Nothing Nothing)))
(Left TIME) ["*.au"])
it "matches CONNECT example 1" $
pMsg "CONNECT tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left CONNECT) ["tolsun.oulu.fi"])
it "matches CONNECT example 2" $
pMsg ":WiZ CONNECT eff.org 6667 csd.bu.edu\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left CONNECT) ["eff.org", "6667", "csd.bu.edu"])
it "matches TRACE example 1" $
pMsg "TRACE *.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left TRACE) ["*.oulu.fi"])
it "matches TRACE example 2" $
pMsg ":WiZ TRACE AngelDust\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left TRACE) ["AngelDust"])
it "matches ADMIN example 1" $
pMsg "ADMIN tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left ADMIN) ["tolsun.oulu.fi"])
it "matches ADMIN example 2" $
pMsg ":WiZ ADMIN *.edu\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left ADMIN) ["*.edu"])
it "matches INFO example 1" $
pMsg "INFO csd.bu.edu\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left INFO) ["csd.bu.edu"])
it "matches INFO example 2" $
pMsg ":Avalon INFO *.fi\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Avalon" Nothing Nothing)))
(Left INFO) ["*.fi"])
it "matches INFO example 3" $
pMsg "INFO Angel\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left INFO) ["Angel"])
it "matches PRIVMSG example 1" $
pMsg ":Angel PRIVMSG Wiz :Hello are you receiving this message ?\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Angel" Nothing Nothing)))
(Left PRIVMSG)
["Wiz", "Hello are you receiving this message ?"])
it "matches PRIVMSG example 2" $
pMsg "PRIVMSG Angel :yes I'm receiving it!\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PRIVMSG)
["Angel", "yes I'm receiving it!"])
it "matches PRIVMSG example 3" $
pMsg "PRIVMSG jto@tolsun.oulu.fi :Hello !\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PRIVMSG)
["jto@tolsun.oulu.fi", "Hello !"])
it "matches PRIVMSG example 4" $
pMsg "PRIVMSG $*.fi :Server tolsun.oulu.fi rebooting.\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PRIVMSG)
["$*.fi", "Server tolsun.oulu.fi rebooting."])
it "matches PRIVMSG example 5" $
pMsg "PRIVMSG #*.edu :NSFNet is undergoing work, expect interruptions\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PRIVMSG)
["#*.edu", "NSFNet is undergoing work, expect interruptions"])
it "matches WHO example 1" $
pMsg "WHO *.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHO) ["*.fi"])
it "matches WHO example 2" $
pMsg "WHO jto* o\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHO) ["jto*", "o"])
it "matches WHOIS example 1" $
pMsg "WHOIS wiz\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOIS) ["wiz"])
it "matches WHOIS example 2" $
pMsg "WHOIS eff.org trillian\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOIS) ["eff.org", "trillian"])
it "matches WHOWAS example 1" $
pMsg "WHOWAS Wiz\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOWAS) ["Wiz"])
it "matches WHOWAS example 2" $
pMsg "WHOWAS Mermaid 9\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOWAS) ["Mermaid", "9"])
it "matches WHOWAS example 3" $
pMsg "WHOWAS Trillian 1 *.edu\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOWAS) ["Trillian", "1", "*.edu"])
it "matches KILL example" $
pMsg "KILL David :(csd.bu.edu <- tolsun.oulu.fi)\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left KILL)
["David", "(csd.bu.edu <- tolsun.oulu.fi)"])
it "matches PING example 1" $
pMsg "PING tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PING) ["tolsun.oulu.fi"])
it "matches PING example 2" $
pMsg "PING WiZ\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PING) ["WiZ"])
it "matches PONG example" $
pMsg "PONG csd.bu.edu tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PONG)
["csd.bu.edu", "tolsun.oulu.fi"])
it "matches ERROR example" $
pMsg "ERROR :Server *.fi already exists\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left ERROR)
["Server *.fi already exists"])
it "matches AWAY example 1" $
pMsg "AWAY :Gone to lunch. Back in 5\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left AWAY)
["Gone to lunch. Back in 5"])
it "matches AWAY example 2" $
pMsg ":WiZ AWAY\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left AWAY) [])
it "matches REHASH example" $
pMsg "REHASH\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left REHASH) [])
it "matches RESTART example" $
pMsg "RESTART\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left RESTART) [])
it "matches SUMMON example 1" $
pMsg "SUMMON jto\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left SUMMON) ["jto"])
it "matches SUMMON example 2" $
pMsg "SUMMON jto tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left SUMMON) ["jto", "tolsun.oulu.fi"])
it "matches USERS example 1" $
pMsg "USERS eff.org\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left USERS) ["eff.org"])
it "matches USERS example 2" $
pMsg ":John USERS tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "John" Nothing Nothing)))
(Left USERS) ["tolsun.oulu.fi"])
it "matches WALLOPS example" $
pMsg ":csd.bu.edu WALLOPS :Connect '*.uiuc.edu 6667' from Joshua\r\n"
`shouldBe`
Right (IrcMessage
(Just (Left "csd.bu.edu"))
(Left WALLOPS) ["Connect '*.uiuc.edu 6667' from Joshua"])
it "matches USERHOST example" $
pMsg "USERHOST Wiz Michael Marty p\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left USERHOST)
["Wiz", "Michael", "Marty", "p"])
it "matches ISON example" $
pMsg "ISON phone trillian WiZ jarlek Avalon Angel Monstah\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left ISON)
["phone", "trillian", "WiZ", "jarlek", "Avalon"
, "Angel", "Monstah"])
where
pMsgOrLine = parseOnly parseMsgOrLine
pMsg = parseOnly parseIrcMessage
msgRenderSpec :: Spec
msgRenderSpec = undefined
-- QuickCheck and SmallCheck properties -- QuickCheck and SmallCheck properties
{- {-
properties :: TestTree
properties = testGroup "Properties" [qcProps, scProps]
scProps :: TestTree
scProps = testGroup "(Checked by SmallCheck)"
[ SC.testProperty "sort == sort . reverse" $
\list -> sort (list :: [Int]) == sort (reverse list)
, SC.testProperty "Fermat's little theorem" $
\x -> ((x :: Integer)^7 - x) `mod` 7 == 0
-- the following property does not hold
, SC.testProperty "Fermat's last theorem" $
\x y z n ->
(n :: Integer) >= 3 SC.==> x^n + y^n /= (z^n :: Integer)
]
qcProps = testGroup "(checked by QuickCheck)"
[ QC.testProperty "sort == sort . reverse" $
\list -> sort (list :: [Int]) == sort (reverse list)
, QC.testProperty "Fermat's little theorem" $
\x -> ((x :: Integer)^7 - x) `mod` 7 == 0
-- the following property does not hold
, QC.testProperty "Fermat's last theorem" $
\x y z n ->
(n :: Integer) >= 3 QC.==> x^n + y^n /= (z^n :: Integer)
]
-- HUnit tests -- HUnit tests
unitTests = testGroup "Unit tests" unitTests = testGroup "Unit tests"
@ -655,3 +46,119 @@ unitTests = testGroup "Unit tests"
[1, 2, 3] `compare` [1,2,2] @?= LT [1, 2, 3] `compare` [1,2,2] @?= LT
] ]
-} -}
instance Arbitrary C8.ByteString where
arbitrary = C8.pack <$> listOf1 (elements ['a'..'z'])
instance Arbitrary IrcUser where
arbitrary = newUser <$> arbitrary
<*> suchThat arbitrary (>0)
instance Arbitrary IrcUserMode where
arbitrary = elements [minBound .. maxBound]
-- * User properties
userProperties :: TestTree
userProperties = testGroup "User Properties" [userqcProps]
userqcProps :: TestTree
userqcProps = testGroup "(checked by QuickCheck)"
[ QC.testProperty "userDelChan . userAddChan == id" $
\user chanKey -> (userDelChan chanKey . userAddChan chanKey) user == user
, QC.testProperty "userDelMode . userAddMode == id" $
\user mode -> (userDelMode mode . userAddMode mode) user == user
, QC.testProperty "userDelInvite . userAddInvite == id" $
\user inv -> (userDelInvite inv . userAddInvite inv) user == user
, QC.testProperty "userHasMode . userAddMode == True" $
\u m -> (userHasMode m . userAddMode m) u
, QC.testProperty "userInChan . userAddChan == True" $
\u ck -> (userInChan ck . userAddChan ck) u
, QC.testProperty "adding and removing multiple channels" manyChans
, QC.testProperty "adding and removing many modes" manyModes
, QC.testProperty "adding and removing many invites" manyInvites
]
manyChans :: IrcUser -> [ChanKey] -> Bool
manyChans u ks =
let cs = nub ks
scs = sort cs
newu = foldr userAddChan u cs
newu' = foldr userDelChan newu scs
in newu' == u && all (`userInChan` newu) cs
manyModes :: IrcUser -> [IrcUserMode] -> Bool
manyModes u ms =
let ms' = nub ms
sms = sort ms'
newu = foldr userAddMode u ms'
newu' = foldr userDelMode newu sms
in newu' == u && all (`userHasMode` newu) ms'
manyInvites :: IrcUser -> [ChanKey] -> Bool
manyInvites u ks = let cs = nub ks
scs = sort cs
newu = foldr userAddInvite u cs
newu' = foldr userDelInvite newu scs
in newu' == u
-- * Channel properties
instance Arbitrary IrcChannel where
arbitrary = newChannel <$> arbitrary
instance Arbitrary IrcChanModeFlags where
arbitrary = elements [minBound .. maxBound]
chanProperties :: TestTree
chanProperties = testGroup "Channel Properties" [chanqcProps]
chanqcProps :: TestTree
chanqcProps = testGroup "(checked by QuickCheck)" [
QC.testProperty "add/del modeFlags" $
\c m -> (chanDelModeFlag m . chanAddModeFlag m) c == c
, QC.testProperty "add/del users" $
\c u -> not (chanHasUser u c) ==>
(chanDelUser u . chanAddUser u) c == c
, QC.testProperty "set/check pass" $
\c p -> (chanClearPass . chanSetPass p) c == c
, QC.testProperty "add/del oper" $
\c u -> not (chanHasUser u c) ==>
(chanDelOper u . chanAddOper u) c == c
, QC.testProperty "add/del voice" $
\c u -> (chanDelVoice u . chanAddVoice u) c == c
, QC.testProperty "add/del invite" $
\c u -> (chanDelInvite u . chanAddInvite u) c == c
, QC.testProperty "nick change" nameChange
]
instance Monoid Bool where
mappend = (&&)
mempty = True
nameChange :: IrcChannel -> [NickKey] -> NickKey -> NickKey -> Property
nameChange c ns n n' =
let ns' = nub ns
newc = foldr (\x -> chanAddInvite x
.chanAddVoice x
.chanAddOper x
.chanAddUser x) c (n:ns')
newc' = chanChangeNick n n' newc
newc'' = foldr chanDelUser newc' ns'
in n' `notElem` ns && n /= n' ==>
mconcat [ chanHasUser n'
, chanUserIsInvited n'
, chanUserHasVoice n'
, chanUserIsOper n'] newc''

597
tests/ParseTests.hs Normal file
View File

@ -0,0 +1,597 @@
{-# LANGUAGE OverloadedStrings #-}
module ParseTests where
import Test.Tasty
import Test.Tasty.Hspec as HS
import Data.Attoparsec.ByteString.Char8 as P
import Data.ByteString.Char8 as C8
import Data.List
import Data.Ord
import Pipes.IRC.Message.Parse
import Pipes.IRC.Message.Render
import Pipes.IRC.Message.Types
msgParseSpec :: Spec
msgParseSpec = do
describe "Parsing" $ do
describe "parseMsgOrLine" $ do
it "succeeds parsing an empty line, returning a Left value" $
pMsgOrLine "\r\n"
`shouldBe`
Right (Left "\r\n")
it "succeeds parsing an IRC message, returning a Right value" $
pMsgOrLine "PRIVMSG #haskell :Hi, guys!\r\n"
`shouldBe`
Right
(Right (IrcMessage Nothing (Left PRIVMSG) ["#haskell", "Hi, guys!"]))
describe "parseIrcMessage" $ do
context "Messages with no prefix" $ do
it "matches with no parameters" $
pMsg "NAMES\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NAMES) [])
it "matches with one parameter (without spaces)" $
pMsg "NICK WiZ\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NICK) ["WiZ"])
it "matches with one parameter (with spaces)" $
pMsg "QUIT :Goodbye, cruel world!\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left QUIT) ["Goodbye, cruel world!"])
context "Messages with server name prefix" $ do
it "matches with server name prefixes" $
pMsg ":foo.domain.com ERROR :Oh no!\r\n"
`shouldBe`
Right (IrcMessage (Just (Left "foo.domain.com"))
(Left ERROR)
["Oh no!"] )
it "matches with hyphenated server name prefixes" $
pMsg ":my-domain.org ERROR :Oh no!\r\n"
`shouldBe`
Right (IrcMessage (Just (Left "my-domain.org"))
(Left ERROR)
["Oh no!"] )
context "Messages with nickname prefix" $ do
it "matches with just nick" $
pMsg ":WiZ PRIVMSG #haskell :Hello\r\n"
`shouldBe`
Right (IrcMessage (Just (Right (NickName "WiZ" Nothing Nothing)))
(Left PRIVMSG)
["#haskell", "Hello"] )
it "matches with nick and user" $
pMsg ":WiZ!wiz PRIVMSG #haskell :Hello\r\n"
`shouldBe`
Right (IrcMessage (Just (Right (NickName "WiZ" (Just "wiz") Nothing)))
(Left PRIVMSG)
["#haskell", "Hello"] )
it "matches with nick, user, and host" $
pMsg ":WiZ!wiz@wiz-host.com PRIVMSG #haskell :Hello\r\n"
`shouldBe`
Right (IrcMessage (Just (Right
(NickName
"WiZ"
(Just "wiz")
(Just "wiz-host.com"))))
(Left PRIVMSG)
["#haskell", "Hello"] )
context "Examples from RFC1459" $ do
it "matches PASS example" $
pMsg "PASS secretpasswordhere\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PASS) ["secretpasswordhere"])
it "matches NICK example 1" $
pMsg "NICK Wiz\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NICK) ["Wiz"])
it "matches NICK example 2" $
pMsg ":WiZ NICK Kilroy\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left NICK) ["Kilroy"])
it "matches USER example 1" $
pMsg "USER guest tolmoon tolsun :Ronnie Reagan\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left USER)
["guest", "tolmoon", "tolsun", "Ronnie Reagan"])
it "matches USER example 2" $
pMsg ":testnick USER guest tolmoon tolsun :Ronnie Reagan\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "testnick" Nothing Nothing)))
(Left USER) ["guest", "tolmoon", "tolsun", "Ronnie Reagan"])
it "matches SERVER example 1" $
pMsg "SERVER test.oulu.fi 1 :[tolsun.oulu.fi] Experimental server\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left SERVER)
["test.oulu.fi", "1", "[tolsun.oulu.fi] Experimental server"])
it "matches SERVER example 2" $
pMsg ":tolsun.oulu.fi SERVER csd.bu.edu 5 :BU Central Server\r\n"
`shouldBe`
Right (IrcMessage
(Just (Left "tolsun.oulu.fi"))
(Left SERVER) ["csd.bu.edu", "5", "BU Central Server"])
it "matches OPER example" $
pMsg "OPER foo bar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left OPER) ["foo", "bar"])
it "matches QUIT example" $
pMsg "QUIT :Gone to have lunch\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left QUIT) ["Gone to have lunch"])
it "matches SQUIT example 1" $
pMsg "SQUIT tolsun.oulu.fi :Bad Link ?\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left SQUIT)
["tolsun.oulu.fi", "Bad Link ?"])
it "matches SQUIT example 2" $
pMsg ":Trillian SQUIT cm22.eng.umd.edu :Server out of control\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Trillian" Nothing Nothing)))
(Left SQUIT) ["cm22.eng.umd.edu", "Server out of control"])
it "matches JOIN example 1" $
pMsg "JOIN #foobar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["#foobar"])
it "matches JOIN example 2" $
pMsg "JOIN &foo fubar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["&foo", "fubar"])
it "matches JOIN example 3" $
pMsg "JOIN #foo,&bar fubar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["#foo,&bar", "fubar"])
it "matches JOIN example 4" $
pMsg "JOIN #foo,&bar fubar,foobar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["#foo,&bar", "fubar,foobar"])
it "matches JOIN example 5" $
pMsg "JOIN #foo,#bar\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left JOIN) ["#foo,#bar"])
it "matches JOIN example 6" $
pMsg ":WiZ JOIN #Twilight_zone\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left JOIN) ["#Twilight_zone"])
it "matches PART example 1" $
pMsg "PART #twilight_zone\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PART) ["#twilight_zone"])
it "matches PART example 2" $
pMsg "PART #oz-ops,&group5\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PART) ["#oz-ops,&group5"])
it "matches MODE example 1" $
pMsg "MODE #Finnish +im\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#Finnish", "+im"])
it "matches MODE example 2" $
pMsg "MODE #Finnish +o Kilroy\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#Finnish", "+o", "Kilroy"])
it "matches MODE example 3" $
pMsg "MODE #Finnish +v Wiz\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#Finnish", "+v", "Wiz"])
it "matches MODE example 4" $
pMsg "MODE #Fins -s\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#Fins", "-s"])
it "matches MODE example 5" $
pMsg "MODE #42 +k oulu\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#42", "+k", "oulu"])
it "matches MODE example 6" $
pMsg "MODE #eu-opers +l 10\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["#eu-opers", "+l", "10"])
it "matches MODE example 7" $
pMsg "MODE &oulu +b\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["&oulu", "+b"])
it "matches MODE example 8" $
pMsg "MODE &oulu +b *!*@*\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["&oulu", "+b", "*!*@*"])
it "matches MODE example 9" $
pMsg "MODE &oulu +b *!*@*.edu\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["&oulu", "+b", "*!*@*.edu"])
it "matches MODE example 10" $
pMsg "MODE WiZ -w\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["WiZ", "-w"])
it "matches MODE example 11" $
pMsg ":Angel MODE Angel +i\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Angel" Nothing Nothing)))
(Left MODE) ["Angel", "+i"])
it "matches MODE example 12" $
pMsg "MODE WiZ -o\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left MODE) ["WiZ", "-o"])
it "matches TOPIC example 1" $
pMsg ":WiZ TOPIC #test :New topic\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left TOPIC) ["#test", "New topic"])
it "matches TOPIC example 2" $
pMsg "TOPIC #test :another topic\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left TOPIC) ["#test", "another topic"])
it "matches TOPIC example 3" $
pMsg "TOPIC #test\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left TOPIC) ["#test"])
it "matches NAMES example 1" $
pMsg "NAMES #twilight_zone,#42\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NAMES) ["#twilight_zone,#42"])
it "matches NAMES example 2" $
pMsg "NAMES\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left NAMES) [])
it "matches LIST example 1" $
pMsg "LIST\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left LIST) [])
it "matches LIST example 2" $
pMsg "LIST #twilight_zone,#42\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left LIST) ["#twilight_zone,#42"])
it "matches INVITE example 1" $
pMsg ":Angel INVITE Wiz #Dust\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Angel" Nothing Nothing)))
(Left INVITE) ["Wiz", "#Dust"])
it "matches INVITE example 2" $
pMsg "INVITE Wiz #Twilight_Zone\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left INVITE) ["Wiz", "#Twilight_Zone"])
it "matches KICK example 1" $
pMsg "KICK &Melbourne Matthew\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left KICK) ["&Melbourne", "Matthew"])
it "matches KICK example 2" $
pMsg "KICK #Finnish John :Speaking English\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left KICK)
["#Finnish", "John", "Speaking English"])
it "matches KICK example 3" $
pMsg ":WiZ KICK #Finnish John\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left KICK) ["#Finnish", "John"])
it "matches VERSION example 1" $
pMsg ":WiZ VERSION *.se\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left VERSION) ["*.se"])
it "matches VERSION example 2" $
pMsg "VERSION tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left VERSION) ["tolsun.oulu.fi"])
it "matches STATS example 1" $
pMsg "STATS m\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left STATS) ["m"])
it "matches STATS example 2" $
pMsg ":Wiz STATS c eff.org\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Wiz" Nothing Nothing)))
(Left STATS) ["c", "eff.org"])
it "matches LINKS example 1" $
pMsg "LINKS *.au\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left LINKS) ["*.au"])
it "matches LINKS example 2" $
pMsg ":WiZ LINKS *.bu.edu *.edu\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left LINKS) ["*.bu.edu", "*.edu"])
it "matches TIME example 1" $
pMsg "TIME tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left TIME) ["tolsun.oulu.fi"])
it "matches TIME example 2" $
pMsg ":Angel TIME *.au\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Angel" Nothing Nothing)))
(Left TIME) ["*.au"])
it "matches CONNECT example 1" $
pMsg "CONNECT tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left CONNECT) ["tolsun.oulu.fi"])
it "matches CONNECT example 2" $
pMsg ":WiZ CONNECT eff.org 6667 csd.bu.edu\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left CONNECT) ["eff.org", "6667", "csd.bu.edu"])
it "matches TRACE example 1" $
pMsg "TRACE *.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left TRACE) ["*.oulu.fi"])
it "matches TRACE example 2" $
pMsg ":WiZ TRACE AngelDust\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left TRACE) ["AngelDust"])
it "matches ADMIN example 1" $
pMsg "ADMIN tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left ADMIN) ["tolsun.oulu.fi"])
it "matches ADMIN example 2" $
pMsg ":WiZ ADMIN *.edu\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left ADMIN) ["*.edu"])
it "matches INFO example 1" $
pMsg "INFO csd.bu.edu\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left INFO) ["csd.bu.edu"])
it "matches INFO example 2" $
pMsg ":Avalon INFO *.fi\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Avalon" Nothing Nothing)))
(Left INFO) ["*.fi"])
it "matches INFO example 3" $
pMsg "INFO Angel\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left INFO) ["Angel"])
it "matches PRIVMSG example 1" $
pMsg ":Angel PRIVMSG Wiz :Hello are you receiving this message ?\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "Angel" Nothing Nothing)))
(Left PRIVMSG)
["Wiz", "Hello are you receiving this message ?"])
it "matches PRIVMSG example 2" $
pMsg "PRIVMSG Angel :yes I'm receiving it!\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PRIVMSG)
["Angel", "yes I'm receiving it!"])
it "matches PRIVMSG example 3" $
pMsg "PRIVMSG jto@tolsun.oulu.fi :Hello !\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PRIVMSG)
["jto@tolsun.oulu.fi", "Hello !"])
it "matches PRIVMSG example 4" $
pMsg "PRIVMSG $*.fi :Server tolsun.oulu.fi rebooting.\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PRIVMSG)
["$*.fi", "Server tolsun.oulu.fi rebooting."])
it "matches PRIVMSG example 5" $
pMsg "PRIVMSG #*.edu :NSFNet is undergoing work, expect interruptions\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PRIVMSG)
["#*.edu", "NSFNet is undergoing work, expect interruptions"])
it "matches WHO example 1" $
pMsg "WHO *.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHO) ["*.fi"])
it "matches WHO example 2" $
pMsg "WHO jto* o\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHO) ["jto*", "o"])
it "matches WHOIS example 1" $
pMsg "WHOIS wiz\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOIS) ["wiz"])
it "matches WHOIS example 2" $
pMsg "WHOIS eff.org trillian\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOIS) ["eff.org", "trillian"])
it "matches WHOWAS example 1" $
pMsg "WHOWAS Wiz\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOWAS) ["Wiz"])
it "matches WHOWAS example 2" $
pMsg "WHOWAS Mermaid 9\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOWAS) ["Mermaid", "9"])
it "matches WHOWAS example 3" $
pMsg "WHOWAS Trillian 1 *.edu\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left WHOWAS) ["Trillian", "1", "*.edu"])
it "matches KILL example" $
pMsg "KILL David :(csd.bu.edu <- tolsun.oulu.fi)\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left KILL)
["David", "(csd.bu.edu <- tolsun.oulu.fi)"])
it "matches PING example 1" $
pMsg "PING tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PING) ["tolsun.oulu.fi"])
it "matches PING example 2" $
pMsg "PING WiZ\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PING) ["WiZ"])
it "matches PONG example" $
pMsg "PONG csd.bu.edu tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left PONG)
["csd.bu.edu", "tolsun.oulu.fi"])
it "matches ERROR example" $
pMsg "ERROR :Server *.fi already exists\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left ERROR)
["Server *.fi already exists"])
it "matches AWAY example 1" $
pMsg "AWAY :Gone to lunch. Back in 5\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left AWAY)
["Gone to lunch. Back in 5"])
it "matches AWAY example 2" $
pMsg ":WiZ AWAY\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "WiZ" Nothing Nothing)))
(Left AWAY) [])
it "matches REHASH example" $
pMsg "REHASH\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left REHASH) [])
it "matches RESTART example" $
pMsg "RESTART\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left RESTART) [])
it "matches SUMMON example 1" $
pMsg "SUMMON jto\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left SUMMON) ["jto"])
it "matches SUMMON example 2" $
pMsg "SUMMON jto tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left SUMMON) ["jto", "tolsun.oulu.fi"])
it "matches USERS example 1" $
pMsg "USERS eff.org\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left USERS) ["eff.org"])
it "matches USERS example 2" $
pMsg ":John USERS tolsun.oulu.fi\r\n"
`shouldBe`
Right (IrcMessage
(Just (Right (NickName "John" Nothing Nothing)))
(Left USERS) ["tolsun.oulu.fi"])
it "matches WALLOPS example" $
pMsg ":csd.bu.edu WALLOPS :Connect '*.uiuc.edu 6667' from Joshua\r\n"
`shouldBe`
Right (IrcMessage
(Just (Left "csd.bu.edu"))
(Left WALLOPS) ["Connect '*.uiuc.edu 6667' from Joshua"])
it "matches USERHOST example" $
pMsg "USERHOST Wiz Michael Marty p\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left USERHOST)
["Wiz", "Michael", "Marty", "p"])
it "matches ISON example" $
pMsg "ISON phone trillian WiZ jarlek Avalon Angel Monstah\r\n"
`shouldBe`
Right (IrcMessage Nothing (Left ISON)
["phone", "trillian", "WiZ", "jarlek", "Avalon"
, "Angel", "Monstah"])
where
pMsgOrLine = parseOnly parseMsgOrLine
pMsg = parseOnly parseIrcMessage
msgRenderSpec :: Spec
msgRenderSpec = undefined