169 lines
4.7 KiB
Haskell
169 lines
4.7 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Main where
|
|
|
|
import Test.Tasty
|
|
import Test.Tasty.Hspec as HS
|
|
import Test.Tasty.QuickCheck as QC
|
|
|
|
import qualified Data.ByteString.Char8 as C8
|
|
import Data.List
|
|
|
|
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 = do
|
|
ts <- tests
|
|
defaultMain ts
|
|
|
|
tests :: IO TestTree
|
|
tests = do
|
|
sps <- specs
|
|
return $ testGroup "Tests" [sps, userProperties, chanProperties]
|
|
|
|
-- Hspec Tests
|
|
|
|
specs :: IO TestTree
|
|
specs = do
|
|
mps <- HS.testSpec "Message Parsing" msgParseSpec
|
|
-- mrs <- HS.testCase "Message Rendering" msgRenderSpec
|
|
return $ testGroup "Specifications"
|
|
[ mps
|
|
-- , mrs
|
|
]
|
|
|
|
-- QuickCheck and SmallCheck properties
|
|
{-
|
|
-- HUnit tests
|
|
|
|
unitTests = testGroup "Unit tests"
|
|
[ HS.testCase "List comparison (different length)" $
|
|
[1, 2, 3] `compare` [1,2] @?= GT
|
|
|
|
-- the following test does not hold
|
|
, HS.testCase "List comparison (same length)" $
|
|
[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''
|