Misc refresh and cleanup, added some QuickCheck props
Levi Pearson
parent
45eb76c8af
commit
fd141d09fb
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 []
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
751
tests/Main.hs
751
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''
|
||||
|
|
|
|||
|
|
@ -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
|
||||
Loading…
Reference in New Issue