llsd-0.1.0.1: Network/Format/LLSD/TestIDL.hs
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-binds #-}
-- |
-- Module : Network.Format.LLSD.TestIDL
-- Copyright : (c) Linden Lab 2009
-- License : MIT
-- Maintainer : bos@lindenlab.com
-- Stability : provisional
-- Portability : portable
module Network.Format.LLSD.TestIDL (
runTests,
runChecks
)
where
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import Data.Maybe
import Data.Time
import qualified Data.UUID as UUID
import Network.Format.LLSD
import Network.Format.LLSD.LLIDL
import qualified Network.URI as URI
import Test.HUnit
import Test.QuickCheck
import System.IO (stderr)
nullUUID, someUUID :: UUID.UUID
nullUUID = fromJust $ UUID.fromString "00000000-0000-0000-0000-000000000000"
someUUID = fromJust $ UUID.fromString "14409e2f-5588-4c12-b719-ff33f614e3b7"
nullDate, someDate :: UTCTime
nullDate = UTCTime (fromGregorian 1970 01 01) (secondsToDiffTime 0)
someDate = UTCTime (fromGregorian 2003 06 23) (secondsToDiffTime $ 4*3600)
nullURI, someURI :: URI.URI
nullURI = URI.nullURI
someURI = fromJust $ URI.parseURI
"http://slurl.com/secondlife/Ambleside/57/104/26"
nullBinary, someBinary :: L.ByteString
nullBinary = L.empty
someBinary = L.pack [222, 173, 190, 239]
ls :: String -> LLSD; ls = toLLSD
li :: Int -> LLSD; li = toLLSD
ld :: Double -> LLSD; ld = toLLSD
lu :: String -> LLSD; lu = toLLSD . (fromLLSD :: LLSD -> URI.URI) . toLLSD
notMatch :: LLIDL -> LLSD -> Bool
notMatch i l = not $ match i l :: Bool
testIDLCases :: String -> [LLIDL -> Test] -> Test
testIDLCases itext its = itext ~:
case parseValue itext of
(Left err) -> TestCase $ assertFailure ("parse error: " ++ err)
(Right i) -> TestList $ map ($i) its
should :: (SData a, Show a) => (LLIDL -> LLSD -> Bool) -> a -> LLIDL -> Test
should f a i = show a ~: assertBool "" (f i (toLLSD a))
test_simple :: Test
test_simple = "simple" ~: TestList [
-- This class aggregates all the parse and match tests for simple types
testIDLCases "undef" [
should match undef,
should match True,
should match False,
should match (0 :: Int),
should match (1 :: Int),
should match (3 :: Int),
should match (0.0 :: Double),
should match (1.0 :: Double),
should match (3.14 :: Double),
should match "",
should match "True",
should match "False",
should match someDate,
should match someUUID,
should match someURI,
should match someBinary
],
testIDLCases "bool" [
should hasDefaulted undef,
should match True,
should match False,
should match (0 :: Int),
should match (1 :: Int),
should incompatible (3 :: Int),
should match (0.0 :: Double),
should match (1.0 :: Double),
should incompatible (3.14 :: Double),
should match "",
should match "true",
should incompatible "false",
should incompatible someDate,
should incompatible someUUID,
should incompatible someURI,
should incompatible someBinary
],
testIDLCases "int" [
should hasDefaulted undef,
should match True,
should match False,
should match (0 :: Int),
should match (1 :: Int),
should match (0.0 :: Double),
should match (10.0 :: Double),
should incompatible (3.14 :: Double),
should incompatible (6.02e23 :: Double),
should hasDefaulted "",
should match "0",
should match "1",
should match "0.0",
should match "10.0",
should incompatible "3.14",
should incompatible "6.02e23",
should incompatible "blob",
should incompatible someDate,
should incompatible someUUID,
should incompatible someURI,
should incompatible someBinary
],
testIDLCases "real" [
should hasDefaulted undef,
should match True,
should match False,
should match (0 :: Int),
should match (1 :: Int),
should match (0.0 :: Double),
should match (10.0 :: Double),
should match (3.14 :: Double),
should match (6.02e23 :: Double),
should hasDefaulted "",
should match "0",
should match "1",
should match "0.0",
should match "10.0",
should match "3.14",
should match "6.02e23",
should incompatible "blob",
should incompatible someDate,
should incompatible someUUID,
should incompatible someURI,
should incompatible someBinary
],
testIDLCases "string" [
should hasDefaulted undef,
should match True,
should match False,
should match (3 :: Int),
should match (3.14 :: Double),
should match "",
should match "bob",
should match someDate,
should match someUUID,
should match someURI,
should incompatible someBinary
],
testIDLCases "date" [
should hasDefaulted undef,
should incompatible True,
should incompatible (3 :: Int),
should incompatible (3.14 :: Double),
should hasDefaulted "",
should match "2009-02-06T22:17:38Z",
should match "2009-02-06T22:17:38.0025Z",
should incompatible "bob",
should match someDate,
should incompatible someUUID,
should incompatible someURI,
should incompatible someBinary
],
testIDLCases "uuid" [
should hasDefaulted undef,
should incompatible True,
should incompatible (3 :: Int),
should incompatible (3.14 :: Double),
should hasDefaulted "",
should match "6cb93268-5148-423f-8618-eaa0884f5b6c",
should incompatible "bob",
should incompatible someDate,
should match someUUID,
should incompatible someURI,
should incompatible someBinary
],
testIDLCases "uri" [
should hasDefaulted undef,
should incompatible True,
should incompatible (3 :: Int),
should incompatible (3.14 :: Double),
should hasDefaulted "",
should match "http://example.com/",
should incompatible someDate,
should incompatible someUUID,
should match someURI,
should incompatible someBinary
],
testIDLCases "binary" [
should hasDefaulted undef,
should incompatible True,
should incompatible (3 :: Int),
should incompatible (3.14 :: Double),
should incompatible "bob",
should incompatible someDate,
should incompatible someUUID,
should incompatible someURI,
should match someBinary
]
]
prop_IntMatchesDoubleIfIntegral :: Int -> Bool
prop_IntMatchesDoubleIfIntegral v = either (const False) (\i -> match i l) p
where p = parseValue "int"
l = toLLSD (fromIntegral v :: Double)
props_simple = [
label "prop_IntMatchesDoubleIfIntegral" prop_IntMatchesDoubleIfIntegral
]
test_selector :: Test
test_selector = "selector" ~: TestList [
-- This class aggregates all the test cases for atomic type selectors.
testIDLCases "true" [
should incompatible undef,
should match True,
should incompatible False,
should incompatible (0 :: Int),
should match (1 :: Int),
should incompatible (3 :: Int),
should incompatible (0.0 :: Double),
should match (1.0 :: Double),
should incompatible (3.14 :: Double),
should incompatible "",
should match "true",
should incompatible "false",
should incompatible someDate,
should incompatible someUUID,
should incompatible someURI,
should incompatible someBinary
],
testIDLCases "false" [
should hasDefaulted undef,
should incompatible True,
should match False,
should match (0 :: Int),
should incompatible (1 :: Int),
should incompatible (3 :: Int),
should match (0.0 :: Double),
should incompatible (1.0 :: Double),
should incompatible (3.14 :: Double),
should match "",
should incompatible "true",
should incompatible "false",
should incompatible someDate,
should incompatible someUUID,
should incompatible someURI,
should incompatible someBinary
],
testIDLCases "1983" [
should incompatible undef,
should incompatible True,
should incompatible False,
should incompatible (0 :: Int),
should incompatible (3 :: Int),
should match (1983 :: Int),
should incompatible (0.0 :: Double),
should match (1983.0 :: Double),
should incompatible (1983.2 :: Double),
should incompatible "",
should match "1983",
should incompatible someDate,
should incompatible someUUID,
should incompatible someURI,
should incompatible someBinary
],
testIDLCases "0" [
should hasDefaulted undef,
should incompatible True,
should match False,
should match (0 :: Int),
should incompatible (3 :: Int),
should match (0.0 :: Double),
should incompatible (16.0 :: Double),
should hasDefaulted "",
should match "0",
should incompatible someDate,
should incompatible someUUID,
should incompatible someURI,
should incompatible someBinary
],
testIDLCases "\"secondLife\"" [
should incompatible undef,
should incompatible True,
should incompatible False,
should incompatible (0 :: Int),
should incompatible (3 :: Int),
should incompatible (0.0 :: Double),
should incompatible (16.0 :: Double),
should incompatible "",
should match "secondLife",
should incompatible "1983",
should incompatible someDate,
should incompatible someUUID,
should incompatible someURI,
should incompatible someBinary
]
{-
testIDLCases "\"\"" [
-- currently the draft doesn"t support this test
should match undef,
should incompatible True,
should incompatible False,
should incompatible (0 :: Int),
should incompatible (3 :: Int),
should incompatible (0.0 :: Double),
should incompatible (16.0 :: Double),
should match "",
should incompatible "bob",
should incompatible someDate,
should incompatible someUUID,
should incompatible someURI,
should incompatible someBinary
]
-}
]
test_array :: Test
test_array = "array" ~: TestList [
testIDLCases "[real, real, real]" [
-- simple types
should incompatible (123 :: Int),
should incompatible (3.1415 :: Double),
should incompatible someUUID,
should notMatch ([] :: [Double]),
-- 1 element array
should notMatch [ld 1.23],
-- 2 elements array
should notMatch [ld 1.23, ld 789.0],
-- 4 elements array ( > 3)
should notMatch [ld 1.23, ld 2.3, ld 4.56, ld 5.67],
-- 3 elements with incorrect value type
should incompatible [ld 1.23, ld 3.3, ls "string"],
-- 3 elements with correct value type
should match [ld 1.23, ld 3.3, ld 2.3434]
],
testIDLCases "[int, string]" [
-- simple types
should incompatible (123 :: Int),
should incompatible (3.1415 :: Double),
should incompatible "string",
should incompatible someUUID,
-- empty array
should notMatch ([] :: [LLSD]),
should notMatch [li 123],
should incompatible [ls "str1"],
should notMatch [li 123, ls "str1", ls "str2"],
should incompatible [ls "str1", li 123, li 345],
should match [li 123, ls "str1"],
should match [li 123, ld 1.2323],
should match [li 123, li 456],
should incompatible [ld 9.999, ls "str1"]
],
testIDLCases "[uri,...]" [
-- simple types
should incompatible (123 :: Int),
should incompatible (3.1415 :: Double),
should incompatible "string",
should incompatible someUUID,
-- empty array
should match ([] :: [LLSD]),
-- 1 element array
should match [lu "www.foo.com"],
-- 2 elements array
should match [lu "www.foo.com", lu "www.bar.com"],
-- 3 elements array
should match [lu "www.foo.com", lu "www.bar.com",
lu "www.topcoder.com/tc/review?project_id=30012"],
-- 1 element
should incompatible [li 123],
-- 2 elements
should incompatible [lu "www.google.com", li 123]
],
testIDLCases "[string, int,...]" [
-- simple types
should incompatible (123 :: Int),
should incompatible (3.1415 :: Double),
should incompatible "string",
should incompatible someUUID,
-- empty array
should match ([] :: [LLSD]),
should notMatch [ls "str"],
should notMatch [li 12345],
should notMatch [ls "str", li 123, ls "str2"],
should incompatible [ls "foo", ls "bar"],
should match [ls "foo", li 123],
should match [ls "foo", li 123, ls "bar", li 345]
],
testIDLCases "[int, int]" [
should match [li 123, li 123],
should notMatch [li 123, li 345, li 678],
should hasAdditional [li 123, li 345, li 678],
should valid [li 123, li 123],
should valid [li 123, li 345, li 678]
]
]
test_map :: Test
test_map = "map" ~: TestList [
let a0 = toLLSD ([] :: [String])
m0 = toLLSD (M.empty :: M.Map String LLSD)
m1 = llsd `with` "name" .= "ant"
m2 = m1 `with` "phone" .= (429873232 :: Int)
m3 = m2 `with` "cam" .= True
in testIDLCases "{ name : string, phone: int }" [
should incompatible (123 :: Int),
should incompatible (3.1415 :: Double),
should incompatible "string",
should incompatible someUUID,
should incompatible a0,
should hasDefaulted m0,
should hasDefaulted m1,
should hasDefaulted $ llsd `with` "phone" .= (42312334 :: Int),
should incompatible $ llsd `with` "phone" .= "error",
should match m2,
-- three entries map
should notMatch $ m2 `with` "address" .= "xx",
should hasAdditional m3
],
let a0 = toLLSD ([] :: [String])
m0 = toLLSD (M.empty :: M.Map String LLSD)
m1 = llsd `with` "id1" .= (1234 :: Int)
m2 = m1 `with` "id2" .= (100 :: Int)
m4 = m2 `with` "id3" .= (101 :: Int) `with` "id4" .= (102 :: Int)
in testIDLCases "{ $: int }" [
should incompatible (123 :: Int),
should incompatible (3.1415 :: Double),
should incompatible "string",
should incompatible someUUID,
should incompatible a0,
-- empty map
should match m0,
-- one entry map
should incompatible $ llsd `with` "name" .= "ant",
should match $ m1,
should incompatible $ llsd `with` "phone" .= "error",
-- two entires map
should match $ m2,
should incompatible $ m1 `with` "phone" .= "error",
should hasDefaulted $ llsd `with` "id1" .= undef `with` "id2" .= (100 :: Int),
-- many entires map
should match $ m4
],
let m1 = llsd `with` "name" .= "bob"
m2 = m1 `with` "address" .= "NYC"
in testIDLCases "{name : string}" [
should match m1,
should notMatch m2,
should hasAdditional m2
],
let m1 = llsd `with` "name" .= "bob"
m2 = m1 `with` "address" .= "NYC"
m3 = m2 `with` "phone" .= (123 :: Int)
in testIDLCases "{name : string, phone : int}" [
should valid m1,
should valid m2,
should valid m3
]
]
shouldParseValue :: String -> Test
shouldParseValue itext = itext ~: assertBool ("should've parsed: " ++ e) p
where parse = parseValue itext
e = either id (const "") parse
p = either (const False) (const True) parse
shouldNotParseValue :: String -> Test
shouldNotParseValue itext = itext ~: assertBool "shouldn't've parsed" np
where parse = parseValue itext
np = either (const True) (const False) parse
test_parseValue :: Test
test_parseValue = "parse value" ~: TestList [
shouldParseValue "undef",
shouldParseValue "bool",
shouldParseValue "int",
shouldParseValue "real",
shouldParseValue "string",
shouldParseValue "uuid",
shouldParseValue "date",
shouldParseValue "uri",
shouldParseValue "binary",
shouldNotParseValue "blob",
shouldNotParseValue "Bool",
shouldNotParseValue "BOOL",
shouldNotParseValue "--",
shouldNotParseValue "*",
shouldNotParseValue "_",
shouldParseValue "true",
shouldParseValue "false",
shouldParseValue "0",
shouldParseValue "1",
shouldParseValue "42",
shouldParseValue "1000000",
shouldParseValue "\"red\"",
shouldParseValue "\"blue\"",
shouldParseValue "\"a/b/c_d\"",
shouldNotParseValue "3.14159",
shouldNotParseValue "-10",
shouldNotParseValue "2x2",
shouldNotParseValue "0x3f",
shouldNotParseValue "\"\"",
shouldNotParseValue "\"a-b\"",
shouldNotParseValue "\"3\"",
shouldNotParseValue "\"~boo~\"",
shouldNotParseValue "\"feh",
{-
for w in ["[ real]", "[\treal]", "[ real]", "[\t\treal]"]:
self.good_parse_value(w)
for nl in ["\n", "\r\n", "\r", "\n\n"]:
w = ("[%s\tint,%s\tbool, ;comment and stuff!!%s\tstring%s]"
% (nl, nl, nl, nl,
self.good_parse_value(w)
-}
shouldNotParseValue "",
shouldNotParseValue " ",
shouldParseValue " int",
shouldParseValue "int ",
-- NOTE: Differs from Python implementation.
-- The Haskell implementation allows leading and trailing whitespace
shouldParseValue "[int,bool]",
shouldParseValue "[ int,bool]",
shouldParseValue "[int ,bool]",
shouldParseValue "[int, bool]",
shouldParseValue "[int,bool ]",
shouldParseValue "[int,...]",
shouldParseValue "[ int,...]",
shouldParseValue "[int ,...]",
shouldParseValue "[int, ...]",
shouldParseValue "[int,... ]",
shouldParseValue "[string, int, bool, real...]",
shouldParseValue "[int, date, uuid]",
shouldParseValue "{name1 : string, name2 : real, name3 : date, name4 : uuid}",
shouldParseValue "{$ : int}",
shouldNotParseValue "foo",
shouldNotParseValue "bar",
shouldNotParseValue "[]",
shouldNotParseValue "{}",
shouldNotParseValue "[int, real, date",
shouldNotParseValue "{name : string, phone : int",
shouldNotParseValue "{name:string, name:int}",
shouldNotParseValue "{name:string,phone:}",
shouldNotParseValue "{name:string, :int}",
shouldNotParseValue "{name:string phone,int}",
shouldNotParseValue "[int, real, invalid]",
shouldNotParseValue "{name: string, id:invalid}",
shouldNotParseValue "[...]",
shouldNotParseValue "{alphone-omega:real}",
shouldNotParseValue "{$}",
shouldNotParseValue "{$:}"
]
testSuiteCases :: String -> [Suite -> Test] -> Test
testSuiteCases itext its = (take 20 itext ++ "...") ~:
case parseSuite itext of
(Left err) -> TestCase $ assertFailure ("parse error: " ++ err)
(Right i) -> TestList $ map ($i) its
suiteShould :: (SData a, Show a) =>
(LLIDL -> LLSD -> Bool) ->
(String -> Suite -> LLIDL) -> String ->
a -> Suite -> Test
suiteShould f r t a s =
(t ++ ": " ++ show a) ~: assertBool "" (f (r t s) (toLLSD a))
test_parseSuite :: Test
test_parseSuite = "parse suite" ~: TestList [
testSuiteCases "\
\;test suite\n\
\%% agent/name\n\
\-> { agent_id: uuid }\n\
\<- { first: string, last: string }\n\
\\n\
\%% region/hub\n\
\-> { region_id: uuid }\n\
\<- { loc: [ real, real, real ] }\n\
\\n\
\%% event_record\n\
\-> { log: string, priority: int }\n\
\<- undef\n\
\\n\
\%% motd\n\
\-> undef\n\
\<- { message: string }\n"
[
suiteShould match request "agent/name"
$ llsd `with` "agent_id" .= someUUID,
suiteShould match response "agent/name"
$ llsd `with` "first" .= "Amy"
`with` "last" .= "Ant",
suiteShould match request "region/hub"
$ llsd `with` "region_id" .= (UUID.toString someUUID),
suiteShould match response "region/hub"
$ llsd `with` "loc" .= ([128,128,24]::[Int]),
suiteShould valid request "event_record"
$ llsd `with` "log" .= "Beep-Bepp-Beep",
suiteShould match response "event_record" (12345::Int),
suiteShould match request "motd" "please",
suiteShould valid response "motd"
$ llsd `with` "message" .= "To infinity, and beyond!"
`with` "author" .= ["Buzz", "Lightyear"]
],
let p = ([ 128.0, 128.0, 26.0 ] :: [Double])
in testSuiteCases "\
\;variant suite\n\
\%% object/info\n\
\-> undef\n\
\<- { name: string, pos: [ real, real, real ], geom: &geometry }\n\
\\n\
\&geometry = { type: \"sphere\", radius: real }\n\
\&geometry = { type: \"cube\", side: real }\n\
\&geometry = { type: \"prisim\", faces: int, twist: real }\n"
[
suiteShould match response "object/info"
$ llsd `with` "name" .= "ball"
`with` "pos" .= p
`with` "geom" ./ "type" .= "sphere"
`with` "geom" ./ "radius" .= (2.2::Double),
suiteShould match response "object/info"
$ llsd `with` "name" .= "box"
`with` "pos" .= p
`with` "geom" ./ "type" .= "cube"
`with` "geom" ./ "side" .= (2.2::Double),
suiteShould match response "object/info"
$ llsd `with` "name" .= "lith"
`with` "pos" .= p
`with` "geom" ./ "type" .= "prisim"
`with` "geom" ./ "faces" .= (3::Int)
`with` "geom" ./ "twist" .= (2.2::Double),
suiteShould incompatible response "object/info"
$ llsd `with` "name" .= "blob"
`with` "pos" .= p
`with` "geom" ./ "type" .= "mesh"
`with` "geom" ./ "verticies" .= ([1,2,3,4]::[Int])
],
let iv = 42::Int
sv = "Amy"
idl = [$llidlSuite|
%% api/get
<< int
%% api/getput
<> int
%% api/getputdel
<x> int
|]
in "api/get..." ~: TestList $ map ($idl)
[
suiteShould incompatible request "api/get" iv,
suiteShould incompatible request "api/get" sv,
suiteShould match response "api/get" iv,
suiteShould incompatible response "api/get" sv,
suiteShould match request "api/getput" iv,
suiteShould incompatible request "api/getput" sv,
suiteShould match response "api/getput" iv,
suiteShould incompatible response "api/getput" sv,
suiteShould match request "api/getputdel" iv,
suiteShould incompatible request "api/getputdel" sv,
suiteShould match response "api/getputdel" iv,
suiteShould incompatible response "api/getputdel" sv
]
]
quotedValue :: LLIDL
quotedValue = [$llidlValue|{ name : string, phone: int }|]
quotedSuite :: Suite
quotedSuite = [$llidlSuite|
;test suite
%% agent/name
-> { agent_id: uuid }
<- { first: string, last: string }
%% region/hub
-> { region_id: uuid }
<- { loc: [ real, real, real ] }
%% event_record
-> { log: string, priority: int }
<- undef
%% motd
-> undef
<- { message: string }
|]
test_quote :: Test
test_quote = "quote" ~: TestList [
should incompatible "string" quotedValue,
should match (llsd `with` "name" .= "ant"
`with` "phone" .= (429873232 :: Int)) quotedValue,
suiteShould match response "agent/name"
(llsd `with` "first" .= "Amy" `with` "last" .= "Ant")
quotedSuite,
suiteShould valid request "event_record"
(llsd `with` "log" .= "Beep-Bepp-Beep")
quotedSuite
]
runTests = runTestText (putTextToHandle stderr False) (TestList [
test_simple,
test_selector,
test_array,
test_map,
test_parseValue,
test_parseSuite,
test_quote
])
runChecks = mapM_ quickCheck $ concat [
props_simple
]