1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
{-# LANGUAGE OverloadedStrings #-}
module Main
(
main
) where
import Network.IRC
import Data.ByteString (ByteString, append, pack)
import Data.Word (Word8)
import Data.Char (ord)
import Control.Applicative (liftA)
import Test.HUnit
import Test.QuickCheck
import Test.Framework as TF (defaultMain, testGroup, Test)
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2 (testProperty)
-- ---------------------------------------------------------
-- Helpful Wrappers
-- An identifier starts with a letter, and consists of interspersed numbers
-- and special characters
newtype Identifier = Identifier { unIdentifier :: ByteString }
deriving (Read,Show,Eq)
instance Arbitrary Identifier where
arbitrary = do
l <- letter
ls <- sized $ \n -> loop n
return $ Identifier (pack (l:ls))
where loop n | n <= 0 = return []
| otherwise = do i <- identifier
is <- loop (n-1)
return (i:is)
-- A hostname is a string that starts and ends with an identifier, and has
-- periods peppered in the middle.
newtype Host = Host { unHost :: ByteString }
instance Arbitrary Host where
arbitrary = do
l <- identifier
ls <- sized $ \n -> loop n
js <- sized $ \n -> loop n
e <- identifier
return $ Host (pack (l:ls ++ (w8 '.':js) ++ [e]))
where loop n | n <= 0 = return []
| otherwise = do i <- host
is <- loop (n-1)
return (i:is)
w8 :: Char -> Word8
w8 = fromIntegral . ord
letter :: Gen Word8
letter = frequency
[ (50, choose (w8 'a', w8 'z'))
, (50, choose (w8 'A', w8 'Z'))
]
digit :: Gen Word8
digit = choose (w8 '0', w8 '9')
special :: Gen Word8
special = elements [w8 '_', w8 '-']
identifier :: Gen Word8
identifier = frequency
[ (50, letter)
, (30, digit)
, (10, special)
]
host :: Gen Word8
host = frequency
[ (90, identifier)
, (20, return (w8 '.'))
]
-- ---------------------------------------------------------
-- IRC Types
newtype Cmd = Cmd { unCmd :: ByteString }
deriving (Read,Show,Eq)
instance Arbitrary Cmd where
arbitrary =
let c = (replyTable !!) <$> choose (0, length replyTable - 1)
in Cmd . fst <$> c
instance Arbitrary Prefix where
arbitrary = oneof
[ NickName
<$> fmap unIdentifier arbitrary
<*> fmap (liftA unIdentifier) arbitrary
<*> fmap (liftA unIdentifier) arbitrary
, Server
<$> fmap unHost arbitrary
]
instance Arbitrary Message where
arbitrary =
let params = map unIdentifier <$> sized vector
cmd = unCmd <$> arbitrary
in Message <$> arbitrary <*> cmd <*> params
-- ---------------------------------------------------------
-- Properties
prop_encodeDecode :: Message -> Bool
prop_encodeDecode msg = (decode . appendCRLF . encode $ msg)
== Just msg
where appendCRLF bs = append bs (pack [w8 '\r', w8 '\n'])
properties :: TF.Test
properties = testGroup "QuickCheck Network.IRC"
[ testProperty "encodeDecode" prop_encodeDecode
]
-- ---------------------------------------------------------
-- Unit Tests
unitTests :: TF.Test
unitTests = testGroup "HUnit tests Network.IRC"
[ -- Decoding tests
testCase "PRIVMSG foo :bar baz"
( decode "PRIVMSG foo :bar baz"
@=? Just (Message Nothing "PRIVMSG" ["foo", "bar baz"]))
, testCase ":foo.bar NOTICE baz baz :baz baz"
( decode ":foo.bar NOTICE baz baz :baz baz"
@=? Just (Message (Just (Server "foo.bar")) "NOTICE" ["baz", "baz", "baz baz"]))
, testCase ":foo.bar 001 baz baz :baz baz"
( decode ":foo.bar 001 baz baz :baz baz"
@=? Just (Message (Just (Server "foo.bar")) "001" ["baz", "baz", "baz baz"]))
, testCase ":foo!bar@baz PRIVMSG #foo :bar baz"
( decode ":foo!bar@baz PRIVMSG #foo :bar baz"
@=? Just (Message (Just (NickName "foo" (Just "bar") (Just "baz"))) "PRIVMSG" ["#foo", "bar baz"]))
, testCase ":foo@baz PRIVMSG #foo :bar baz"
( decode ":foo@baz PRIVMSG #foo :bar baz"
@=? Just (Message (Just (NickName "foo" Nothing (Just "baz"))) "PRIVMSG" ["#foo", "bar baz"]))
, testCase ":foo!bar PRIVMSG #foo :bar baz"
( decode ":foo!bar PRIVMSG #foo :bar baz"
@=? Just (Message (Just (NickName "foo" (Just "bar") Nothing)) "PRIVMSG" ["#foo", "bar baz"]))
, testCase ":foo PRIVMSG #foo :bar baz"
( decode ":foo PRIVMSG #foo :bar baz"
@=? Just (Message (Just (NickName "foo" Nothing Nothing)) "PRIVMSG" ["#foo", "bar baz"]))
-- Decoding tests
-- Initial colon encoding tests
, testCase "Message Nothing \"PRIVMSG\" [\"#foo\", \":bar bas\"]"
( encode (Message Nothing "PRIVMSG" ["#foo", ":bar bas"])
@?= "PRIVMSG #foo ::bar bas")
, testCase "Message Nothing \"PRIVMSG\" [\"#foo\", \":bar\"]"
( encode (Message Nothing "PRIVMSG" ["#foo", ":bar"])
@?= "PRIVMSG #foo ::bar")
-- Corrected case
, testCase ":talon.nl.eu.SwiftIRC.net 332 foo #bar :\n"
( decode ":talon.nl.eu.SwiftIRC.net 332 foo #bar :\n"
@?= Just (Message (Just $ Server "talon.nl.eu.SwiftIRC.net") "332" ["foo","#bar",""]))
]
-- ---------------------------------------------------------
-- Test List
tests :: [TF.Test]
tests = [ properties
, unitTests
]
main :: IO ()
main = defaultMain tests
|
