pipes-irc-server/tests/Main.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import           Test.Tasty
import           Test.Tasty.Hspec         as HS
import           Test.Tasty.QuickCheck    as QC

import           Control.Applicative

import qualified Data.ByteString.Char8    as C8
import           Data.List
import           Data.Monoid

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, userProperties, chanProperties]

-- Hspec Tests

specs :: TestTree
specs = testGroup "Specifications"
  [ HS.testCase "Message Parsing" msgParseSpec
--  , HS.testCase "Message Rendering" msgRenderSpec
  ]

-- 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''