-
Notifications
You must be signed in to change notification settings - Fork 0
/
Set14bTest.hs
216 lines (187 loc) · 8.65 KB
/
Set14bTest.hs
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
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TupleSections #-}
module Set14bTest where
import Mooc.Test
import Mooc.Th
import Control.Exception
import Control.Monad
import Data.List
import qualified Data.Text as T
import Test.QuickCheck
import Test.QuickCheck.Monadic
import Database.SQLite.Simple
import Network.HTTP (simpleHTTP, getRequest, getResponseBody)
import Network.Wai.Handler.Warp (withApplication, testWithApplication)
import Set14b hiding (main)
main = score tests
tests = [(1,"deposit",[ex1])
,(2,"withdraw",[ex2_small, ex2_big])
,(3,"parseCommand",[ex3])
,(4,"perform",[ex4_small, ex4_big])
,(5,"simpleServer",[ex5])
,(6,"server",[ex6_small, ex6_big])
,(7,"server withdraw",[ex7_small, ex7_big])
,(8,"server isError",[ex8_parseCommand, ex8_http])]
-- -- -- -- --
word = listOf1 (choose ('a','z'))
getAllQuery' = Query (T.pack "SELECT account, amount FROM events;")
-- TODO test against SQL injections?
ex1 =
forAllBlind word $ \name1 ->
forAllBlind word $ \name2 ->
forAllBlind (choose (0,10)) $ \amount1 ->
forAllBlind (choose (0,10)) $ \amount2 ->
counterexample "After running" $
counterexample (" db <- openDatabase \"\"") $
counterexample (" deposit db (T.pack " ++ show name1 ++ ") " ++ show amount1) $
counterexample (" deposit db (T.pack " ++ show name2 ++ ") " ++ show amount2) $
monadicIO $ do
out <- run $ bracket (openDatabase "") close $ \db -> do
deposit db (T.pack name1) amount1
deposit db (T.pack name2) amount2
query_ db getAllQuery' :: IO [(String,Int)]
stop_ $ counterexample "The output of: query_ db getAllQuery :: IO [(String,Int)]" $
out ?== [(name1,amount1),(name2,amount2)]
ex2_small =
forAllBlind word $ \name ->
forAllBlind (choose (0,10)) $ \amount1 ->
forAllBlind (choose (0,10)) $ \amount2 ->
counterexample "After running" $
counterexample (" db <- openDatabase \"\"") $
counterexample (" deposit db (T.pack " ++ show name ++ ") " ++ show amount1) $
counterexample (" deposit db (T.pack " ++ show name ++ ") " ++ show amount2) $
counterexample ("The output of: balance db " ++ show name) $
monadicIO $ do
out <- run $ bracket (openDatabase "") close $ \db -> do
deposit db (T.pack name) amount1
deposit db (T.pack name) amount2
balance db (T.pack name)
stop_ $ out ?== amount1 + amount2
ex2_big =
forAllBlind word $ \name ->
forAllBlind (listOf (choose (0,10))) $ \amounts ->
forAllBlind (listOf1 $ (,) <$> suchThat word (/=name) <*> choose (0,10)) $ \chaff ->
let input0 = map (name,) amounts ++ chaff
in forAllBlind (shuffle input0) $ \input ->
counterexample "After running" $
counterexample (intercalate "\n" (map depo input)) $
counterexample ("The output of: balance db " ++ show name) $
monadicIO $ do
out <- run $ bracket (openDatabase "") close $ \db -> do
forM_ input $ \(n,a) -> deposit db (T.pack n) a
balance db (T.pack name)
stop_ $ out ?== sum amounts
where depo (name,amount) = " deposit db " ++ show name ++ " " ++ show amount
ex3 =
forAllBlind word $ \name ->
forAllBlind (choose (0,9999)) $ \amount ->
conjoin [counterexample ("parseCommand [T.pack \"balance\", T.pack " ++ show name ++ "]") $
parseCommand [T.pack "balance", T.pack name]
?== Just (Balance (T.pack name))
,counterexample ("parseCommand [T.pack \"deposit\", T.pack " ++ show name ++ ", T.pack " ++ show (show amount) ++ "]") $
parseCommand [T.pack "deposit", T.pack name, T.pack (show amount)]
?== Just (Deposit (T.pack name) amount)]
ex4_small =
forAllBlind word $ \name ->
forAllBlind (choose (0,10)) $ \amount ->
counterexample "Running" $
counterexample " db <- openDatabase \"\"" $
counterexample (" out1 <- perform db (Just (Deposit (T.pack "++ show name++") " ++ show amount ++ "))") $
counterexample (" out2 <- perform db (Just (Balance (T.pack "++ show name++")))") $
counterexample (" return [out1,out2]") $
counterexample "The output:" $
monadicIO $ do
out <- run $ bracket (openDatabase "") close $ \db -> do
out1 <- perform db (Just (Deposit (T.pack name) amount))
out2 <- perform db (Just (Balance (T.pack name)))
return [out1,out2]
stop_ $ out ?== [T.pack "OK", T.pack (show amount)]
mkDeposit n a = Just (Deposit (T.pack n) a)
ex4_big =
forAllBlind word $ \name ->
forAllBlind (listOf (choose (0,10))) $ \amounts ->
forAllBlind (listOf1 $ mkDeposit <$> suchThat word (/=name) <*> choose (0,10)) $ \chaff ->
let input0 = map (mkDeposit name) amounts ++ chaff
in forAllBlind (shuffle input0) $ \input1 ->
let input = input1 ++ [Just (Balance (T.pack name))]
in counterexample "Note: T.pack calls left out due to technical reasons." $
counterexample "Running" $
counterexample " db <- openDatabase \"\"" $
counterexample (" mapM (perform db) " ++ show input) $
monadicIO $ do
out <- run $ bracket (openDatabase "") close $ \db ->
mapM (perform db) input
stop_ $ out ?== (replicate (length input - 1) (T.pack "OK")) ++ [T.pack (show (sum amounts))]
get url = simpleHTTP (getRequest url) >>= getResponseBody
ex5 =
once $
counterexample "Running: run 8899 simpleServer" $
counterexample "And fetching http://localhost:8899" $
monadicIO $ do
out <- run $ testWithApplication (return simpleServer) $ \port ->
get ("http://127.0.0.1:" ++ show port)
stop_ $ out ?== "BANK"
testHTTP paths expected =
counterexample "Running:" $
counterexample " db <- openDatabase \"\"" $
counterexample " run 4321 (server db)" $
counterexample "Fetching:" $
counterexample (unlines $ map (" - http://localhost:4321"++) paths) $
monadicIO $ do
out <- run $ bracket (openDatabase "") close $ \db ->
testWithApplication (return (server db)) $ \port ->
mapM get (map (("http://127.0.0.1:"++show port)++) paths)
stop_ $ out ?== expected
ex6_small =
once $
testHTTP ["/deposit/lopez/17", "/balance/lopez"] ["OK", "17"]
depositPath :: String -> Int -> String
depositPath name amount
| amount<0 = "/withdraw/" ++ name ++ "/" ++ show (negate amount)
| otherwise = "/deposit/" ++ name ++ "/" ++ show amount
ex6_big =
forAllBlind word $ \name ->
forAllBlind (listOf (choose (0,10))) $ \amounts ->
forAllBlind (listOf1 $ depositPath <$> suchThat word (/=name) <*> choose (0,10)) $ \chaff ->
let input0 = map (depositPath name) amounts ++ chaff
in forAllBlind (shuffle input0) $ \input1 ->
let input = input1 ++ ["/balance/" ++ name]
in testHTTP input ((replicate (length input - 1) "OK") ++ [show (sum amounts)])
ex7_small =
once $
testHTTP ["/deposit/simon/17", "/withdraw/simon/6", "/balance/simon"] ["OK", "OK", "11"]
ex7_big =
forAllBlind word $ \name ->
forAllBlind (listOf (choose (-10,10))) $ \amounts ->
forAllBlind (listOf1 $ depositPath <$> suchThat word (/=name) <*> choose (0,10)) $ \chaff ->
let input0 = map (depositPath name) amounts ++ chaff
in forAllBlind (shuffle input0) $ \input1 ->
let input = input1 ++ ["/balance/" ++ name]
in testHTTP input ((replicate (length input - 1) "OK") ++ [show (sum amounts)])
ex8_parseCommand = conjoin [$(testing [|parseCommand v|]) (?==Nothing)
| v <- (map.map) T.pack [[]
,["deposit"]
,["withdraw"]
,["deposit","x"]
,["withdraw","x"]
,["deposit","x","123x"]
,["withdraw","x","123x"]
,["deposit","x","123","x"]
,["withdraw","x","123","x"]
,["balance"]
,["balance","x","y"]
,["balance","x","123"]]]
isError url = testHTTP [url] ["ERROR"]
ex8_http = forAllBlind word $ \w ->
forAllBlind word $ \name ->
forAllBlind (choose (0,10::Int)) $ \amount ->
conjoin [isError ("/"++w)
,isError ("/deposit/"++w)
,isError ("/withdraw/"++w)
,isError ("/deposit/"++name++"/"++show amount++w)
,isError ("/withdraw/"++name++"/"++show amount++w)
,isError ("/deposit/"++name++"/"++show amount++"/"++w)
,isError ("/deposit/"++name++"/"++show amount++"/"++w++"/"++w)
,isError ("/withdraw/"++name++"/"++show amount++"/"++w)
,isError ("/balance")
,isError ("/balance/" ++ name ++ "/" ++ w)
,isError ("/balance/" ++ name ++ "/" ++ show amount)]