{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Main where
import Control.Arrow
import Control.Monad.Writer.Strict
import qualified Data.String as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import GHC.Generics (Generic, Rep)
import Network.URI.Template
import Network.URI.Template.Parser
import Network.URI.Template.TH
import Network.URI.Template.Types
import System.Exit
import Test.HUnit hiding (Label, path, test)
import Web.HttpApiData (toUrlPiece)
type TestRegistry = Writer [Test]
test :: Assertion -> TestRegistry ()
test t = tell [TestCase t]
suite :: TestRegistry () -> TestRegistry ()
suite t = tell [TestList $ execWriter t]
label :: String -> TestRegistry () -> TestRegistry ()
label n = censor (\l -> [TestLabel n $ TestList l])
runTestRegistry :: TestRegistry () -> IO Counts
runTestRegistry = runTestTT . TestList . execWriter
-------------------------------------------------------------------------------
-- Template Haskell Derivation Tests
-------------------------------------------------------------------------------
-- Test basic record type with default options
data Person = Person
{ personName :: Text
, personAge :: Int
}
$(deriveToTemplateValue ''Person)
-- Test record with field label modifier
data User = User
{ userName :: Text
, userEmail :: Text
}
$(deriveToTemplateValueWith defaultOptions { fieldLabelModifier = drop 4 } ''User)
-- Test record with snake_case conversion
data Product = Product
{ productName :: Text
, productPrice :: Int
}
$(deriveToTemplateValueWith defaultOptions { fieldLabelModifier = camelTo2 '_' } ''Product)
-- Test unary record with unwrapUnaryRecords
newtype UserId = UserId { getUserId :: Int }
$(deriveToTemplateValueWith defaultOptions { unwrapUnaryRecords = True } ''UserId)
-- Test nullary constructor
data Status = Active
$(deriveToTemplateValue ''Status)
thDerivationTests :: TestRegistry ()
thDerivationTests = label "Template Haskell Derivation Tests" $
suite $ do
label "Basic record with default options" $ test $ do
let person = Person "Alice" 30
let val = toTemplateValue person
case val of
Associative pairs -> do
length pairs @?= 2
-- Check that we have the right keys
let keys = [toUrlPiece k | (Single k, _) <- pairs]
keys @?= (["personName", "personAge"] :: [Text])
_ -> assertFailure "Expected Associative value"
label "Record with fieldLabelModifier (drop prefix)" $ test $ do
let user = User "Bob" "bob@example.com"
let val = toTemplateValue user
case val of
Associative pairs -> do
let keys = [toUrlPiece k | (Single k, _) <- pairs]
keys @?= (["Name", "Email"] :: [Text])
_ -> assertFailure "Expected Associative value"
label "Record with snake_case conversion" $ test $ do
let product = Product "Widget" 100
let val = toTemplateValue product
case val of
Associative pairs -> do
let keys = [toUrlPiece k | (Single k, _) <- pairs]
keys @?= (["product_name", "product_price"] :: [Text])
_ -> assertFailure "Expected Associative value"
label "Unary record with unwrapUnaryRecords" $ test $ do
let userId = UserId 42
let val = toTemplateValue userId
case val of
Single i -> toUrlPiece i @?= ("42" :: Text)
_ -> assertFailure "Expected Single value"
label "Nullary constructor" $ test $ do
let status = Active
let val = toTemplateValue status
case val of
Single s -> toUrlPiece s @?= ("Active" :: Text)
_ -> assertFailure "Expected Single value"
label "Use derived instance in URI template" $ test $ do
let product = Product "Widget" 100
let rendered = render (UriTemplate $ V.fromList [Embed Query [Variable "product" Explode]]) [("product", WrappedValue $ toTemplateValue product)]
rendered @?= ("?product_name=Widget&product_price=100" :: Text)
-------------------------------------------------------------------------------
-- Generics Derivation Tests
-------------------------------------------------------------------------------
-- Test basic record type with generics and default options
data GenPerson = GenPerson
{ genPersonName :: Text
, genPersonAge :: Int
}
deriving (Generic)
instance ToTemplateValue GenPerson where
type TemplateRep GenPerson = GTemplateRep (Rep GenPerson)
toTemplateValue = gToTemplateValue
-- Test record with custom generic options
data GenProduct = GenProduct
{ genProductName :: Text
, genProductPrice :: Int
}
deriving (Generic)
instance ToTemplateValue GenProduct where
type TemplateRep GenProduct = GTemplateRep (Rep GenProduct)
toTemplateValue = gToTemplateValueWith defaultGenericOptions
{ genericFieldLabelModifier = camelTo2Generic '_'
}
genericsDerivationTests :: TestRegistry ()
genericsDerivationTests = label "Generics Derivation Tests" $
suite $ do
label "Basic record with default generics" $ test $ do
let person = GenPerson "Bob" 25
let val = toTemplateValue person
case val of
Associative pairs -> do
length pairs @?= 2
let keys = [toUrlPiece k | (Single k, _) <- pairs]
keys @?= (["genPersonName", "genPersonAge"] :: [Text])
_ -> assertFailure "Expected Associative value"
label "Record with custom field modifier (snake_case)" $ test $ do
let product = GenProduct "Gadget" 200
let val = toTemplateValue product
case val of
Associative pairs -> do
let keys = [toUrlPiece k | (Single k, _) <- pairs]
keys @?= (["gen_product_name", "gen_product_price"] :: [Text])
_ -> assertFailure "Expected Associative value"
label "Use generic instance in URI template" $ test $ do
let product = GenProduct "Gadget" 200
let rendered = render (UriTemplate $ V.fromList [Embed Query [Variable "product" Explode]]) [("product", WrappedValue $ toTemplateValue product)]
rendered @?= ("?gen_product_name=Gadget&gen_product_price=200" :: Text)
main :: IO ()
main = do
counts <- testRun
let statusCode = errors counts + failures counts
if statusCode > 0
then exitFailure
else exitSuccess
where
strEq = (@?=) :: Text -> Text -> Assertion
testRun = runTestRegistry $ do
parserTests
showInstanceTests
isStringInstanceTests
quasiQuoterTests strEq
quasiQuoterPatternTests
embedTests
thDerivationTests
genericsDerivationTests
percentEncodingTests
label "RFC 6570 Core Examples" $
suite $ do
label "unescaped" $ test $ unescaped strEq
label "fragment" $ test $ fragment strEq
label "label tests" $ test $ labelTests strEq
label "path tests" $ test $ pathTests strEq
label "path params" $ test $ pathParams strEq
label "query params" $ test $ queryParams strEq
label "continued query params" $ test $ continuedQueryParams strEq
label "RFC 6570 Section 3.2 - Comprehensive Tests" $
suite $ do
label "3.2.2 Simple String Expansion" $ test $ simpleExpansionTests strEq
label "3.2.3 Reserved Expansion" $ test $ reservedExpansionTests strEq
label "3.2.4 Fragment Expansion" $ test $ fragmentExpansionTests strEq
label "3.2.5 Label Expansion with Dot-Prefix" $ test $ labelExpansionTests strEq
label "3.2.6 Path Segment Expansion" $ test $ pathSegmentExpansionTests strEq
label "3.2.7 Path-Style Parameter Expansion" $ test $ pathParameterExpansionTests strEq
label "3.2.8 Form-Style Query Expansion" $ test $ queryExpansionTests strEq
label "3.2.9 Form-Style Query Continuation" $ test $ queryContinuationTests strEq
label "Edge Cases and Special Scenarios" $
suite $ do
label "Empty Value Handling" $ test $ emptyValueTests strEq
label "Complex Multi-Variable Combinations" $ test $ complexCombinationTests strEq
label "Special Character Encoding" $ test $ specialCharacterTests strEq
label "Prefix Modifier (Length Constraints)" $ test $ prefixModifierTests strEq
parserTests :: TestRegistry ()
parserTests = label "Parser Tests" $
suite $ do
let foo = Variable "foo" Normal
label "Literal" $ parserTest "foo" $ Literal "foo"
label "Simple" $ parserTest "{foo}" $ Embed Simple [foo]
label "Reserved" $ parserTest "{+foo}" $ Embed Reserved [foo]
label "Fragment" $ parserTest "{#foo}" $ Embed Fragment [foo]
label "Label" $ parserTest "{.foo}" $ Embed Label [foo]
label "Path Segment" $ parserTest "{/foo}" $ Embed PathSegment [foo]
label "Path Parameter" $ parserTest "{;foo}" $ Embed PathParameter [foo]
label "Query" $ parserTest "{?foo}" $ Embed Query [foo]
label "Query Continuation" $ parserTest "{&foo}" $ Embed QueryContinuation [foo]
label "Explode" $ parserTest "{foo*}" $ Embed Simple [Variable "foo" Explode]
label "Max Length" $ parserTest "{foo:1}" $ Embed Simple [Variable "foo" $ MaxLength 1]
label "Multiple Variables" $ parserTest "{foo,bar}" $ Embed Simple [Variable "foo" Normal, Variable "bar" Normal]
parserTest :: String -> TemplateSegment -> TestRegistry ()
parserTest t e = test $ parseTemplate t @?= Right (UriTemplate (V.singleton e))
showInstanceTests :: TestRegistry ()
showInstanceTests = label "Show Instance Tests" $
suite $ do
label "Literal segments" $ test $ do
show (Literal "foo") @?= "foo"
show (Literal "/users/") @?= "/users/"
label "Simple expansion" $ test $
show (Embed Simple [Variable "var" Normal]) @?= "{var}"
label "Reserved expansion" $ test $
show (Embed Reserved [Variable "path" Normal]) @?= "{+path}"
label "Fragment expansion" $ test $
show (Embed Fragment [Variable "section" Normal]) @?= "{#section}"
label "Label expansion" $ test $
show (Embed Label [Variable "domain" Normal]) @?= "{.domain}"
label "Path segment expansion" $ test $
show (Embed PathSegment [Variable "segments" Normal]) @?= "{/segments}"
label "Path parameter expansion" $ test $
show (Embed PathParameter [Variable "params" Normal]) @?= "{;params}"
label "Query expansion" $ test $
show (Embed Query [Variable "filter" Normal]) @?= "{?filter}"
label "Query continuation expansion" $ test $
show (Embed QueryContinuation [Variable "page" Normal]) @?= "{&page}"
label "Explode modifier" $ test $
show (Embed Simple [Variable "list" Explode]) @?= "{list*}"
label "MaxLength modifier" $ test $ do
show (Embed Simple [Variable "var" (MaxLength 3)]) @?= "{var:3}"
show (Embed Simple [Variable "var" (MaxLength 10)]) @?= "{var:10}"
label "Multiple variables" $ test $
show (Embed Simple [Variable "x" Normal, Variable "y" Normal]) @?= "{x,y}"
label "Multiple variables with modifiers" $ test $ do
show (Embed Simple [Variable "x" (MaxLength 5), Variable "y" Explode]) @?= "{x:5,y*}"
show (Embed Query [Variable "filter" Explode, Variable "sort" Normal]) @?= "{?filter*,sort}"
label "renderTemplate full templates" $ test $ do
let template1 = UriTemplate (V.fromList [Literal "/users/", Embed Simple [Variable "userId" Normal]])
renderTemplate template1 @?= "/users/{userId}"
let template2 = UriTemplate (V.fromList [Literal "/api", Embed Query [Variable "page" Normal], Embed QueryContinuation [Variable "limit" Normal]])
renderTemplate template2 @?= "/api{?page}{&limit}"
let template3 = UriTemplate (V.fromList [Embed PathSegment [Variable "path" Explode], Literal "/file.txt"])
renderTemplate template3 @?= "{/path*}/file.txt"
label "Round-trip: parse then show" $ test $ do
let testRoundTrip input = do
case parseTemplate input of
Right template -> renderTemplate template @?= input
Left err -> assertFailure $ "Parse failed: " ++ show err
testRoundTrip "{var}"
testRoundTrip "{+path}"
testRoundTrip "{#section}"
testRoundTrip "{.domain}"
testRoundTrip "{/segments*}"
testRoundTrip "{;params}"
testRoundTrip "{?query*}"
testRoundTrip "{&continuation}"
testRoundTrip "/users/{userId}/posts{?status,limit}"
testRoundTrip "http://example.com{/path*}{?query*}"
isStringInstanceTests :: TestRegistry ()
isStringInstanceTests = label "IsString Instance Tests" $
suite $ do
label "Simple template literal" $ test $ do
let template = S.fromString "/users/{userId}" :: UriTemplate
renderTemplate template @?= "/users/{userId}"
label "Template with query params" $ test $ do
let template = S.fromString "/api{?page,limit}" :: UriTemplate
renderTemplate template @?= "/api{?page,limit}"
label "Complex template" $ test $ do
let template = S.fromString "http://example.com{/path*}{?query*}{#fragment}" :: UriTemplate
renderTemplate template @?= "http://example.com{/path*}{?query*}{#fragment}"
label "Template with all modifier types" $ test $ do
let template = S.fromString "{var}{+reserved}{#fragment}{.label}{/path}{;params}{?query}{&cont}" :: UriTemplate
renderTemplate template @?= "{var}{+reserved}{#fragment}{.label}{/path}{;params}{?query}{&cont}"
label "Template with value modifiers" $ test $ do
let template = S.fromString "{var:3}{list*}{name:10}" :: UriTemplate
renderTemplate template @?= "{var:3}{list*}{name:10}"
label "Plain literal without variables" $ test $ do
let template = S.fromString "/static/path" :: UriTemplate
renderTemplate template @?= "/static/path"
label "Empty template" $ test $ do
let template = S.fromString "" :: UriTemplate
renderTemplate template @?= ""
label "Template can be used with render" $ test $ do
let template = S.fromString "/users/{userId}" :: UriTemplate
let rendered = render template [("userId", WrappedValue $ Single (123 :: Int))] :: String
rendered @?= "/users/123"
embedTests = label "Embed Tests" $
suite $ do
label "Literal" $ embedTest "foo" "foo"
label "Simple" $ embedTest "{foo}" "bar"
label "Reserved" $ embedTest "{+foo}" "bar"
label "Fragment" $ embedTest "{#foo}" "#bar"
label "Label" $ embedTest "{.foo}" ".bar"
label "Path Segment" $ embedTest "{/foo}" "/bar"
label "Path Parameter" $ embedTest "{;foo}" ";foo=bar"
label "Query" $ embedTest "{?foo}" "?foo=bar"
label "Query Continuation" $ embedTest "{&foo}" "&foo=bar"
label "Explode" $ embedTest "{foo*}" "bar"
label "Max Length" $ embedTest "{foo:1}" "b"
embedTestEnv = [("foo", WrappedValue $ Single ("bar" :: Text))]
embedTest :: String -> String -> TestRegistry ()
embedTest t expect = test $ do
let (Right tpl) = parseTemplate t
let rendered = render tpl embedTestEnv
rendered @?= expect
var :: TemplateString
var = "value"
semi :: TemplateString
semi = ";"
hello :: TemplateString
hello = "Hello World!"
path :: TemplateString
path = "/foo/bar"
list :: [TemplateString]
list = ["red", "green", "blue"]
keys :: AList TemplateString TemplateString
keys = AList [("semi", ";"), ("dot", "."), ("comma", ",")]
-- Additional RFC 6570 variables for comprehensive testing
x :: TemplateString
x = "1024"
y :: TemplateString
y = "768"
emptyStr :: TemplateString
emptyStr = ""
emptyList :: [TemplateString]
emptyList = []
emptyKeys :: AList TemplateString TemplateString
emptyKeys = AList []
who :: TemplateString
who = "fred"
base :: TemplateString
base = "http://example.com/home/"
v :: TemplateString
v = "6"
half :: TemplateString
half = "50%"
dub :: TemplateString
dub = "me/too"
count :: [TemplateString]
count = ["one", "two", "three"]
dom :: [TemplateString]
dom = ["example", "com"]
quasiQuoterTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> TestRegistry ()
quasiQuoterTests (@?=) = label "QuasiQuoter Tests" $
suite $ do
label "Simple" $ test ([uri|{var}|] @?= "value")
label "Simple with sufficient length" $ test ([uri|{var:20}|] @?= "value")
label "Simple with insufficient length" $ test ([uri|{var:3}|] @?= "val")
label "Escape" $ test ([uri|{semi}|] @?= "%3B")
label "Escape" $ test ([uri|{semi:2}|] @?= "%3B")
label "Multiple" $ test ([uri|{var,hello}|] @?= "value,Hello%20World%21")
label "Length Constraint" $ test ([uri|{var:3}|] @?= "val")
label "Sufficiently large length constraint" $ test ([uri|{var:10}|] @?= "value")
label "List" $ test ([uri|{list}|] @?= "red,green,blue")
label "Explode List" $ test ([uri|{list*}|] @?= "red,green,blue")
label "Associative List" $ test ([uri|{keys}|] @?= "semi,%3B,dot,.,comma,%2C")
label "Explode Associative List" $ test ([uri|{keys*}|] @?= "semi=%3B,dot=.,comma=%2C")
label "Explode Associative List Query Params" $ test ([uri|{?keys*}|] @?= "?semi=%3B&dot=.&comma=%2C")
unescaped :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
unescaped (@?=) = do
[uri|{+path:6}/here|] @?= "/foo/b/here"
[uri|{+list}|] @?= "red,green,blue"
[uri|{+list*}|] @?= "red,green,blue"
[uri|{+keys}|] @?= "semi,;,dot,.,comma,,"
[uri|{+keys*}|] @?= "semi=;,dot=.,comma=,"
fragment :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
fragment (@?=) = do
[uri|{#path:6}/here|] @?= "#/foo/b/here"
[uri|{#list}|] @?= "#red,green,blue"
[uri|{#list*}|] @?= "#red,green,blue"
[uri|{#keys}|] @?= "#semi,;,dot,.,comma,,"
[uri|{#keys*}|] @?= "#semi=;,dot=.,comma=,"
labelTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
labelTests (@?=) = do
[uri|X{.var:3}|] @?= "X.val"
[uri|X{.list}|] @?= "X.red,green,blue"
[uri|X{.list*}|] @?= "X.red.green.blue"
[uri|X{.keys}|] @?= "X.semi,%3B,dot,.,comma,%2C"
[uri|X{.keys*}|] @?= "X.semi=%3B.dot=..comma=%2C"
pathTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
pathTests (@?=) = do
[uri|{/var:1,var}|] @?= "/v/value"
[uri|{/list}|] @?= "/red,green,blue"
[uri|{/list*}|] @?= "/red/green/blue"
[uri|{/list*,path:4}|] @?= "/red/green/blue/%2Ffoo"
[uri|{/keys}|] @?= "/semi,%3B,dot,.,comma,%2C"
[uri|{/keys*}|] @?= "/semi=%3B/dot=./comma=%2C"
pathParams :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
pathParams (@?=) = do
[uri|{;hello:5}|] @?= ";hello=Hello"
[uri|{;list}|] @?= ";list=red,green,blue"
[uri|{;list*}|] @?= ";list=red;list=green;list=blue"
[uri|{;keys}|] @?= ";keys=semi,%3B,dot,.,comma,%2C"
[uri|{;keys*}|] @?= ";semi=%3B;dot=.;comma=%2C"
queryParams :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
queryParams (@?=) = do
[uri|{?var:3}|] @?= "?var=val"
[uri|{?list}|] @?= "?list=red,green,blue"
[uri|{?list*}|] @?= "?list=red&list=green&list=blue"
[uri|{?keys}|] @?= "?keys=semi,%3B,dot,.,comma,%2C"
[uri|{?keys*}|] @?= "?semi=%3B&dot=.&comma=%2C"
continuedQueryParams :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
continuedQueryParams (@?=) = do
[uri|{&var:3}|] @?= "&var=val"
[uri|{&list}|] @?= "&list=red,green,blue"
[uri|{&list*}|] @?= "&list=red&list=green&list=blue"
[uri|{&keys}|] @?= "&keys=semi,%3B,dot,.,comma,%2C"
[uri|{&keys*}|] @?= "&semi=%3B&dot=.&comma=%2C"
-- Edge case tests for empty values
emptyValueTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
emptyValueTests (@?=) = do
-- Empty string variable
[uri|{emptyStr}|] @?= ""
[uri|{?emptyStr}|] @?= "?emptyStr="
[uri|{&emptyStr}|] @?= "&emptyStr="
[uri|{/emptyStr}|] @?= "/"
[uri|{;emptyStr}|] @?= ";emptyStr"
[uri|{.emptyStr}|] @?= "."
[uri|{#emptyStr}|] @?= "#"
[uri|{+emptyStr}|] @?= ""
-- Empty list
[uri|{emptyList}|] @?= ""
[uri|{emptyList*}|] @?= ""
[uri|{?emptyList}|] @?= "?emptyList="
[uri|{?emptyList*}|] @?= "?"
[uri|{&emptyList}|] @?= "&emptyList="
[uri|{&emptyList*}|] @?= "&"
[uri|{/emptyList}|] @?= "/"
[uri|{/emptyList*}|] @?= "/"
-- Empty associative array
[uri|{emptyKeys}|] @?= ""
[uri|{emptyKeys*}|] @?= ""
[uri|{?emptyKeys}|] @?= "?emptyKeys="
[uri|{?emptyKeys*}|] @?= "?"
[uri|{&emptyKeys}|] @?= "&emptyKeys="
[uri|{&emptyKeys*}|] @?= "&"
[uri|{;emptyKeys}|] @?= ";emptyKeys"
[uri|{;emptyKeys*}|] @?= ";"
[uri|{.emptyKeys}|] @?= "."
[uri|{.emptyKeys*}|] @?= "."
[uri|{/emptyKeys}|] @?= "/"
[uri|{/emptyKeys*}|] @?= "/"
-- RFC 6570 Section 3.2.2 - Simple String Expansion
simpleExpansionTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
simpleExpansionTests (@?=) = do
[uri|{var}|] @?= "value"
[uri|{hello}|] @?= "Hello%20World%21"
[uri|{half}|] @?= "50%25"
[uri|O{emptyStr}X|] @?= "OX"
[uri|{x,y}|] @?= "1024,768"
[uri|{x,hello,y}|] @?= "1024,Hello%20World%21,768"
[uri|?{x,emptyStr}|] @?= "?1024,"
[uri|?{x,emptyStr,y}|] @?= "?1024,,768"
[uri|{var:3}|] @?= "val"
[uri|{var:30}|] @?= "value"
[uri|{list}|] @?= "red,green,blue"
[uri|{list*}|] @?= "red,green,blue"
[uri|{keys}|] @?= "semi,%3B,dot,.,comma,%2C"
[uri|{keys*}|] @?= "semi=%3B,dot=.,comma=%2C"
-- RFC 6570 Section 3.2.3 - Reserved Expansion
reservedExpansionTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
reservedExpansionTests (@?=) = do
[uri|{+var}|] @?= "value"
[uri|{+hello}|] @?= "Hello World!"
[uri|{+half}|] @?= "50%"
[uri|{base}index|] @?= "http%3A%2F%2Fexample.com%2Fhome%2Findex"
[uri|{+base}index|] @?= "http://example.com/home/index"
[uri|O{+emptyStr}X|] @?= "OX"
[uri|{+path}/here|] @?= "/foo/bar/here"
[uri|here?ref={+path}|] @?= "here?ref=/foo/bar"
[uri|up{+path}{var}/here|] @?= "up/foo/barvalue/here"
[uri|{+x,hello,y}|] @?= "1024,Hello World!,768"
[uri|{+path,x}/here|] @?= "/foo/bar,1024/here"
[uri|{+path:6}/here|] @?= "/foo/b/here"
[uri|{+list}|] @?= "red,green,blue"
[uri|{+list*}|] @?= "red,green,blue"
[uri|{+keys}|] @?= "semi,;,dot,.,comma,,"
[uri|{+keys*}|] @?= "semi=;,dot=.,comma=,"
-- RFC 6570 Section 3.2.4 - Fragment Expansion
fragmentExpansionTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
fragmentExpansionTests (@?=) = do
[uri|{#var}|] @?= "#value"
[uri|{#hello}|] @?= "#Hello World!"
[uri|{#half}|] @?= "#50%"
[uri|foo{#emptyStr}|] @?= "foo#"
[uri|foo{#emptyStr,x}|] @?= "foo#,1024"
[uri|{#x,hello,y}|] @?= "#1024,Hello World!,768"
[uri|{#path,x}/here|] @?= "#/foo/bar,1024/here"
[uri|{#path:6}/here|] @?= "#/foo/b/here"
[uri|{#list}|] @?= "#red,green,blue"
[uri|{#list*}|] @?= "#red,green,blue"
[uri|{#keys}|] @?= "#semi,;,dot,.,comma,,"
[uri|{#keys*}|] @?= "#semi=;,dot=.,comma=,"
-- RFC 6570 Section 3.2.5 - Label Expansion with Dot-Prefix
labelExpansionTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
labelExpansionTests (@?=) = do
[uri|{.who}|] @?= ".fred"
[uri|{.who,who}|] @?= ".fred.fred"
[uri|{.half,who}|] @?= ".50%25.fred"
[uri|www{.dom*}|] @?= "www.example.com"
[uri|X{.var}|] @?= "X.value"
[uri|X{.emptyStr}|] @?= "X."
[uri|X{.x,y}|] @?= "X.1024.768"
[uri|{.var:3}|] @?= ".val"
[uri|{.list}|] @?= ".red,green,blue"
[uri|{.list*}|] @?= ".red.green.blue"
[uri|{.keys}|] @?= ".semi,%3B,dot,.,comma,%2C"
[uri|{.keys*}|] @?= ".semi=%3B.dot=..comma=%2C"
-- RFC 6570 Section 3.2.6 - Path Segment Expansion
pathSegmentExpansionTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
pathSegmentExpansionTests (@?=) = do
[uri|{/who}|] @?= "/fred"
[uri|{/who,who}|] @?= "/fred/fred"
[uri|{/half,who}|] @?= "/50%25/fred"
[uri|{/who,dub}|] @?= "/fred/me%2Ftoo"
[uri|{/var}|] @?= "/value"
[uri|{/var,emptyStr}|] @?= "/value/"
[uri|{/var,x}/here|] @?= "/value/1024/here"
[uri|{/var:1,var}|] @?= "/v/value"
[uri|{/list}|] @?= "/red,green,blue"
[uri|{/list*}|] @?= "/red/green/blue"
[uri|{/list*,path:4}|] @?= "/red/green/blue/%2Ffoo"
[uri|{/keys}|] @?= "/semi,%3B,dot,.,comma,%2C"
[uri|{/keys*}|] @?= "/semi=%3B/dot=./comma=%2C"
-- RFC 6570 Section 3.2.7 - Path-Style Parameter Expansion
pathParameterExpansionTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
pathParameterExpansionTests (@?=) = do
[uri|{;who}|] @?= ";who=fred"
[uri|{;half}|] @?= ";half=50%25"
[uri|{;emptyStr}|] @?= ";emptyStr"
[uri|{;v,emptyStr,who}|] @?= ";v=6;emptyStr;who=fred"
[uri|{;x,y}|] @?= ";x=1024;y=768"
[uri|{;x,y,emptyStr}|] @?= ";x=1024;y=768;emptyStr"
[uri|{;hello:5}|] @?= ";hello=Hello"
[uri|{;list}|] @?= ";list=red,green,blue"
[uri|{;list*}|] @?= ";list=red;list=green;list=blue"
[uri|{;keys}|] @?= ";keys=semi,%3B,dot,.,comma,%2C"
[uri|{;keys*}|] @?= ";semi=%3B;dot=.;comma=%2C"
-- RFC 6570 Section 3.2.8 - Form-Style Query Expansion
queryExpansionTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
queryExpansionTests (@?=) = do
[uri|{?who}|] @?= "?who=fred"
[uri|{?half}|] @?= "?half=50%25"
[uri|{?x,y}|] @?= "?x=1024&y=768"
[uri|{?x,y,emptyStr}|] @?= "?x=1024&y=768&emptyStr="
[uri|{?var:3}|] @?= "?var=val"
[uri|{?list}|] @?= "?list=red,green,blue"
[uri|{?list*}|] @?= "?list=red&list=green&list=blue"
[uri|{?keys}|] @?= "?keys=semi,%3B,dot,.,comma,%2C"
[uri|{?keys*}|] @?= "?semi=%3B&dot=.&comma=%2C"
-- RFC 6570 Section 3.2.9 - Form-Style Query Continuation
queryContinuationTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
queryContinuationTests (@?=) = do
[uri|{&who}|] @?= "&who=fred"
[uri|{&half}|] @?= "&half=50%25"
[uri|?fixed=yes{&x}|] @?= "?fixed=yes&x=1024"
[uri|{&x,y,emptyStr}|] @?= "&x=1024&y=768&emptyStr="
[uri|{&var:3}|] @?= "&var=val"
[uri|{&list}|] @?= "&list=red,green,blue"
[uri|{&list*}|] @?= "&list=red&list=green&list=blue"
[uri|{&keys}|] @?= "&keys=semi,%3B,dot,.,comma,%2C"
[uri|{&keys*}|] @?= "&semi=%3B&dot=.&comma=%2C"
-- Complex combinations and edge cases
complexCombinationTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
complexCombinationTests (@?=) = do
-- Multiple expansions in one template
[uri|{var}{hello}|] @?= "valueHello%20World%21"
[uri|{+base}{var}|] @?= "http://example.com/home/value"
[uri|map?{x,y}&{who}|] @?= "map?1024,768&fred"
[uri|{x,y,list}|] @?= "1024,768,red,green,blue"
[uri|{x,y,list*}|] @?= "1024,768,red,green,blue"
[uri|{?x,y,list}|] @?= "?x=1024&y=768&list=red,green,blue"
[uri|{?x,y,list*}|] @?= "?x=1024&y=768&list=red&list=green&list=blue"
-- Literals mixed with expansions
[uri|/path/{var}/to/{who}|] @?= "/path/value/to/fred"
[uri|{/var}{?x,y}|] @?= "/value?x=1024&y=768"
[uri|{/var,x}{?y,who}|] @?= "/value/1024?y=768&who=fred"
-- Special character encoding tests
specialCharacterTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
specialCharacterTests (@?=) = do
-- Special characters that need encoding in simple expansion
[uri|{hello}|] @?= "Hello%20World%21"
[uri|{half}|] @?= "50%25"
[uri|{semi}|] @?= "%3B"
[uri|{dub}|] @?= "me%2Ftoo"
-- Same characters should be less encoded in reserved expansion
[uri|{+hello}|] @?= "Hello World!"
[uri|{+half}|] @?= "50%"
[uri|{+dub}|] @?= "me/too"
-- Prefix modifier tests (length constraints)
prefixModifierTests :: (Eq s, S.IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion
prefixModifierTests (@?=) = do
-- Simple expansion
[uri|{var:1}|] @?= "v"
[uri|{var:3}|] @?= "val"
[uri|{var:5}|] @?= "value"
[uri|{var:10}|] @?= "value"
[uri|{hello:5}|] @?= "Hello"
[uri|{hello:15}|] @?= "Hello%20World%21"
-- With different operators
[uri|{+path:4}|] @?= "/foo"
[uri|{+path:6}|] @?= "/foo/b"
[uri|{#path:6}|] @?= "#/foo/b"
[uri|{.var:3}|] @?= ".val"
[uri|{/var:1,var}|] @?= "/v/value"
[uri|{;hello:5}|] @?= ";hello=Hello"
[uri|{?var:3}|] @?= "?var=val"
[uri|{&var:3}|] @?= "&var=val"
-- Test quasiquoter pattern matching
quasiQuoterPatternTests :: TestRegistry ()
quasiQuoterPatternTests = label "QuasiQuoter Pattern Tests" $
suite $ do
label "Simple literal pattern match" $ test $ do
let tpl = parseTemplate "/static/path"
case tpl of
Right [uri|/static/path|] -> return ()
_ -> assertFailure "Pattern should match /static/path"
label "Simple variable pattern match and binding" $ test $ do
let tpl = parseTemplate "{userId}"
case tpl of
Right [uri|{userId}|] -> do
-- userId is now bound to "userId" :: Text
userId @?= "userId"
_ -> assertFailure "Pattern should match {userId}"
label "Complex pattern match with multiple bindings" $ test $ do
let tpl = parseTemplate "/users/{userId}/posts/{postId}"
case tpl of
Right [uri|/users/{userId}/posts/{postId}|] -> do
-- Both variables are bound
userId @?= "userId"
postId @?= "postId"
_ -> assertFailure "Pattern should match complex template"
label "Pattern with modifiers binds variables" $ test $ do
let tpl = parseTemplate "{+path}{?query*}{#fragment}"
case tpl of
Right [uri|{+path}{?query*}{#fragment}|] -> do
path @?= "path"
query @?= "query"
fragment @?= "fragment"
_ -> assertFailure "Pattern should match template with modifiers"
label "Pattern with max length binds variable" $ test $ do
let tpl = parseTemplate "{var:3}"
case tpl of
Right [uri|{var:3}|] -> do
var @?= "var"
_ -> assertFailure "Pattern should match template with max length"
label "Pattern should not match different template" $ test $ do
let tpl = parseTemplate "/users/{userId}"
case tpl of
Right [uri|/posts/{postId}|] -> assertFailure "Pattern should not match different template"
Right _ -> return ()
Left _ -> assertFailure "Parse should succeed"
label "Multiple variables with same modifier" $ test $ do
let tpl = parseTemplate "{x,y,z}"
case tpl of
Right [uri|{x,y,z}|] -> do
x @?= "x"
y @?= "y"
z @?= "z"
_ -> assertFailure "Should match and bind all three variables"
label "Binding with mixed literal and variable segments" $ test $ do
let tpl = parseTemplate "/api/v1/users/{userId}/posts/{postId}/comments"
case tpl of
Right [uri|/api/v1/users/{userId}/posts/{postId}/comments|] -> do
userId @?= "userId"
postId @?= "postId"
_ -> assertFailure "Should match complex template with mixed segments"
label "Binding variables with all modifier types" $ test $ do
let tpl = parseTemplate "{simple}{+reserved}{#fragment}{.label}{/path}{;param}{?query}{&cont}"
case tpl of
Right [uri|{simple}{+reserved}{#fragment}{.label}{/path}{;param}{?query}{&cont}|] -> do
simple @?= "simple"
reserved @?= "reserved"
fragment @?= "fragment"
label @?= "label"
path @?= "path"
param @?= "param"
query @?= "query"
cont @?= "cont"
_ -> assertFailure "Should bind variables with all modifier types"
label "Binding with explode modifier on different operators" $ test $ do
let tpl = parseTemplate "{list1*}{+list2*}{#list3*}{.list4*}{/list5*}{;list6*}{?list7*}{&list8*}"
case tpl of
Right [uri|{list1*}{+list2*}{#list3*}{.list4*}{/list5*}{;list6*}{?list7*}{&list8*}|] -> do
list1 @?= "list1"
list2 @?= "list2"
list3 @?= "list3"
list4 @?= "list4"
list5 @?= "list5"
list6 @?= "list6"
list7 @?= "list7"
list8 @?= "list8"
_ -> assertFailure "Should bind exploded variables"
label "Binding with length constraints" $ test $ do
let tpl = parseTemplate "{short:3}{medium:10}{long:100}"
case tpl of
Right [uri|{short:3}{medium:10}{long:100}|] -> do
short @?= "short"
medium @?= "medium"
long @?= "long"
_ -> assertFailure "Should bind variables with length constraints"
label "Multiple variables in single expression with different modifiers" $ test $ do
let tpl = parseTemplate "{a,b:5,c*}"
case tpl of
Right [uri|{a,b:5,c*}|] -> do
a @?= "a"
b @?= "b"
c @?= "c"
_ -> assertFailure "Should bind all variables despite different modifiers"
label "Binding preserves variable name exactly" $ test $ do
let tpl = parseTemplate "{userId123}{user_id}{camelCase}"
case tpl of
Right [uri|{userId123}{user_id}{camelCase}|] -> do
userId123 @?= "userId123"
user_id @?= "user_id"
camelCase @?= "camelCase"
_ -> assertFailure "Should preserve exact variable names"
label "Pattern with only literals (no variables)" $ test $ do
let tpl = parseTemplate "/static/path/to/resource"
case tpl of
Right [uri|/static/path/to/resource|] -> return ()
_ -> assertFailure "Should match literal-only template"
label "Empty template pattern" $ test $ do
let tpl = parseTemplate ""
case tpl of
Right [uri||] -> return ()
_ -> assertFailure "Should match empty template"
label "Pattern with repeated variable names causes conflict (documented limitation)" $ test $ do
-- Note: This test documents that repeated variable names in a single pattern
-- will cause a compile error due to conflicting definitions. This is expected
-- Haskell behavior for pattern matching.
let tpl = parseTemplate "{id1}/{id2}"
case tpl of
Right [uri|{id1}/{id2}|] -> do
id1 @?= "id1"
id2 @?= "id2"
_ -> assertFailure "Should bind unique variable names"
label "Complex real-world API pattern" $ test $ do
let tpl = parseTemplate "/api/v2/organizations/{orgId}/projects/{projectId}/issues{?status,assignee,page,limit}"
case tpl of
Right [uri|/api/v2/organizations/{orgId}/projects/{projectId}/issues{?status,assignee,page,limit}|] -> do
orgId @?= "orgId"
projectId @?= "projectId"
status @?= "status"
assignee @?= "assignee"
page @?= "page"
limit @?= "limit"
_ -> assertFailure "Should handle complex real-world template"
label "Pattern match failure doesn't bind variables" $ test $ do
let tpl = parseTemplate "/users/{userId}"
let result = case tpl of
Right [uri|/posts/{postId}|] -> Just "matched"
Right _ -> Nothing
Left _ -> Nothing
result @?= Nothing
label "Nested pattern matching" $ test $ do
let tpl1 = parseTemplate "/users/{userId}"
let tpl2 = parseTemplate "/posts/{postId}"
case (tpl1, tpl2) of
(Right [uri|/users/{userId}|], Right [uri|/posts/{postId}|]) -> do
userId @?= "userId"
postId @?= "postId"
_ -> assertFailure "Should handle nested pattern matches"
label "Pattern with percent-encoded literals" $ test $ do
let tpl = parseTemplate "/path%20with%20spaces/{var}"
case tpl of
Right [uri|/path%20with%20spaces/{var}|] -> do
var @?= "var"
_ -> assertFailure "Should handle percent-encoded literals"
label "Variable bindings are type Text" $ test $ do
let tpl = parseTemplate "{userId}"
case tpl of
Right [uri|{userId}|] -> do
-- Verify it's Text by using Text operations
let _ = T.length userId
let _ = T.toUpper userId
userId @?= "userId"
_ -> assertFailure "Variables should be Text type"
label "Multiple query parameters with continuation" $ test $ do
let tpl = parseTemplate "/search{?q,kind,sort}{&page,limit}"
case tpl of
Right [uri|/search{?q,kind,sort}{&page,limit}|] -> do
q @?= "q"
kind @?= "kind" -- Changed from 'type' which is a keyword
sort @?= "sort"
page @?= "page"
limit @?= "limit"
_ -> assertFailure "Should handle query parameters with continuation"
label "Guards can use bound variables" $ test $ do
let tpl = parseTemplate "/api/{version}/users"
let result = case tpl of
Right [uri|/api/{version}/users|] | version == "version" -> True
_ -> False
result @?= True
label "Pattern matching in function arguments" $ test $ do
let checkTemplate [uri|/users/{userId}|] = userId
checkTemplate _ = "no match"
case parseTemplate "/users/{userId}" of
Right tpl -> checkTemplate tpl @?= "userId"
Left _ -> assertFailure "Parse should succeed"
percentEncodingTests :: TestRegistry ()
percentEncodingTests = label "Percent Encoding Tests" $ suite $ do
-- Tests for percent-encoded sequences in literal parts of templates
label "Percent-encoded space in literal" $ test $ do
case parseTemplate "/path%20with%20spaces" of
Right tpl -> renderTemplate tpl @?= "/path%20with%20spaces"
Left _ -> assertFailure "Should parse percent-encoded spaces"
label "Percent-encoded special chars in literal" $ test $ do
case parseTemplate "/api%2Fv1%2Fresource" of
Right tpl -> renderTemplate tpl @?= "/api%2Fv1%2Fresource"
Left _ -> assertFailure "Should parse percent-encoded slashes"
label "Mixed literal and percent-encoded in literal" $ test $ do
case parseTemplate "/hello%20world/test" of
Right tpl -> renderTemplate tpl @?= "/hello%20world/test"
Left _ -> assertFailure "Should parse mixed content"
label "Percent-encoded literal with variable" $ test $ do
case parseTemplate "/path%20with%20spaces/{var}" of
Right tpl -> do
renderTemplate tpl @?= "/path%20with%20spaces/{var}"
let result = render tpl [("var", WrappedValue $ Single ("test" :: T.Text))]
result @?= ("/path%20with%20spaces/test" :: T.Text)
Left _ -> assertFailure "Should parse percent-encoded literal with variable"
label "Multiple percent-encoded sequences in literal" $ test $ do
case parseTemplate "/a%20b%20c%20d" of
Right tpl -> renderTemplate tpl @?= "/a%20b%20c%20d"
Left _ -> assertFailure "Should parse multiple percent-encoded sequences"
-- Tests for percent-encoded sequences in variable names
label "Percent-encoded char in variable name" $ test $ do
case parseTemplate "{user%5Fid}" of
Right tpl -> do
renderTemplate tpl @?= "{user%5Fid}"
let result = render tpl [("user%5Fid", WrappedValue $ Single ("123" :: T.Text))]
result @?= ("123" :: T.Text)
Left _ -> assertFailure "Should parse percent-encoded underscore in variable name"
label "Variable with percent-encoded name in query" $ test $ do
case parseTemplate "{?user%5Fname}" of
Right tpl -> do
let result = render tpl [("user%5Fname", WrappedValue $ Single ("alice" :: T.Text))]
result @?= ("?user%5Fname=alice" :: T.Text)
Left _ -> assertFailure "Should parse percent-encoded variable name in query"
-- Tests for rendering with values that need encoding
label "Render space in simple expansion" $ test $ do
case parseTemplate "{value}" of
Right tpl -> do
let result = render tpl [("value", WrappedValue $ Single ("hello world" :: T.Text))]
result @?= ("hello%20world" :: T.Text)
Left _ -> assertFailure "Should parse simple template"
label "Render special chars in simple expansion" $ test $ do
case parseTemplate "{value}" of
Right tpl -> do
let result = render tpl [("value", WrappedValue $ Single ("a/b?c=d" :: T.Text))]
result @?= ("a%2Fb%3Fc%3Dd" :: T.Text)
Left _ -> assertFailure "Should parse simple template"
label "Render reserved expansion does not encode" $ test $ do
case parseTemplate "{+value}" of
Right tpl -> do
let result = render tpl [("value", WrappedValue $ Single ("hello world" :: T.Text))]
result @?= ("hello world" :: T.Text)
Left _ -> assertFailure "Should parse reserved template"
label "Render path with encoding" $ test $ do
case parseTemplate "{/path}" of
Right tpl -> do
let result = render tpl [("path", WrappedValue $ Single ("hello world" :: T.Text))]
result @?= ("/hello%20world" :: T.Text)
Left _ -> assertFailure "Should parse path template"
label "Percent in value gets encoded" $ test $ do
case parseTemplate "{value}" of
Right tpl -> do
let result = render tpl [("value", WrappedValue $ Single ("100%" :: T.Text))]
result @?= ("100%25" :: T.Text)
Left _ -> assertFailure "Should parse simple template"
label "Already percent-encoded value gets double-encoded" $ test $ do
case parseTemplate "{value}" of
Right tpl -> do
let result = render tpl [("value", WrappedValue $ Single ("hello%20world" :: T.Text))]
-- The %20 in the value should be encoded to %2520
result @?= ("hello%2520world" :: T.Text)
Left _ -> assertFailure "Should parse simple template"
-- Edge cases
label "Percent at end of literal" $ test $ do
case parseTemplate "/path%20" of
Right tpl -> renderTemplate tpl @?= "/path%20"
Left _ -> assertFailure "Should parse percent-encoded sequence at end"
label "Multiple variables with percent-encoded names" $ test $ do
case parseTemplate "{user%5Fid}/{post%5Fid}" of
Right tpl -> do
let result = render tpl
[ ("user%5Fid", WrappedValue $ Single ("u123" :: T.Text))
, ("post%5Fid", WrappedValue $ Single ("p456" :: T.Text))
]
result @?= ("u123/p456" :: T.Text)
Left _ -> assertFailure "Should parse multiple percent-encoded variable names"
label "Case sensitivity in percent encoding" $ test $ do
-- Both %2f and %2F should work (lowercase and uppercase hex)
case parseTemplate "/path%2Fwith%2fslashes" of
Right tpl -> renderTemplate tpl @?= "/path%2Fwith%2fslashes"
Left _ -> assertFailure "Should accept both uppercase and lowercase hex digits"
label "Unicode char gets properly encoded in output" $ test $ do
case parseTemplate "{value}" of
Right tpl -> do
let result = render tpl [("value", WrappedValue $ Single ("hello\x2665world" :: T.Text))]
-- Heart symbol should be UTF-8 encoded then percent-encoded
result @?= ("hello%E2%99%A5world" :: T.Text)
Left _ -> assertFailure "Should parse simple template"