From fd141d09fb466ea12112204ee3435ff2cb910025 Mon Sep 17 00:00:00 2001 From: Levi Pearson Date: Thu, 12 Jun 2014 03:33:09 -0600 Subject: [PATCH] Misc refresh and cleanup, added some QuickCheck props --- pipes-irc-server.cabal | 72 +-- src/Pipes/IRC/Server.hs | 9 +- src/Pipes/IRC/Server/Channel.hs | 61 +- src/Pipes/IRC/Server/EventHandler.hs | 7 +- src/Pipes/IRC/Server/IrcMonad.hs | 2 +- src/Pipes/IRC/Server/MessageHandler.hs | 4 +- src/Pipes/IRC/Server/Server.hs | 32 +- src/Pipes/IRC/Server/Types.hs | 4 +- tests/Main.hs | 751 +++++-------------------- tests/ParseTests.hs | 597 ++++++++++++++++++++ 10 files changed, 827 insertions(+), 712 deletions(-) create mode 100644 tests/ParseTests.hs diff --git a/pipes-irc-server.cabal b/pipes-irc-server.cabal index 8973397..4110081 100644 --- a/pipes-irc-server.cabal +++ b/pipes-irc-server.cabal @@ -23,26 +23,26 @@ executable pipes-irc-server , Pipes.IRC.Server.Types , Pipes.IRC.Server.MessageHandler -- other-extensions: - build-depends: base >= 4.6 && < 4.7 - , mtl >= 2.1 && < 3 - , errors >= 1.4 && < 2 - , mmorph >= 1 && < 2 - , containers >= 0.5 && < 1 - , bytestring >= 0.10 && < 0.11 - , text >= 0.11.3 && < 0.12 - , attoparsec >= 0.10 && < 0.11 - , network >= 2.4 && < 2.5 - , pipes >= 4 && < 5 - , pipes-concurrency >= 2 && < 3 - , pipes-bytestring >= 1.0 && < 2 - , pipes-parse >= 2.0 && < 3 - , pipes-attoparsec >= 0.3 && < 1 - , pipes-network >= 0.6 && < 1 - , stm >= 2 && < 3 - , time >= 1.4 && < 1.5 - , async >= 2 && < 3 - , free >= 3 && < 4 - , lens >= 3 && < 4 + build-depends: base + , mtl + , errors + , mmorph + , containers + , bytestring + , text + , attoparsec + , network + , pipes + , pipes-concurrency + , pipes-bytestring + , pipes-parse + , pipes-attoparsec + , pipes-network + , stm + , time + , async + , free + , lens hs-source-dirs: src default-language: Haskell2010 @@ -50,21 +50,23 @@ executable pipes-irc-server test-suite tests type: exitcode-stdio-1.0 main-is: Main.hs - build-depends: base >= 4.6 && < 4.7 - , mtl >= 2.1 && < 3 - , containers >= 0.5 && < 1 - , bytestring >= 0.10 && < 0.11 - , text >= 0.11.3 && < 0.12 - , attoparsec >= 0.10 && < 0.11 - , pipes >= 4 && < 5 - , pipes-concurrency >= 2 && < 3 - , pipes-bytestring >= 1.0 && < 2 - , pipes-parse >= 2.0 && < 3 - , pipes-attoparsec >= 0.3 && < 1 - , pipes-network >= 0.6 && < 1 - , stm >= 2 && < 3 - , async >= 2 && < 3 - , free >= 3 && < 4 + build-depends: base + , mtl + , containers + , bytestring + , text + , attoparsec + , pipes + , pipes-concurrency + , pipes-bytestring + , pipes-parse + , pipes-attoparsec + , pipes-network + , stm + , async + , free + , lens + , time build-depends: tasty , tasty-hspec , tasty-hunit diff --git a/src/Pipes/IRC/Server.hs b/src/Pipes/IRC/Server.hs index cb6524a..dd420f4 100644 --- a/src/Pipes/IRC/Server.hs +++ b/src/Pipes/IRC/Server.hs @@ -35,10 +35,10 @@ version = "0.1a" parseMessage :: Producer ByteString IO () -> Producer (Either ByteString IrcMessage) IO () parseMessage prod = do - void $ for (parseMany parseMsgOrLine prod) $ \res -> + void $ for (parsed parseMsgOrLine prod) $ \res -> case res of - (_, Left _) -> yield $ Left "ERROR Bad Parse" - (_, Right val) -> yield $ Right val + (Left _) -> yield $ Left "ERROR Bad Parse" + (Right val) -> yield $ Right val return () renderMessage :: Pipe IrcMessage ByteString IO () @@ -153,7 +153,8 @@ idlePinger srv cid = atomically $ do conns <- readTVar (srv ^. ircConnections) - PC.send (conns ! cid ^. out) pingMsg + void $ PC.send (conns ! cid ^. out) pingMsg + return () threadDelay oneMinute diff --git a/src/Pipes/IRC/Server/Channel.hs b/src/Pipes/IRC/Server/Channel.hs index cf771b9..a12672f 100644 --- a/src/Pipes/IRC/Server/Channel.hs +++ b/src/Pipes/IRC/Server/Channel.hs @@ -15,6 +15,7 @@ module Pipes.IRC.Server.Channel , chanSigil , chanUserSigil , chanSetPass + , chanClearPass , chanHasPass , chanCheckPass , 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 -- the set of set of channels on the user or perform any checking; -- 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 -- change the set of channels on the user or perform any checking; -- this just performs the low-level change to the channel. -chanDelUser un = (chanUsers %~ delete un) - . (chanOpers %~ delete un) - . (chanVoices %~ delete un) +chanDelUser uname = (chanUsers %~ delete uname) + . (chanOpers %~ delete uname) + . (chanVoices %~ delete uname) -- | Is the user owning the given nick on the channel? Returns 'True' -- if the user is in fact on the channel. chanHasUser :: NickKey -- ^ user to check presence of on the channel -> IrcChannel -- ^ channel in which to look for the user -> 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 -- 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 -> IrcChannel -- ^ channel the user may have status in -> ByteString -- ^ the sigil associated with the user's status -chanUserSigil un ch | member un $ ch ^. chanOpers = "@" - | member un $ ch ^. chanVoices = "+" - | otherwise = "" +chanUserSigil uname ch | member uname $ ch ^. chanOpers = "@" + | member uname $ ch ^. chanVoices = "+" + | otherwise = "" -- | Set a password key that must be given with a JOIN command in -- 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 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 -- channel does have a password key set. 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 -- not perform any permission or error checks, it just performs the -- low-level operation. -chanAddOper un = chanOpers %~ insert un +chanAddOper uname = chanOpers %~ insert uname -- | Remove the given nickname as an operator on the channel. This -- does not perform any permission or error checks, it just performs -- the low-level operation. -chanDelOper un = chanOpers %~ delete un +chanDelOper uname = chanOpers %~ delete uname chanAddVoice, chanDelVoice :: NickKey -- ^ nickname of user -> 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 -- does not perform any permission or error checks, it just performs -- 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 -- does not perform any permission or error checks, it just performs -- the low-level operation. -chanDelVoice un = chanVoices %~ delete un +chanDelVoice uname = chanVoices %~ delete uname chanAddInvite, chanDelInvite :: NickKey -- ^ nickname of user -> 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 does not perform any permission or error checks, it just does -- the operation. -chanAddInvite un = chanInvites %~ insert un +chanAddInvite uname = chanInvites %~ insert uname -- | Remove record of the invitation for the nickname to join the -- channel. This does not perform permission or error checks, it just -- 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 -- 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 -> IrcChannel -- ^ channel to check -> 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 -- 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 -> IrcChannel -- ^ channel to check -> 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 -- 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 -> IrcChannel -- ^ channel to check -> 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' -- 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 -> IrcChannel -- ^ channel to check -> Bool -- ^ 'True' if nickname may speak on channel -chanUserMaySpeak un ch - | (chanHasUser un ch || not (chanHasModeFlag NoOutsideMsgs ch)) +chanUserMaySpeak uname ch + | (chanHasUser uname ch || not (chanHasModeFlag NoOutsideMsgs ch)) && not (chanHasModeFlag Moderated ch) = True - | chanUserIsOper un ch = True - | chanUserHasVoice un ch = True + | chanUserIsOper uname ch = True + | chanUserHasVoice uname ch = True | otherwise = False -- | Is the nickname allowed to join the channel? Returns 'True' if @@ -261,9 +268,9 @@ chanUserMaySpeak un ch chanUserMayJoin :: NickKey -- ^ nickname to check -> IrcChannel -- ^ channel to check -> Bool -- ^ 'True' if nickname may join the channel -chanUserMayJoin un ch +chanUserMayJoin uname ch | not $ chanHasModeFlag InviteOnly ch = True - | chanUserIsInvited un ch = True + | chanUserIsInvited uname ch = True | otherwise = False -- | Is the nickname allowed to set the topic for the channel? @@ -271,8 +278,8 @@ chanUserMayJoin un ch chanUserMaySetTopic :: NickKey -- ^ nickname to check -> IrcChannel -- ^ channel to check -> Bool -- ^ 'True' if nickname may set the topic -chanUserMaySetTopic un ch +chanUserMaySetTopic uname ch | not (chanHasModeFlag TopicOperOnly ch) && - chanHasUser un ch = True - | chanUserIsOper un ch = True - | otherwise = False + chanHasUser uname ch = True + | chanUserIsOper uname ch = True + | otherwise = False diff --git a/src/Pipes/IRC/Server/EventHandler.hs b/src/Pipes/IRC/Server/EventHandler.hs index f5007dd..7793a95 100644 --- a/src/Pipes/IRC/Server/EventHandler.hs +++ b/src/Pipes/IRC/Server/EventHandler.hs @@ -4,6 +4,7 @@ module Pipes.IRC.Server.EventHandler ( ircEventHandler ) where +import Control.Applicative ((<$>)) import Control.Concurrent.Async import Control.Concurrent.STM import Control.Lens @@ -25,12 +26,10 @@ ircEventHandler srv evt = case evt of Close connId -> do outConns <- readTVarIO $ srv ^. ircConnections - case M.lookup connId outConns of - Just IrcConnection{..} -> return False - _ -> return True + return $ isJust (M.lookup connId outConns) Msg {..} -> do 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 logOutMsg _outMsg _outDest return True diff --git a/src/Pipes/IRC/Server/IrcMonad.hs b/src/Pipes/IRC/Server/IrcMonad.hs index 9394666..e54442a 100644 --- a/src/Pipes/IRC/Server/IrcMonad.hs +++ b/src/Pipes/IRC/Server/IrcMonad.hs @@ -97,7 +97,7 @@ channelTargets chname = do let cUsers chan = S.elems (S.delete mynick $ chan ^. chanUsers) let chmap = srv ^. ircChannels 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"] return [] diff --git a/src/Pipes/IRC/Server/MessageHandler.hs b/src/Pipes/IRC/Server/MessageHandler.hs index c7eaeae..d4e78cb 100644 --- a/src/Pipes/IRC/Server/MessageHandler.hs +++ b/src/Pipes/IRC/Server/MessageHandler.hs @@ -5,7 +5,7 @@ module Pipes.IRC.Server.MessageHandler ( ircMessageHandler ) where -import Control.Applicative (pure, (<$>), (<|>)) +import Control.Applicative ((<|>)) import Control.Error import Control.Lens import Control.Monad.RWS @@ -144,7 +144,7 @@ doJoin msg chans = forM_ chans $ \(c, k) -> runValidation $ do nick <- checkRegistration -- If the channel is absent, joining it will create it checkChannelAbsence c - -- If it already exists, do some sanity checks first + -- If it already exists, do some sanity checks first <|> do chan <- checkChannelPresence c checkUserNotOnChan nick c chan checkInvitation nick c chan diff --git a/src/Pipes/IRC/Server/Server.hs b/src/Pipes/IRC/Server/Server.hs index 9dc41bd..134ce37 100644 --- a/src/Pipes/IRC/Server/Server.hs +++ b/src/Pipes/IRC/Server/Server.hs @@ -53,9 +53,9 @@ ircDelUser nn srv = uchans = S.elems (usr ^. userChannels) ichans = S.elems (usr ^. userInvites) in - (ircUsers %~ M.delete nn) . - (ircChannels %~ alterAtKeys (ircPartChan nn) uchans) . - (ircChannels %~ adjustAtKeys (chanDelInvite nn) ichans) + (ircUsers %~ M.delete nn) + . (ircChannels %~ alterAtKeys (ircPartChan nn) uchans) + . (ircChannels %~ adjustAtKeys (chanDelInvite nn) ichans) -- | Check whether a user with the given nickname is known by the -- 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 -> IrcServer -- ^ server to perform the join on -> IrcServer -- ^ new server with join completed -ircJoin un cn = (ircChannels %~ M.alter alterChan cn) - . (ircUsers %~ M.adjust (userAddChan cn) un) +ircJoin uname cn = (ircChannels %~ M.alter alterChan cn) + . (ircUsers %~ M.adjust (userAddChan cn) uname) 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 ircPartChan :: NickKey -> Maybe IrcChannel -> Maybe IrcChannel -ircPartChan un (Just chan) = case chanDelUser un chan of - IrcChannel{ _chanUsers = us } - | us == S.empty -> Nothing - chan' -> Just chan' -ircPartChan _ Nothing = Nothing +ircPartChan uname (Just chan) = + case chanDelUser uname chan of + IrcChannel{ _chanUsers = us } + | us == S.empty -> Nothing + chan' -> Just chan' +ircPartChan _ Nothing = Nothing -- | Remove the user with the given nickname from the named -- 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 -> IrcServer -- ^ server to perform the part on -> IrcServer -- ^ new server with part completed -ircPart un cn srv = - srv & (ircChannels %~ (M.alter $ ircPartChan un) cn) +ircPart uname cn srv = + srv & (ircChannels %~ (M.alter $ ircPartChan uname) cn) & (ircUsers %~ adjustAtKeys (userDelInvite cn) iusers) where chan = (srv ^. ircChannels) ! cn @@ -112,8 +114,8 @@ ircInvite :: NickKey -- ^ nickname of user to invite -> ChanKey -- ^ name of channel user is invited to -> IrcServer -- ^ server to perform the invitation on -> IrcServer -- ^ new server with invite completed -ircInvite un cn = (ircChannels %~ M.adjust (chanAddInvite un) cn) - . (ircUsers %~ M.adjust (userAddInvite cn) un) +ircInvite uname cn = (ircChannels %~ M.adjust (chanAddInvite uname) cn) + . (ircUsers %~ M.adjust (userAddInvite cn) uname) -- | Determine whether the user with the given nickname is disallowed -- from joining the channel due to the 'InviteOnly' flag and lack of diff --git a/src/Pipes/IRC/Server/Types.hs b/src/Pipes/IRC/Server/Types.hs index 8c07e52..953a035 100644 --- a/src/Pipes/IRC/Server/Types.hs +++ b/src/Pipes/IRC/Server/Types.hs @@ -62,7 +62,7 @@ data IrcUserMode = Away -- ^ the user is marked as away from keyboard | Oper -- ^ the user is an IRC operator | LocalOper -- ^ the user is a local server operator | 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 -- channel-specific. @@ -90,7 +90,7 @@ data IrcChanModeFlags = Anonymous -- ^ all communication is anonymized | Private -- ^ channel shows up as private in list | Secret -- ^ channel does not appear in list | 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. data IrcChannel = diff --git a/tests/Main.hs b/tests/Main.hs index 39583b4..512b517 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -3,27 +3,27 @@ module Main where import Test.Tasty -import Test.Tasty.Hspec as HS ---import Test.Tasty.HUnit as HU ---import Test.Tasty.QuickCheck as QC ---import Test.Tasty.SmallCheck as SC +import Test.Tasty.Hspec as HS +import Test.Tasty.QuickCheck as QC -import Data.Attoparsec.ByteString.Char8 as P -import Data.ByteString.Char8 as C8 +import Control.Applicative + +import qualified Data.ByteString.Char8 as C8 import Data.List -import Data.Ord +import Data.Monoid -import Pipes.IRC.Message.Parse -import Pipes.IRC.Message.Render -import Pipes.IRC.Message.Types +import ParseTests + +import Pipes.IRC.Server.Channel +import Pipes.IRC.Server.Server +import Pipes.IRC.Server.Types +import Pipes.IRC.Server.User main :: IO () main = defaultMain tests tests :: TestTree -tests = testGroup "Tests" [specs] ---tests = testGroup "Tests" [specs, properties, unitTests] - +tests = testGroup "Tests" [specs, userProperties, chanProperties] -- Hspec Tests @@ -33,617 +33,8 @@ specs = testGroup "Specifications" -- , 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 {- -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 unitTests = testGroup "Unit tests" @@ -655,3 +46,119 @@ unitTests = testGroup "Unit tests" [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'' diff --git a/tests/ParseTests.hs b/tests/ParseTests.hs new file mode 100644 index 0000000..690e7aa --- /dev/null +++ b/tests/ParseTests.hs @@ -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