diff --git a/LICENSE.markdown b/LICENSE.markdown new file mode 100644 --- /dev/null +++ b/LICENSE.markdown @@ -0,0 +1,15 @@ +ISC License (ISC) + +Copyright 2020 Taylor Fausak + +Permission to use, copy, modify, and/or distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM +LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR +OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,17 @@ +# Burrito + +Burrito is a Haskell library for parsing and rendering URI templates. + +According to [RFC 6570](https://tools.ietf.org/html/rfc6570): "A URI Template +is a compact sequence of characters for describing a range of Uniform Resource +Identifiers through variable expansion." Burrito implements URI templates +according to the specification in that RFC. + +The term "uniform resource identifiers" (URI) is often used interchangeably +with other related terms like "internationalized resource identifier" (IRI), +"uniform resource locator" (URL), and "uniform resource name" (URN). Burrito +can be used for all of these. If you want to get technical, its input must be a +valid IRI and its output will be a valid URI or URN. + +Although Burrito is primarily intended to be used with HTTP and HTTPS URIs, it +should work with other schemes as well. diff --git a/burrito.cabal b/burrito.cabal new file mode 100644 --- /dev/null +++ b/burrito.cabal @@ -0,0 +1,59 @@ +name: burrito +version: 1.0.0.0 + +synopsis: Parse and render URI templates. +description: + Burrito is a Haskell library for parsing and rendering URI templates. + . + According to [RFC 6570](https://tools.ietf.org/html/rfc6570): "A URI Template + is a compact sequence of characters for describing a range of Uniform + Resource Identifiers through variable expansion." Burrito implements URI + templates according to the specification in that RFC. + . + The term "uniform resource identifiers" (URI) is often used interchangeably + with other related terms like "internationalized resource identifier" (IRI), + "uniform resource locator" (URL), and "uniform resource name" (URN). Burrito + can be used for all of these. If you want to get technical, its input must be + a valid IRI and its output will be a valid URI or URN. + . + Although Burrito is primarily intended to be used with HTTP and HTTPS URIs, + it should work with other schemes as well. + +build-type: Simple +cabal-version: >= 1.8 +category: Network +extra-source-files: README.markdown +license-file: LICENSE.markdown +license: ISC +maintainer: Taylor Fausak + +library + build-depends: + base >= 4.12.0 && < 4.15 + exposed-modules: Burrito + ghc-options: + -Weverything + -Wno-all-missed-specialisations + -Wno-implicit-prelude + -Wno-missing-exported-signatures + -Wno-safe + hs-source-dirs: src/lib + + if impl(ghc >= 8.8.1) + ghc-options: + -Wno-missing-deriving-strategies + + if impl(ghc >= 8.10.1) + ghc-options: + -Wno-missing-safe-haskell-mode + -Wno-prepositive-qualified-module + +test-suite test + build-depends: + base -any + , burrito -any + , HUnit >= 1.6.0 && < 1.7 + , transformers >= 0.5.6 && < 0.6 + hs-source-dirs: src/test + main-is: Main.hs + type: exitcode-stdio-1.0 diff --git a/src/lib/Burrito.hs b/src/lib/Burrito.hs new file mode 100644 --- /dev/null +++ b/src/lib/Burrito.hs @@ -0,0 +1,944 @@ +-- | Burrito is a Haskell library for parsing and rendering URI templates. +-- +-- According to [RFC 6570](https://tools.ietf.org/html/rfc6570): "A URI +-- Template is a compact sequence of characters for describing a range of +-- Uniform Resource Identifiers through variable expansion." Burrito implements +-- URI templates according to the specification in that RFC. +-- +-- The term "uniform resource identifiers" (URI) is often used interchangeably +-- with other related terms like "internationalized resource identifier" (IRI), +-- "uniform resource locator" (URL), and "uniform resource name" (URN). Burrito +-- can be used for all of these. If you want to get technical, its input must +-- be a valid IRI and its output will be a valid URI or URN. +-- +-- Although Burrito is primarily intended to be used with HTTP and HTTPS URIs, +-- it should work with other schemes as well. +-- +-- If you're not already familiar with URI templates, I recommend reading the +-- overview of the RFC. It's short, to the point, and easy to understand. +-- +-- Assuming you're familiar with URI templates, here's a simple example to show +-- you how Burrito works: +-- +-- > import Burrito +-- > let Just template = parse "http://example.com/search{?query}" +-- > expand [ ( "query", stringValue "bikes" ) ] template +-- > "http://example.com/search?query=bikes" +-- +-- In short, use 'parse' to parse templates and 'expand' to render them. +module Burrito + ( parse + , expand + , Template + , Value + , stringValue + , listValue + , dictionaryValue + ) +where + +import qualified Control.Applicative as Applicative +import qualified Control.Monad as Monad +import qualified Data.Bits as Bits +import qualified Data.Char as Char +import qualified Data.Functor.Identity as Identity +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Maybe as Maybe +import qualified Data.Word as Word +import qualified Text.Printf as Printf + + +-- | Attempts to parse a string as a URI template. If parsing fails, this will +-- return 'Nothing'. Otherwise it will return 'Just' the parsed template. +-- +-- Parsing will usually succeed, but it can fail if the input string contains +-- characters that are not valid in IRIs (like @^@) or if the input string +-- contains an invalid template expression (like @{!}@). To include characters +-- that aren't valid in IRIs, percent encode them (like @%5E@). +parse :: String -> Maybe Template +parse string = case runParser parseTemplate string of + Just (template, "") -> Just template + _ -> Nothing + + +-- | Expands a template using the given values. Unlike parsing, expansion +-- always succeeds. If no value is given for a variable, it will simply not +-- appear in the output. +expand :: [(String, Value)] -> Template -> String +expand values = Identity.runIdentity + . expandTemplate (pure . flip lookup values . nameToString) + + +-- | Represents a URI template. Use 'parse' to create a template and 'expand' +-- to render one. +newtype Template = Template + { template_tokens :: [Token] + } deriving (Eq, Show) + + +-- | Represents a token in a template. +data Token + = Token_Expression Expression + | Token_Literal Literal + deriving (Eq, Show) + + +-- | Represents a literal in a token. +newtype Literal = Literal + { literal_characters :: NonEmpty.NonEmpty Character + } deriving (Eq, Show) + + +-- | Represents a character in a literal. Although encoded characters are +-- allowed to have any value, typically they will not include most ASCII +-- printable characters. In other words @A@ is more likely than @%41@. +data Character + = Character_Encoded Word.Word8 + | Character_Unencoded Char + deriving (Eq, Show) + + +-- | Represents an expression in a token. +data Expression = Expression + { expression_operator :: Operator + , expression_variables :: NonEmpty.NonEmpty Variable + } deriving (Eq, Show) + + +-- | Represents an operator in an expression. +data Operator + = Operator_Ampersand + | Operator_FullStop + | Operator_None + | Operator_NumberSign + | Operator_PlusSign + | Operator_QuestionMark + | Operator_Semicolon + | Operator_Solidus + deriving (Eq, Show) + + +-- | Represents a variable in an expression. +data Variable = Variable + { variable_modifier :: Modifier + , variable_name :: Name + } deriving (Eq, Show) + + +-- | Represents a modifier on a variable. The number associated with a prefix +-- modifier will be between 1 and 9999 inclusive. +data Modifier + = Modifier_Asterisk + | Modifier_Colon Int + | Modifier_None + deriving (Eq, Show) + + +-- | Represents a variable name, which is required to be non-empty. Variable +-- names allow ASCII letters and numbers, underscores, percent encoded triples, +-- and periods. However the periods cannot appear at the beginning or end, and +-- there can't be more than one of them in a row. +newtype Name = Name + { name_chars :: NonEmpty.NonEmpty Char + } deriving (Eq, Show) + + +-- | Represents a value that can be substituted into a template. Can be a +-- string, a list, or dictionary (which is called an associative array in the +-- RFC). Use 'stringValue', 'listValue', and 'dictionaryValue' to construct +-- values. +data Value + = Value_Dictionary [(String, String)] + | Value_List [String] + | Value_String String + deriving (Eq, Show) + + +-- | Constructs a string 'Value'. +stringValue :: String -> Value +stringValue = Value_String + + +-- | Constructs a list 'Value'. +listValue :: [String] -> Value +listValue = Value_List + + +-- | Constructs a dictionary 'Value'. +dictionaryValue :: [(String, String)] -> Value +dictionaryValue = Value_Dictionary + + +-- | Expands a template for output according to section 3 of the RFC, using the +-- given function to resolve variable values. +expandTemplate + :: Applicative m => (Name -> m (Maybe Value)) -> Template -> m String +expandTemplate f = expandTokens f . template_tokens + + +-- | Expands tokens for output according to section 3 of the RFC, using the +-- given function to resolve variable values. +expandTokens + :: Applicative m => (Name -> m (Maybe Value)) -> [Token] -> m String +expandTokens f = fmap concat . traverse (expandToken f) + + +-- | Expands a token for output according to section 3 of the RFC, using the +-- given function to resolve variable values. +expandToken :: Applicative m => (Name -> m (Maybe Value)) -> Token -> m String +expandToken f token = case token of + Token_Literal literal -> pure $ expandLiteral literal + Token_Expression expression -> expandExpression f expression + + +-- | Expands a literal token for output according to section 3.1 of the RFC. +expandLiteral :: Literal -> String +expandLiteral = concatMap expandCharacter . literal_characters + + +-- | Expands a single literal character for output. This is necessary to +-- normalize percent encodings and to encode characters that aren't allowed to +-- appear in URIs. +expandCharacter :: Character -> String +expandCharacter character = case character of + Character_Encoded word8 -> percentEncodeWord8 word8 + Character_Unencoded char -> escapeChar Operator_PlusSign char + + +-- | If necessary, escapes a character for output with the given operator. +-- Otherwise returns the character unchanged as a string. +escapeChar :: Operator -> Char -> String +escapeChar operator char = + if isAllowed operator char then [char] else percentEncodeChar char + + +-- | Returns true if the given character is allowed unescaped in the output for +-- the given operator. +isAllowed :: Operator -> Char -> Bool +isAllowed operator char = case operator of + Operator_NumberSign -> isUnreserved char || isReserved char + Operator_PlusSign -> isUnreserved char || isReserved char + _ -> isUnreserved char + + +-- | Percent encodes a character by UTF-8 encoding it and then percent encoding +-- the resulting octets. +percentEncodeChar :: Char -> String +percentEncodeChar = concatMap percentEncodeWord8 . encodeUtf8 + + +-- | Percent encodes an octet by converting it into uppercase hexadecimal +-- digits and prepending a percent sign. For example @12@ becomes @"%0C"@. +percentEncodeWord8 :: Word.Word8 -> String +percentEncodeWord8 = Printf.printf "%%%02X" + + +-- | Expands an expression for output according to section 3.2 of the RFC, +-- using the given function to resolve variable values. +expandExpression + :: Applicative m => (Name -> m (Maybe Value)) -> Expression -> m String +expandExpression f expression = + let + operator = expression_operator expression + prefix = prefixFor operator + separator = separatorFor operator + finalize expansions = + (if null expansions then "" else prefix) + <> List.intercalate separator expansions + in fmap finalize . expandVariables f operator $ expression_variables + expression + + +-- | Returns the prefix to use before an expression for the given operator. +prefixFor :: Operator -> String +prefixFor operator = case operator of + Operator_Ampersand -> "&" + Operator_FullStop -> "." + Operator_None -> "" + Operator_NumberSign -> "#" + Operator_PlusSign -> "" + Operator_QuestionMark -> "?" + Operator_Semicolon -> ";" + Operator_Solidus -> "/" + + +-- | Returns the separator to use between values for the given operator. +separatorFor :: Operator -> String +separatorFor operator = case operator of + Operator_Ampersand -> "&" + Operator_FullStop -> "." + Operator_None -> "," + Operator_NumberSign -> "," + Operator_PlusSign -> "," + Operator_QuestionMark -> "&" + Operator_Semicolon -> ";" + Operator_Solidus -> "/" + + +-- | Expands variables for output according to section 3.2 of the RFC, using +-- the given function to resolve variable values. +expandVariables + :: Applicative m + => (Name -> m (Maybe Value)) + -> Operator + -> NonEmpty.NonEmpty Variable + -> m [String] +expandVariables f operator = + fmap Maybe.catMaybes . traverse (expandVariable f operator) . NonEmpty.toList + + +-- | Expands a variable for output according to section 3.2.1 of the RFC, using +-- the given function to resolve variable values. +expandVariable + :: Applicative m + => (Name -> m (Maybe Value)) + -> Operator + -> Variable + -> m (Maybe String) +expandVariable f operator variable = + let + name = variable_name variable + modifier = variable_modifier variable + in expandMaybeValue operator name modifier <$> f name + + +-- | If the given value is not nothing, expand it according to section 3.2.1 of +-- the RFC. +expandMaybeValue :: Operator -> Name -> Modifier -> Maybe Value -> Maybe String +expandMaybeValue operator name modifier maybeValue = do + value <- maybeValue + expandValue operator name modifier value + + +-- | Expands a value for output according to section 3.2.1 of the RFC. If the +-- value is undefined according to section 2.3, this returns nothing. +expandValue :: Operator -> Name -> Modifier -> Value -> Maybe String +expandValue operator name modifier value = case value of + Value_Dictionary dictionary -> + expandDictionary operator name modifier <$> NonEmpty.nonEmpty dictionary + Value_List list -> + expandList operator name modifier <$> NonEmpty.nonEmpty list + Value_String string -> Just $ expandString operator name modifier string + + +-- | Expands a dictionary (associative array) value for output. +expandDictionary + :: Operator + -> Name + -> Modifier + -> NonEmpty.NonEmpty (String, String) + -> String +expandDictionary = expandElements + $ \operator _ modifier -> expandDictionaryElement operator modifier + + +-- | Expands one element of a dictionary value for output. +expandDictionaryElement :: Operator -> Modifier -> (String, String) -> [String] +expandDictionaryElement operator modifier (name, value) = + let escape = escapeString operator Modifier_None + in + case modifier of + Modifier_Asterisk -> [escape name <> "=" <> escape value] + _ -> [escape name, escape value] + + +-- | Expands a list value for output. +expandList + :: Operator -> Name -> Modifier -> NonEmpty.NonEmpty String -> String +expandList = expandElements $ \operator name modifier -> + pure . expandListElement operator name modifier + + +-- | Expands one element of a list value for output. +expandListElement :: Operator -> Name -> Modifier -> String -> String +expandListElement operator name modifier = case modifier of + Modifier_Asterisk -> expandString operator name Modifier_None + _ -> expandString Operator_None name Modifier_None + + +-- | Expands a collection of elements for output. This is used for both +-- dictionaries and lists. +expandElements + :: (Operator -> Name -> Modifier -> a -> [String]) + -> Operator + -> Name + -> Modifier + -> NonEmpty.NonEmpty a + -> String +expandElements f operator name modifier = + let + showPrefix = case modifier of + Modifier_Asterisk -> False + _ -> case operator of + Operator_Ampersand -> True + Operator_QuestionMark -> True + Operator_Semicolon -> True + _ -> False + prefix = if showPrefix then nameToString name <> "=" else "" + separator = case modifier of + Modifier_Asterisk -> separatorFor operator + _ -> "," + in mappend prefix . List.intercalate separator . concatMap + (f operator name modifier) + + +-- | Expands a string value for output. +expandString :: Operator -> Name -> Modifier -> String -> String +expandString operator name modifier s = + let + prefix = case operator of + Operator_Ampersand -> nameToString name <> "=" + Operator_QuestionMark -> nameToString name <> "=" + Operator_Semicolon -> nameToString name <> if null s then "" else "=" + _ -> "" + in prefix <> escapeString operator modifier s + + +-- | Escapes a string value for output. This handles encoding characters as +-- necessary for the given oeprator, as well as taking the prefix as necessary +-- for the given modifier. +escapeString :: Operator -> Modifier -> String -> String +escapeString operator modifier string = + concatMap (escapeChar operator) $ case modifier of + Modifier_Colon size -> take size string + _ -> string + + +-- | Converts a name into a regular string. +nameToString :: Name -> String +nameToString = NonEmpty.toList . name_chars + + +-- | Encodes a character as a series of UTF-8 octets. The resulting list will +-- have between one and four elements. +encodeUtf8 :: Char -> [Word.Word8] +encodeUtf8 char = + let + oneByte x = [intToWord8 $ bitAnd 0x7f x] + twoBytes x = + [ bitOr 0xc0 . intToWord8 . bitAnd 0x3f $ bitShiftR 6 x + , bitOr 0x80 . intToWord8 $ bitAnd 0x3f x + ] + threeBytes x = + [ bitOr 0xe0 . intToWord8 . bitAnd 0x0f $ bitShiftR 12 x + , bitOr 0x80 . intToWord8 . bitAnd 0x3f $ bitShiftR 6 x + , bitOr 0x80 . intToWord8 $ bitAnd 0x3f x + ] + fourBytes x = + [ bitOr 0xf0 . intToWord8 . bitAnd 0x07 $ bitShiftR 18 x + , bitOr 0x80 . intToWord8 . bitAnd 0x3f $ bitShiftR 12 x + , bitOr 0x80 . intToWord8 . bitAnd 0x3f $ bitShiftR 6 x + , bitOr 0x80 . intToWord8 $ bitAnd 0x3f x + ] + in case Char.ord char of + int + | int <= 0x7f -> oneByte int + | int <= 0x7ff -> twoBytes int + | int <= 0xffff -> threeBytes int + | otherwise -> fourBytes int + + +-- | Computes the bitwise AND of the two parameters. +bitAnd :: Bits.Bits a => a -> a -> a +bitAnd = (Bits..&.) + + +-- | Computes the bitwise OR of the two parameters. +bitOr :: Bits.Bits a => a -> a -> a +bitOr = (Bits..|.) + + +-- | Shifts the given value to the right by the specified number of bits. If +-- the shift amount is negative, an exception will be thrown. +bitShiftR :: Bits.Bits a => Int -> a -> a +bitShiftR = flip Bits.shiftR + + +-- | Converts a machine-sized signed integer into an eight-bit unsigned +-- integer. If the input is out of bounds, an exception will be thrown. +intToWord8 :: Int -> Word.Word8 +intToWord8 x = + let + lo = word8ToInt (minBound :: Word.Word8) + hi = word8ToInt (maxBound :: Word.Word8) + in if x < lo + then error $ "intToWord8: " <> show x <> " < " <> show lo + else if x > hi + then error $ "intToWord8: " <> show x <> " > " <> show hi + else fromIntegral x + + +-- | Converts an eight-bit unsigned integer into a machine-sized signed +-- integer. This conversion cannot fail. +word8ToInt :: Word.Word8 -> Int +word8ToInt = fromIntegral + + +-- | A simple type to handle parsing. +newtype Parser a = Parser + { runParser :: String -> Maybe (a, String) + } + + +instance Functor Parser where + -- | Applies the given function to the result of a successful parse. + fmap f p = Parser $ \s -> case runParser p s of + Nothing -> Nothing + Just (x, t) -> Just (f x, t) + + +instance Applicative Parser where + -- | Produces a parser that always succeeds by returning the given value. + pure x = Parser $ \s -> Just (x, s) + + -- | Uses the first parser to get a function, then uses the second parser to + -- get a value, then calls the function with the value. + p <*> q = Parser $ \s -> case runParser p s of + Nothing -> Nothing + Just (f, t) -> case runParser q t of + Nothing -> Nothing + Just (x, u) -> Just (f x, u) + + +instance Monad Parser where + -- | Feeds the output of a successful parse into the given function. If + -- parsing fails, doesn't call the function. + p >>= f = Parser $ \s -> case runParser p s of + Nothing -> Nothing + Just (x, t) -> runParser (f x) t + + +instance Applicative.Alternative Parser where + -- | Fails without consuming any input. + empty = Parser $ const Nothing + + -- | Returns the first parser if it succeeds. Otherwise returns the second + -- parser. + p <|> q = Parser $ \s -> case runParser p s of + Nothing -> runParser q s + Just (x, t) -> Just (x, t) + + +-- | Parses any one character. This is used as the basis for all other parsers. +parseAny :: Parser Char +parseAny = Parser $ \string -> case string of + "" -> Nothing + first : rest -> Just (first, rest) + + +-- | Runs the given parser between the other parsers. Useful for wrapping a +-- parser in quotes or parentheses. +parseBetween :: Parser before -> Parser after -> Parser a -> Parser a +parseBetween before after parser = before *> parser <* after + + +-- | Parses the given character and returns it. +parseChar :: Char -> Parser Char +parseChar = parseIf . (==) + + +-- | Parses the given character and throws it away. See 'parseChar' +parseChar_ :: Char -> Parser () +parseChar_ = Monad.void . parseChar + + +-- | Tries to parse the first thing. If that fails, tries to parse the second +-- thing. +parseEither :: Parser a -> Parser a -> Parser a +parseEither = (Applicative.<|>) + + +-- | Parses one character if it passes the given predicate function. +parseIf :: (Char -> Bool) -> Parser Char +parseIf predicate = do + char <- parseAny + if predicate char then pure char else Applicative.empty + + +-- | Runs the given parser at least once. +parseNonEmpty :: Parser a -> Parser (NonEmpty.NonEmpty a) +parseNonEmpty parser = nonEmpty <$> parser <*> Applicative.many parser + + +-- | Runs the given parser separated by the other parser. Requires at least one +-- occurrence of the non-separator parser. +parseSepBy1 :: Parser separator -> Parser a -> Parser (NonEmpty.NonEmpty a) +parseSepBy1 separator parser = + nonEmpty <$> parser <*> Applicative.many (separator *> parser) + + +-- | Parses a @URI-Template@ as defined by section 2 of the RFC. +parseTemplate :: Parser Template +parseTemplate = Template <$> Applicative.many parseToken + + +-- | Parses a token, which we define as part of a URI template. +parseToken :: Parser Token +parseToken = parseEither + (Token_Literal <$> parseLiteral) + (Token_Expression <$> parseExpression) + + +-- | Parses a @literals@ value as defined by section 2.1 of the RFC. +parseLiteral :: Parser Literal +parseLiteral = Literal <$> parseNonEmpty parseCharacter + + +-- | Parses a character in a literal. +parseCharacter :: Parser Character +parseCharacter = parseEither parseCharacterUnencoded parseCharacterEncoded + + +-- | Parses an unencoded character in a literal. +parseCharacterUnencoded :: Parser Character +parseCharacterUnencoded = Character_Unencoded <$> parseIf isLiteral + + +-- | Parses a percent-encoded character in a literal. +parseCharacterEncoded :: Parser Character +parseCharacterEncoded = do + (hi, lo) <- parsePercentEncoded + pure . Character_Encoded $ intToWord8 + (Char.digitToInt hi * 16 + Char.digitToInt lo) + + +-- | Parses an @expression@ as defined by section 2.2 of the RFC. +parseExpression :: Parser Expression +parseExpression = + parseBetween (parseChar_ '{') (parseChar_ '}') + $ Expression + <$> parseOperator + <*> parseVariableList + + +-- | Parses a @variable-list@ as defined by sections 2.3 of the RFC. +parseVariableList :: Parser (NonEmpty.NonEmpty Variable) +parseVariableList = parseSepBy1 (parseChar_ ',') parseVarspec + + +-- | Parses a @varspec@ as defined by section 2.3 of the RFC. +parseVarspec :: Parser Variable +parseVarspec = do + name <- parseVarname + modifier <- parseModifier + pure $ Variable { variable_name = name, variable_modifier = modifier } + + +-- | Parses a @varname@ as defined by section 2.3 of the RFC. +parseVarname :: Parser Name +parseVarname = do + first <- parseVarcharFirst + rest <- Applicative.many parseVarcharRest + pure . Name $ combine first rest + + +-- | Parses the first character in a variable name, which excludes periods. +parseVarcharFirst :: Parser (NonEmpty.NonEmpty Char) +parseVarcharFirst = parseEither parseVarcharUnencoded parseVarcharEncoded + + +-- | Parses an unencoded character in a variable name. +parseVarcharUnencoded :: Parser (NonEmpty.NonEmpty Char) +parseVarcharUnencoded = pure <$> parseIf isVarchar + + +-- | Parses a percent-encoded character in a variable name. +parseVarcharEncoded :: Parser (NonEmpty.NonEmpty Char) +parseVarcharEncoded = do + (hi, lo) <- parsePercentEncoded + pure $ nonEmpty '%' [hi, lo] + + +-- | Parses a non-first character in a variable name. This is like +-- 'parseVarcharFirst' except it allows periods. +parseVarcharRest :: Parser (NonEmpty.NonEmpty Char) +parseVarcharRest = parseEither + (nonEmpty <$> parseChar '.' <*> fmap NonEmpty.toList parseVarcharFirst) + parseVarcharFirst + + +-- | Returns true if the given character is in the @varchar@ range defined by +-- section 2.3 of the RFC. Note that this does not include the @pct-encoded@ +-- part of the grammar because that requires multiple characters to match. +isVarchar :: Char -> Bool +isVarchar x = case x of + '_' -> True + _ -> isAlpha x || Char.isDigit x + + +-- | Adds a bunch of non-empty lists to the end of one non-empty list, while +-- keeping the non-emptiness around. +combine :: NonEmpty.NonEmpty a -> [NonEmpty.NonEmpty a] -> NonEmpty.NonEmpty a +combine xs = + nonEmpty (NonEmpty.head xs) + . mappend (NonEmpty.tail xs) + . concatMap NonEmpty.toList + + +-- | Constructs a non-empty list without using an operator. +nonEmpty :: a -> [a] -> NonEmpty.NonEmpty a +nonEmpty = (NonEmpty.:|) + + +-- | Parses a @pct-encoded@ as defined by section 1.5 of the RFC. Returns both +-- hexadecimal digits as they appeared in the input without doing any case +-- normalization. +parsePercentEncoded :: Parser (Char, Char) +parsePercentEncoded = do + parseChar_ '%' + (,) <$> parseIf Char.isHexDigit <*> parseIf Char.isHexDigit + + +-- | Parses an @operator@ as defined by section 2.2 of the RFC. +parseOperator :: Parser Operator +parseOperator = + Maybe.fromMaybe Operator_None <$> Applicative.optional parseRequiredOperator + + +-- | Parses a required, non-reserved operator as defined by section 2.2 of the +-- RFC. See 'parseOperator'. +parseRequiredOperator :: Parser Operator +parseRequiredOperator = do + operator <- parseIf isOperator + maybe Applicative.empty pure $ toOperator operator + + +-- | Converts an operator character into its respective 'Operator' type. +-- Returns nothing for characters that are not valid operators. +toOperator :: Char -> Maybe Operator +toOperator x = case x of + '+' -> Just Operator_PlusSign + '#' -> Just Operator_NumberSign + '.' -> Just Operator_FullStop + '/' -> Just Operator_Solidus + ';' -> Just Operator_Semicolon + '?' -> Just Operator_QuestionMark + '&' -> Just Operator_Ampersand + _ -> Nothing + + +-- | Returns true if the given character is in the @operator@ range defined by +-- section 2.2 of the RFC. +isOperator :: Char -> Bool +isOperator x = isOpLevel2 x || isOpLevel3 x || isOpReserve x + + +-- | Returns true if the given character is in the @op-level2@ range defined by +-- section 2.2 of the RFC. +isOpLevel2 :: Char -> Bool +isOpLevel2 x = case x of + '+' -> True + '#' -> True + _ -> False + + +-- | Returns true if the given character is in the @op-level3@ range defined by +-- section 2.2 of the RFC. +isOpLevel3 :: Char -> Bool +isOpLevel3 x = case x of + '.' -> True + '/' -> True + ';' -> True + '?' -> True + '&' -> True + _ -> False + + +-- | Returns true if the given character is in the @op-reserve@ range defined +-- by section 2.2 of the RFC. +isOpReserve :: Char -> Bool +isOpReserve x = case x of + '=' -> True + ',' -> True + '!' -> True + '@' -> True + '|' -> True + _ -> False + + +-- | Parses a @modifier-level4@ as defined by section 2.4 of the RFC. +parseModifier :: Parser Modifier +parseModifier = + fmap (Maybe.fromMaybe Modifier_None) . Applicative.optional $ parseEither + parsePrefixModifier + parseExplodeModifier + + +-- | Parses a @prefix@ as defined by section 2.4.1 of the RFC. +parsePrefixModifier :: Parser Modifier +parsePrefixModifier = do + parseChar_ ':' + Modifier_Colon <$> parseMaxLength + + +-- | Parses a @max-length@ as defined by section 2.4.1 of the RFC. +parseMaxLength :: Parser Int +parseMaxLength = do + first <- parseNonZeroDigit + rest <- parseUpTo 3 parseDigit + pure . fromDigits $ nonEmpty first rest + + +-- | Converts a list of digits into the number that they represent. For example +-- @[1, 2]@ becomes @12@. +fromDigits :: NonEmpty.NonEmpty Int -> Int +fromDigits = foldr1 ((+) . (10 *)) + + +-- | Parses up to the given number of occurrences of the given parser. If the +-- number is less than one, this will always succeed by returning the empty +-- list. +parseUpTo :: Int -> Parser a -> Parser [a] +parseUpTo = parseUpToWith [] + + +-- | Like 'parseUpTo' but with an explicit accumulator. +parseUpToWith :: [a] -> Int -> Parser a -> Parser [a] +parseUpToWith accumulator remaining parser = if remaining < 1 + then pure accumulator + else do + result <- Applicative.optional parser + case result of + Nothing -> pure accumulator + Just value -> parseUpToWith (value : accumulator) (remaining - 1) parser + + +-- | Parses a single non-zero decimal digit and returns that digit's value. See +-- 'isNonZeroDigit'. +parseNonZeroDigit :: Parser Int +parseNonZeroDigit = Char.digitToInt <$> parseIf isNonZeroDigit + + +-- | Returns true if the given character is a non-zero decimal digit. This +-- range isn't explicitly named by the RFC, but it's given in section 2.4.1. +isNonZeroDigit :: Char -> Bool +isNonZeroDigit x = case x of + '0' -> False + _ -> Char.isDigit x + + +-- | Parses a single decimal digit and returns that digit's value. +parseDigit :: Parser Int +parseDigit = Char.digitToInt <$> parseIf Char.isDigit + + +-- | Returns true if the given character is in the @ALPHA@ range defined by +-- section 1.5 of the RFC. +isAlpha :: Char -> Bool +isAlpha x = Char.isAsciiUpper x || Char.isAsciiLower x + + +-- | Parses an @explode@ as defined by section 2.4.2 of the RFC. +parseExplodeModifier :: Parser Modifier +parseExplodeModifier = Modifier_Asterisk <$ parseChar_ '*' + + +-- | Returns true if the given character is in the @reserved@ range defined by +-- section 1.5 of the RFC. +isReserved :: Char -> Bool +isReserved x = isGenDelim x || isSubDelim x + + +-- | Returns true if the given character is in the @gen-delims@ range defined +-- by section 1.5 of the RFC. +isGenDelim :: Char -> Bool +isGenDelim x = case x of + ':' -> True + '/' -> True + '?' -> True + '#' -> True + '[' -> True + ']' -> True + '@' -> True + _ -> False + + +-- | Returns true if the given character is in the @sub-delims@ range defined +-- by section 1.5 of the RFC. +isSubDelim :: Char -> Bool +isSubDelim x = case x of + '!' -> True + '$' -> True + '&' -> True + '\'' -> True + '(' -> True + ')' -> True + '*' -> True + '+' -> True + ',' -> True + ';' -> True + '=' -> True + _ -> False + + +-- | Returns true if the given character is in the @unreserved@ range defined +-- by section 1.5 of the RFC. +isUnreserved :: Char -> Bool +isUnreserved x = case x of + '-' -> True + '.' -> True + '_' -> True + '~' -> True + _ -> isAlpha x || Char.isDigit x + + +-- | Returns true if the given character is in the @literal@ range defined by +-- section 2.1 of the RFC. +isLiteral :: Char -> Bool +isLiteral x = case x of + ' ' -> False + '"' -> False + '\'' -> False + '%' -> False + '<' -> False + '>' -> False + '\\' -> False + '^' -> False + '`' -> False + '{' -> False + '|' -> False + '}' -> False + _ -> between '\x20' '\x7e' x || isUcschar x || isIprivate x + + +-- | Returns true if the given character is in the @ucschar@ range defined by +-- section 1.5 of the RFC. +isUcschar :: Char -> Bool +isUcschar x = + between '\xa0' '\xd7ff' x + || between '\xf900' '\xfdcf' x + || between '\xfdf0' '\xffef' x + || between '\x10000' '\x1fffd' x + || between '\x20000' '\x2fffd' x + || between '\x30000' '\x3fffd' x + || between '\x40000' '\x4fffd' x + || between '\x50000' '\x5fffd' x + || between '\x60000' '\x6fffd' x + || between '\x70000' '\x7fffd' x + || between '\x80000' '\x8fffd' x + || between '\x90000' '\x9fffd' x + || between '\xa0000' '\xafffd' x + || between '\xb0000' '\xbfffd' x + || between '\xc0000' '\xcfffd' x + || between '\xd0000' '\xdfffd' x + || between '\xe1000' '\xefffd' x + + +-- | Returns true if the given character is in the @iprivate@ range defined by +-- section 1.5 of the RFC. +isIprivate :: Char -> Bool +isIprivate x = + between '\xe000' '\xf8ff' x + || between '\xf0000' '\xffffd' x + || between '\x100000' '\x10fffd' x + + +-- | Returns true if the value is between the given inclusive bounds. +between + :: Ord a + => a -- ^ lower bound + -> a -- ^ upper bound + -> a + -> Bool +between lo hi x = lo <= x && x <= hi diff --git a/src/test/Main.hs b/src/test/Main.hs new file mode 100644 --- /dev/null +++ b/src/test/Main.hs @@ -0,0 +1,1231 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Main + ( main + ) +where + +import qualified Burrito +import qualified Control.Monad as Monad +import qualified Control.Monad.Trans.Writer as Writer +import qualified Data.Either as Either +import qualified Data.String as String +import qualified GHC.Exts as Exts +import qualified GHC.Stack as Stack +import qualified System.Exit as Exit +import qualified Test.HUnit as Test + +main :: IO () +main = runTests $ do + + label "accepts empty templates" $ do + test "" [] "" + + label "ignores extra variables" $ do + test "" ["extra" =: "ignored"] "" + + label "accepts ascii literals" $ do + test "!" [] "!" + test "#" [] "#" + test "$" [] "$" + test "&" [] "&" + test "(" [] "(" + test ")" [] ")" + test "*" [] "*" + test "+" [] "+" + test "," [] "," + test "-" [] "-" + test "." [] "." + test "/" [] "/" + test "0" [] "0" + test "9" [] "9" + test ":" [] ":" + test ";" [] ";" + test "=" [] "=" + test "?" [] "?" + test "@" [] "@" + test "A" [] "A" + test "Z" [] "Z" + test "[" [] "[" + test "]" [] "]" + test "_" [] "_" + test "a" [] "a" + test "z" [] "z" + test "~" [] "~" + + label "accepts unicode literals" $ do + test "\xa0" [] "%C2%A0" + test "\xd7ff" [] "%ED%9F%BF" + test "\xf900" [] "%EF%A4%80" + test "\xfdcf" [] "%EF%B7%8F" + test "\xfdf0" [] "%EF%B7%B0" + test "\xffef" [] "%EF%BF%AF" + test "\x10000" [] "%F0%90%80%80" + test "\x1fffd" [] "%F0%9F%BF%BD" + test "\x20000" [] "%F0%A0%80%80" + test "\x2fffd" [] "%F0%AF%BF%BD" + test "\x30000" [] "%F0%B0%80%80" + test "\x3fffd" [] "%F0%BF%BF%BD" + test "\x40000" [] "%F1%80%80%80" + test "\x4fffd" [] "%F1%8F%BF%BD" + test "\x50000" [] "%F1%90%80%80" + test "\x5fffd" [] "%F1%9F%BF%BD" + test "\x60000" [] "%F1%A0%80%80" + test "\x6fffd" [] "%F1%AF%BF%BD" + test "\x70000" [] "%F1%B0%80%80" + test "\x7fffd" [] "%F1%BF%BF%BD" + test "\x80000" [] "%F2%80%80%80" + test "\x8fffd" [] "%F2%8F%BF%BD" + test "\x90000" [] "%F2%90%80%80" + test "\x9fffd" [] "%F2%9F%BF%BD" + test "\xa0000" [] "%F2%A0%80%80" + test "\xafffd" [] "%F2%AF%BF%BD" + test "\xb0000" [] "%F2%B0%80%80" + test "\xbfffd" [] "%F2%BF%BF%BD" + test "\xc0000" [] "%F3%80%80%80" + test "\xcfffd" [] "%F3%8F%BF%BD" + test "\xd0000" [] "%F3%90%80%80" + test "\xdfffd" [] "%F3%9F%BF%BD" + test "\xe1000" [] "%F3%A1%80%80" + test "\xefffd" [] "%F3%AF%BF%BD" + + label "accepts private literals" $ do + test "\xe000" [] "%EE%80%80" + test "\xf8ff" [] "%EF%A3%BF" + test "\xf0000" [] "%F3%B0%80%80" + test "\xffffd" [] "%F3%BF%BF%BD" + test "\x100000" [] "%F4%80%80%80" + test "\x10fffd" [] "%F4%8F%BF%BD" + + label "passes percent encoded literals through" $ do + test "%00" [] "%00" + + label "normalizes percent encodings to uppercase" $ do + test "%AA" [] "%AA" + test "%Aa" [] "%AA" + test "%aA" [] "%AA" + test "%aa" [] "%AA" + + label "rejects invalid percent encodings" $ do + test "%" [] Failure + test "%0" [] Failure + test "%0z" [] Failure + test "%z" [] Failure + + label "does not decode percent encoded literals" $ do + test "%30" [] "%30" + + label "rejects invalid literals" $ do + test " " [] Failure + test "\"" [] Failure + test "'" [] Failure + test "%" [] Failure + test "<" [] Failure + test ">" [] Failure + test "\\" [] Failure + test "^" [] Failure + test "`" [] Failure + test "{" [] Failure + test "|" [] Failure + test "}" [] Failure + + label "rejects empty variable names" $ do + test "{}" [] Failure + test "{,}" [] Failure + test "{a,,b}" [] Failure + test "{+}" [] Failure + test "{:1}" [] Failure + test "{*}" [] Failure + + label "accepts uppercase variable names" $ do + test "{AZ}" [] "" + + label "accepts lowercase variable names" $ do + test "{az}" [] "" + + label "accepts decimal variable names" $ do + test "{09}" [] "" + + label "accepts underscores in variable names" $ do + test "{_a}" [] "" + test "{a_}" [] "" + test "{_}" [] "" + + label "accepts dots in variable names" $ do + test "{A.A}" [] "" + test "{a.a}" [] "" + test "{0.0}" [] "" + test "{_._}" [] "" + test "{%aa.%aa}" [] "" + + label "rejects invalid dots in variable names" $ do + test "{.}" [] Failure + test "{a.}" [] Failure + test "{+.a}" [] Failure + test "{a..b}" [] Failure + + label "accepts percent encoded variable names" $ do + test "{%00}" [] "" + + -- It's unclear if percent encoded triplets in variable names should be case + -- sensitive or not. Section 2.3 says: "Variable names are case-sensitive + -- because the name might be expanded within a case-sensitive URI component." + -- But the HEXDIG rule in section 1.5 says: "; case-insensitive". I think + -- it's safe to assume they are case sensitive because they can appear in an + -- expansion. For example: + -- + -- render "{;%aa}" [("%aa", "A")] ==> ";%aa=A" + -- + -- However percent encoded triplets that only differ by case would be decoded + -- into the same octet anyway. + label "does not normalize percent encoded variable names" $ do + test "{%AA}" ["%AA" =: "upper-upper"] "upper-upper" + test "{%Aa}" ["%Aa" =: "upper-lower"] "upper-lower" + test "{%aA}" ["%aA" =: "lower-upper"] "lower-upper" + test "{%aa}" ["%aa" =: "lower-lower"] "lower-lower" + + label "rejects invalid percent encoded variable names" $ do + test "{%}" [] Failure + test "{%0}" [] Failure + test "{%0z}" [] Failure + test "{%z}" [] Failure + + label "rejects invalid variable names" $ do + test "{!}" [] Failure + + label "rejects invalid expressions" $ do + test "{" [] Failure + test "{{}" [] Failure + test "}" [] Failure + test "{}}" [] Failure + + label "accepts multiple variables in one expression" $ do + test "{a,b}" [] "" + test "{a,b,c,d}" [] "" + test "{a,a}" [] "" + + label "accepts prefix modifiers" $ do + test "{a:5}" [] "" + test "{a:67}" [] "" + test "{a:801}" [] "" + test "{a:234}" [] "" + test "{a:9999}" [] "" + + label "applies prefix modifiers" $ do + let values = ["a" =: "abcdefghijklmnopqrstuvwxyz"] :: Values + test "{a:1}" values "a" + test "{a:5}" values "abcde" + test "{a:10}" values "abcdefghij" + test "{a:15}" values "abcdefghijklmno" + test "{a:20}" values "abcdefghijklmnopqrst" + test "{a:25}" values "abcdefghijklmnopqrstuvwxy" + test "{a:30}" values "abcdefghijklmnopqrstuvwxyz" + + label "rejects invalid prefix modifiers" $ do + test "{a:}" [] Failure + test "{a:0}" [] Failure + test "{a:10000}" [] Failure + test "{a:-1}" [] Failure + + label "accepts explode modifiers" $ do + test "{a*}" [] "" + + label "rejects both prefix and explode modifiers" $ do + test "{a:1*}" [] Failure + test "{a*:1}" [] Failure + + label "accepts different modifiers on different variables" $ do + test "{a,b:1,c*}" [] "" + + label "accepts allowed operators" $ do + test "{+a}" [] "" + test "{#a}" [] "" + test "{.a}" [] "" + test "{/a}" [] "" + test "{;a}" [] "" + test "{?a}" [] "" + test "{&a}" [] "" + + label "rejects reserved operators" $ do + test "{=a}" [] Failure + test "{,a}" [] Failure + test "{!a}" [] Failure + test "{@a}" [] Failure + test "{|a}" [] Failure + + label "rejects multiple operators" $ do + test "{+#a}" [] Failure + + label "rejects different operators for different variables" $ do + test "{+a,#b}" [] Failure + + label "accepts operators and modifiers" $ do + test "{+a:1}" [] "" + test "{#a*}" [] "" + + label "accepts multiple variables with an operator" $ do + test "{+a,b}" [] "" + test "{#a,b}" [] "" + test "{.a,b}" [] "" + test "{/a,b}" [] "" + test "{;a,b}" [] "" + test "{?a,b}" [] "" + test "{&a,b}" [] "" + + label "accepts multiple expressions" $ do + test "{a}{b}" [] "" + test "{a}{b}{c}{d}" [] "" + test "{a}{a}" [] "" + + label "rejects nested expressions" $ do + test "{{}}" [] Failure + test "{a{b}}" [] Failure + test "{{a}b}" [] Failure + test "{a{b}c}" [] Failure + + label "accepts literals and expressions together" $ do + test "a{b}" [] "a" + test "{a}b" [] "b" + test "a{b}c" [] "ac" + test "{a}b{c}" [] "b" + + label "handles missing values" $ do + test "{a}" [] "" + test "{+a}" [] "" + test "{#a}" [] "" + test "{.a}" [] "" + test "{/a}" [] "" + test "{;a}" [] "" + test "{?a}" [] "" + test "{&a}" [] "" + + label "handles empty list values" $ do + let values = ["a" =: emptyList] :: Values + test "{a}" values "" + test "{+a}" values "" + test "{#a}" values "" + test "{.a}" values "" + test "{/a}" values "" + test "{;a}" values "" + test "{?a}" values "" + test "{&a}" values "" + + label "handles empty dictionary values" $ do + let values = ["a" =: emptyDictionary] :: Values + test "{a}" values "" + test "{+a}" values "" + test "{#a}" values "" + test "{.a}" values "" + test "{/a}" values "" + test "{;a}" values "" + test "{?a}" values "" + test "{&a}" values "" + + label "handles empty string values" $ do + let values = ["a" =: ""] :: Values + test "{a}" values "" + test "{+a}" values "" + test "{#a}" values "#" + test "{.a}" values "." + test "{/a}" values "/" + test "{;a}" values ";a" + test "{?a}" values "?a=" + test "{&a}" values "&a=" + + label "handles nonempty string values" $ do + let values = ["a" =: "A"] :: Values + test "{a}" values "A" + test "{+a}" values "A" + test "{#a}" values "#A" + test "{.a}" values ".A" + test "{/a}" values "/A" + test "{;a}" values ";a=A" + test "{?a}" values "?a=A" + test "{&a}" values "&a=A" + + label "handles a mix of defined and undefined values" $ do + let values = ["b" =: "B"] :: Values + test "{a,b}" values "B" + test "{+a,b}" values "B" + test "{#a,b}" values "#B" + test "{.a,b}" values ".B" + test "{/a,b}" values "/B" + test "{;a,b}" values ";b=B" + test "{?a,b}" values "?b=B" + test "{&a,b}" values "&b=B" + + label "handles multiple empty string values" $ do + let values = ["a" =: ""] :: Values + test "{a,a}" values "," + test "{+a,a}" values "," + test "{#a,a}" values "#," + test "{.a,a}" values ".." + test "{/a,a}" values "//" + test "{;a,a}" values ";a;a" + test "{?a,a}" values "?a=&a=" + test "{&a,a}" values "&a=&a=" + + label "handles multiple non-empty string values" $ do + let values = ["a" =: "A", "b" =: "B"] :: Values + test "{a,b}" values "A,B" + test "{+a,b}" values "A,B" + test "{#a,b}" values "#A,B" + test "{.a,b}" values ".A.B" + test "{/a,b}" values "/A/B" + test "{;a,b}" values ";a=A;b=B" + test "{?a,b}" values "?a=A&b=B" + test "{&a,b}" values "&a=A&b=B" + + label "escapes characters in composite dictionaries" $ do + let values = ["a" =: ["K! \xa0\xd7ff\x10000" =: "V! \xa0\xd7ff\x10000"]] :: Values + test "{a*}" values "K%21%20%C2%A0%ED%9F%BF%F0%90%80%80=V%21%20%C2%A0%ED%9F%BF%F0%90%80%80" + test "{+a*}" values "K!%20%C2%A0%ED%9F%BF%F0%90%80%80=V!%20%C2%A0%ED%9F%BF%F0%90%80%80" + test "{#a*}" values "#K!%20%C2%A0%ED%9F%BF%F0%90%80%80=V!%20%C2%A0%ED%9F%BF%F0%90%80%80" + test "{.a*}" values ".K%21%20%C2%A0%ED%9F%BF%F0%90%80%80=V%21%20%C2%A0%ED%9F%BF%F0%90%80%80" + test "{/a*}" values "/K%21%20%C2%A0%ED%9F%BF%F0%90%80%80=V%21%20%C2%A0%ED%9F%BF%F0%90%80%80" + test "{;a*}" values ";K%21%20%C2%A0%ED%9F%BF%F0%90%80%80=V%21%20%C2%A0%ED%9F%BF%F0%90%80%80" + test "{?a*}" values "?K%21%20%C2%A0%ED%9F%BF%F0%90%80%80=V%21%20%C2%A0%ED%9F%BF%F0%90%80%80" + test "{&a*}" values "&K%21%20%C2%A0%ED%9F%BF%F0%90%80%80=V%21%20%C2%A0%ED%9F%BF%F0%90%80%80" + + label "prefers the first variable" $ do + test "{a}" ["a" =: "A", "a" =: "B"] "A" + test "{a}" ["a" =: "B", "a" =: "A"] "B" + + label "passes test from rfc" $ do + + label "section 1.1" $ do + test "http://example.com/~{username}/" ["username" =: "fred"] "http://example.com/~fred/" + test "http://example.com/~{username}/" ["username" =: "mark"] "http://example.com/~mark/" + test "http://example.com/dictionary/{term:1}/{term}" ["term" =: "cat"] "http://example.com/dictionary/c/cat" + test "http://example.com/dictionary/{term:1}/{term}" ["term" =: "dog"] "http://example.com/dictionary/d/dog" + test "http://example.com/search{?q,lang}" ["q" =: "cat", "lang" =: "en"] "http://example.com/search?q=cat&lang=en" + test "http://example.com/search{?q,lang}" ["q" =: "chien", "lang" =: "fr"] "http://example.com/search?q=chien&lang=fr" + test "http://www.example.com/foo{?query,number}" ["query" =: "mycelium", "number" =: "100"] "http://www.example.com/foo?query=mycelium&number=100" + test "http://www.example.com/foo{?query,number}" ["number" =: "100"] "http://www.example.com/foo?number=100" + test "http://www.example.com/foo{?query,number}" [] "http://www.example.com/foo" + + label "section 1.2" $ do + let + values = + [ "empty" =: "" + , "hello" =: "Hello World!" + , "keys" =: ["semi" =: ";", "dot" =: ".", "comma" =: ","] + , "list" =: ["red", "green", "blue"] + , "path" =: "/foo/bar" + , "var" =: "value" + , "x" =: "1024" + , "y" =: "768" + ] :: Values + + label "level 1" $ do + test "{var}" values "value" + test "{hello}" values "Hello%20World%21" + + label "level 2" $ do + test "{+var}" values "value" + test "{+hello}" values "Hello%20World!" + test "{+path}/here" values "/foo/bar/here" + test "here?ref={+path}" values "here?ref=/foo/bar" + test "X{#var}" values "X#value" + test "X{#hello}" values "X#Hello%20World!" + + label "level 3" $ do + test "map?{x,y}" values "map?1024,768" + test "{x,hello,y}" values "1024,Hello%20World%21,768" + test "{+x,hello,y}" values "1024,Hello%20World!,768" + test "{+path,x}/here" values "/foo/bar,1024/here" + test "{#x,hello,y}" values "#1024,Hello%20World!,768" + test "{#path,x}/here" values "#/foo/bar,1024/here" + test "X{.var}" values "X.value" + test "X{.x,y}" values "X.1024.768" + test "{/var}" values "/value" + test "{/var,x}/here" values "/value/1024/here" + test "{;x,y}" values ";x=1024;y=768" + test "{;x,y,empty}" values ";x=1024;y=768;empty" + test "{?x,y}" values "?x=1024&y=768" + test "{?x,y,empty}" values "?x=1024&y=768&empty=" + test "?fixed=yes{&x}" values "?fixed=yes&x=1024" + test "{&x,y,empty}" values "&x=1024&y=768&empty=" + + label "level 4" $ do + test "{var:3}" values "val" + test "{var:30}" values "value" + test "{list}" values "red,green,blue" + test "{list*}" values "red,green,blue" + test "{keys}" values "semi,%3B,dot,.,comma,%2C" + test "{keys*}" values "semi=%3B,dot=.,comma=%2C" + test "{+path:6}/here" values "/foo/b/here" + test "{+list}" values "red,green,blue" + test "{+list*}" values "red,green,blue" + test "{+keys}" values "semi,;,dot,.,comma,," + test "{+keys*}" values "semi=;,dot=.,comma=," + test "{#path:6}/here" values "#/foo/b/here" + test "{#list}" values "#red,green,blue" + test "{#list*}" values "#red,green,blue" + test "{#keys}" values "#semi,;,dot,.,comma,," + test "{#keys*}" values "#semi=;,dot=.,comma=," + test "X{.var:3}" values "X.val" + test "X{.list}" values "X.red,green,blue" + test "X{.list*}" values "X.red.green.blue" + test "X{.keys}" values "X.semi,%3B,dot,.,comma,%2C" + test "X{.keys*}" values "X.semi=%3B.dot=..comma=%2C" + test "{/var:1,var}" values "/v/value" + test "{/list}" values "/red,green,blue" + test "{/list*}" values "/red/green/blue" + test "{/list*,path:4}" values "/red/green/blue/%2Ffoo" + test "{/keys}" values "/semi,%3B,dot,.,comma,%2C" + test "{/keys*}" values "/semi=%3B/dot=./comma=%2C" + test "{;hello:5}" values ";hello=Hello" + test "{;list}" values ";list=red,green,blue" + test "{;list*}" values ";list=red;list=green;list=blue" + test "{;keys}" values ";keys=semi,%3B,dot,.,comma,%2C" + test "{;keys*}" values ";semi=%3B;dot=.;comma=%2C" + test "{?var:3}" values "?var=val" + test "{?list}" values "?list=red,green,blue" + test "{?list*}" values "?list=red&list=green&list=blue" + test "{?keys}" values "?keys=semi,%3B,dot,.,comma,%2C" + test "{?keys*}" values "?semi=%3B&dot=.&comma=%2C" + test "{&var:3}" values "&var=val" + test "{&list}" values "&list=red,green,blue" + test "{&list*}" values "&list=red&list=green&list=blue" + test "{&keys}" values "&keys=semi,%3B,dot,.,comma,%2C" + test "{&keys*}" values "&semi=%3B&dot=.&comma=%2C" + + label "section 2.4.1" $ do + let values = ["var" =: "value", "semi" =: ";"] :: Values + test "{var}" values "value" + test "{var:20}" values "value" + test "{var:3}" values "val" + test "{semi}" values "%3B" + test "{semi:2}" values "%3B" + + label "section 2.4.2" $ do + let values = ["year" =: ["1965", "2000", "2012"], "dom" =: ["example", "com"]] :: Values + test "find{?year*}" values "find?year=1965&year=2000&year=2012" + test "www{.dom*}" values "www.example.com" + + label "section 3.1" $ do + let + values = + [ "base" =: "http://example.com/home/" + , "count" =: ["one", "two", "three"] + , "dom" =: ["example", "com"] + , "dub" =: "me/too" + , "empty_keys" =: emptyDictionary + , "empty" =: "" + , "half" =: "50%" + , "hello" =: "Hello World!" + , "keys" =: ["semi" =: ";", "dot" =: ".", "comma" =: ","] + , "list" =: ["red", "green", "blue"] + , "path" =: "/foo/bar" + , "v" =: "6" + , "var" =: "value" + , "who" =: "fred" + , "x" =: "1024" + , "y" =: "768" + ] :: Values + + label "subsection 1" $ do + test "{count}" values "one,two,three" + test "{count*}" values "one,two,three" + test "{/count}" values "/one,two,three" + test "{/count*}" values "/one/two/three" + test "{;count}" values ";count=one,two,three" + test "{;count*}" values ";count=one;count=two;count=three" + test "{?count}" values "?count=one,two,three" + test "{?count*}" values "?count=one&count=two&count=three" + test "{&count*}" values "&count=one&count=two&count=three" + + label "subsection 2" $ do + test "{var}" values "value" + test "{hello}" values "Hello%20World%21" + test "{half}" values "50%25" + test "O{empty}X" values "OX" + test "O{undef}X" values "OX" + test "{x,y}" values "1024,768" + test "{x,hello,y}" values "1024,Hello%20World%21,768" + test "?{x,empty}" values "?1024," + test "?{x,undef}" values "?1024" + test "?{undef,y}" values "?768" + test "{var:3}" values "val" + test "{var:30}" values "value" + test "{list}" values "red,green,blue" + test "{list*}" values "red,green,blue" + test "{keys}" values "semi,%3B,dot,.,comma,%2C" + test "{keys*}" values "semi=%3B,dot=.,comma=%2C" + + label "subsection 3" $ do + test "{+var}" values "value" + test "{+hello}" values "Hello%20World!" + test "{+half}" values "50%25" + test "{base}index" values "http%3A%2F%2Fexample.com%2Fhome%2Findex" + test "{+base}index" values "http://example.com/home/index" + test "O{+empty}X" values "OX" + test "O{+undef}X" values "OX" + test "{+path}/here" values "/foo/bar/here" + test "here?ref={+path}" values "here?ref=/foo/bar" + test "up{+path}{var}/here" values "up/foo/barvalue/here" + test "{+x,hello,y}" values "1024,Hello%20World!,768" + test "{+path,x}/here" values "/foo/bar,1024/here" + test "{+path:6}/here" values "/foo/b/here" + test "{+list}" values "red,green,blue" + test "{+list*}" values "red,green,blue" + test "{+keys}" values "semi,;,dot,.,comma,," + test "{+keys*}" values "semi=;,dot=.,comma=," + + label "subsection 4" $ do + test "{#var}" values "#value" + test "{#hello}" values "#Hello%20World!" + test "{#half}" values "#50%25" + test "foo{#empty}" values "foo#" + test "foo{#undef}" values "foo" + test "{#x,hello,y}" values "#1024,Hello%20World!,768" + test "{#path,x}/here" values "#/foo/bar,1024/here" + test "{#path:6}/here" values "#/foo/b/here" + test "{#list}" values "#red,green,blue" + test "{#list*}" values "#red,green,blue" + test "{#keys}" values "#semi,;,dot,.,comma,," + test "{#keys*}" values "#semi=;,dot=.,comma=," + + label "subsection 5" $ do + test "{.who}" values ".fred" + test "{.who,who}" values ".fred.fred" + test "{.half,who}" values ".50%25.fred" + test "www{.dom*}" values "www.example.com" + test "X{.var}" values "X.value" + test "X{.empty}" values "X." + test "X{.undef}" values "X" + test "X{.var:3}" values "X.val" + test "X{.list}" values "X.red,green,blue" + test "X{.list*}" values "X.red.green.blue" + test "X{.keys}" values "X.semi,%3B,dot,.,comma,%2C" + test "X{.keys*}" values "X.semi=%3B.dot=..comma=%2C" + test "X{.empty_keys}" values "X" + test "X{.empty_keys*}" values "X" + + label "subsection 6" $ do + test "{/who}" values "/fred" + test "{/who,who}" values "/fred/fred" + test "{/half,who}" values "/50%25/fred" + test "{/who,dub}" values "/fred/me%2Ftoo" + test "{/var}" values "/value" + test "{/var,empty}" values "/value/" + test "{/var,undef}" values "/value" + test "{/var,x}/here" values "/value/1024/here" + test "{/var:1,var}" values "/v/value" + test "{/list}" values "/red,green,blue" + test "{/list*}" values "/red/green/blue" + test "{/list*,path:4}" values "/red/green/blue/%2Ffoo" + test "{/keys}" values "/semi,%3B,dot,.,comma,%2C" + test "{/keys*}" values "/semi=%3B/dot=./comma=%2C" + + label "subsection 7" $ do + test "{;who}" values ";who=fred" + test "{;half}" values ";half=50%25" + test "{;empty}" values ";empty" + test "{;v,empty,who}" values ";v=6;empty;who=fred" + test "{;v,bar,who}" values ";v=6;who=fred" + test "{;x,y}" values ";x=1024;y=768" + test "{;x,y,empty}" values ";x=1024;y=768;empty" + test "{;x,y,undef}" values ";x=1024;y=768" + test "{;hello:5}" values ";hello=Hello" + test "{;list}" values ";list=red,green,blue" + test "{;list*}" values ";list=red;list=green;list=blue" + test "{;keys}" values ";keys=semi,%3B,dot,.,comma,%2C" + test "{;keys*}" values ";semi=%3B;dot=.;comma=%2C" + + label "subsection 8" $ do + test "{?who}" values "?who=fred" + test "{?half}" values "?half=50%25" + test "{?x,y}" values "?x=1024&y=768" + test "{?x,y,empty}" values "?x=1024&y=768&empty=" + test "{?x,y,undef}" values "?x=1024&y=768" + test "{?var:3}" values "?var=val" + test "{?list}" values "?list=red,green,blue" + test "{?list*}" values "?list=red&list=green&list=blue" + test "{?keys}" values "?keys=semi,%3B,dot,.,comma,%2C" + test "{?keys*}" values "?semi=%3B&dot=.&comma=%2C" + + label "subsection 9" $ do + test "{&who}" values "&who=fred" + test "{&half}" values "&half=50%25" + test "?fixed=yes{&x}" values "?fixed=yes&x=1024" + test "{&x,y,empty}" values "&x=1024&y=768&empty=" + test "{&x,y,undef}" values "&x=1024&y=768" + test "{&var:3}" values "&var=val" + test "{&list}" values "&list=red,green,blue" + test "{&list*}" values "&list=red&list=green&list=blue" + test "{&keys}" values "&keys=semi,%3B,dot,.,comma,%2C" + test "{&keys*}" values "&semi=%3B&dot=.&comma=%2C" + + label "handles simple expansion" $ do + test "{a}" [] "" + test "{a}" ["a" =: emptyList] "" + test "{a}" ["a" =: emptyDictionary] "" + test "{a}" ["a" =: ""] "" + test "{a}" ["a" =: "A"] "A" + test "{a}" ["a" =: "~"] "~" + test "{a}" ["a" =: "%"] "%25" + test "{a}" ["a" =: "?"] "%3F" + test "{a}" ["a" =: "&"] "%26" + test "{a}" ["a" =: "\xa0"] "%C2%A0" + test "{a}" ["a" =: "\xd7ff"] "%ED%9F%BF" + test "{a}" ["a" =: "\x10000"] "%F0%90%80%80" + test "{a}" ["a" =: ["A"]] "A" + test "{a}" ["a" =: ["A", "B"]] "A,B" + test "{a}" ["a" =: ["%"]] "%25" + test "{a}" ["a" =: ["\xa0"]] "%C2%A0" + test "{a}" ["a" =: ["A" =: "1"]] "A,1" + test "{a}" ["a" =: ["A" =: "1", "B" =: "2"]] "A,1,B,2" + test "{a}" ["a" =: ["A" =: "%"]] "A,%25" + test "{a}" ["a" =: ["A" =: "\xa0"]] "A,%C2%A0" + test "{a}" ["a" =: ["%" =: "1"]] "%25,1" + test "{a*}" [] "" + test "{a*}" ["a" =: ""] "" + test "{a*}" ["a" =: "A"] "A" + test "{a*}" ["a" =: emptyList] "" + test "{a*}" ["a" =: ["A"]] "A" + test "{a*}" ["a" =: ["A", "B"]] "A,B" + test "{a*}" ["a" =: emptyDictionary] "" + test "{a*}" ["a" =: ["A" =: "1"]] "A=1" + test "{a*}" ["a" =: ["A" =: "1", "B" =: "2"]] "A=1,B=2" + test "{a:1}" [] "" + test "{a:1}" ["a" =: ""] "" + test "{a:1}" ["a" =: "A"] "A" + test "{a:1}" ["a" =: "AB"] "A" + test "{a:1}" ["a" =: "%B"] "%25" + test "{a:1}" ["a" =: "\xa0\&B"] "%C2%A0" + test "{a:1}" ["a" =: "\xd7ff\&B"] "%ED%9F%BF" + test "{a:1}" ["a" =: "\x10000\&B"] "%F0%90%80%80" + test "{a:1}" ["a" =: emptyList] "" + test "{a:1}" ["a" =: ["AB"]] "AB" + test "{a:1}" ["a" =: ["AB", "CD"]] "AB,CD" + test "{a:1}" ["a" =: emptyDictionary] "" + test "{a:1}" ["a" =: ["AB" =: "12"]] "AB,12" + test "{a:1}" ["a" =: ["AB" =: "12", "CD" =: "34"]] "AB,12,CD,34" + test "{a,a}" [] "" + test "{a,a}" ["a" =: emptyList] "" + test "{a,a}" ["a" =: emptyDictionary] "" + test "{a,a}" ["a" =: ""] "," + test "{a,b}" ["a" =: ""] "" + test "{a,b}" ["b" =: ""] "" + test "{%aa}" ["%aa" =: "A"] "A" + test "{%aa}" ["%aa" =: ["A", "B"]] "A,B" + test "{%aa}" ["%aa" =: ["A" =: "1", "B" =: "2"]] "A,1,B,2" + test "{%aa*}" ["%aa" =: "A"] "A" + test "{%aa*}" ["%aa" =: ["A", "B"]] "A,B" + test "{%aa*}" ["%aa" =: ["A" =: "1", "B" =: "2"]] "A=1,B=2" + + label "handles reserved expansion" $ do + test "{+a}" [] "" + test "{+a}" ["a" =: emptyList] "" + test "{+a}" ["a" =: emptyDictionary] "" + test "{+a}" ["a" =: ""] "" + test "{+a}" ["a" =: "A"] "A" + test "{+a}" ["a" =: "~"] "~" + test "{+a}" ["a" =: "%"] "%25" + test "{+a}" ["a" =: "?"] "?" + test "{+a}" ["a" =: "&"] "&" + test "{+a}" ["a" =: "\xa0"] "%C2%A0" + test "{+a}" ["a" =: "\xd7ff"] "%ED%9F%BF" + test "{+a}" ["a" =: "\x10000"] "%F0%90%80%80" + test "{+a}" ["a" =: ["A"]] "A" + test "{+a}" ["a" =: ["A", "B"]] "A,B" + test "{+a}" ["a" =: ["%"]] "%25" + test "{+a}" ["a" =: ["\xa0"]] "%C2%A0" + test "{+a}" ["a" =: ["A" =: "1"]] "A,1" + test "{+a}" ["a" =: ["A" =: "1", "B" =: "2"]] "A,1,B,2" + test "{+a}" ["a" =: ["A" =: "%"]] "A,%25" + test "{+a}" ["a" =: ["A" =: "\xa0"]] "A,%C2%A0" + test "{+a}" ["a" =: ["%" =: "1"]] "%25,1" + test "{+a*}" [] "" + test "{+a*}" ["a" =: ""] "" + test "{+a*}" ["a" =: "A"] "A" + test "{+a*}" ["a" =: emptyList] "" + test "{+a*}" ["a" =: ["A"]] "A" + test "{+a*}" ["a" =: ["A", "B"]] "A,B" + test "{+a*}" ["a" =: emptyDictionary] "" + test "{+a*}" ["a" =: ["A" =: "1"]] "A=1" + test "{+a*}" ["a" =: ["A" =: "1", "B" =: "2"]] "A=1,B=2" + test "{+a:1}" [] "" + test "{+a:1}" ["a" =: ""] "" + test "{+a:1}" ["a" =: "A"] "A" + test "{+a:1}" ["a" =: "AB"] "A" + test "{+a:1}" ["a" =: "%B"] "%25" + test "{+a:1}" ["a" =: "\xa0\&B"] "%C2%A0" + test "{+a:1}" ["a" =: "\xd7ff\&B"] "%ED%9F%BF" + test "{+a:1}" ["a" =: "\x10000\&B"] "%F0%90%80%80" + test "{+a:1}" ["a" =: emptyList] "" + test "{+a:1}" ["a" =: ["AB"]] "AB" + test "{+a:1}" ["a" =: ["AB", "CD"]] "AB,CD" + test "{+a:1}" ["a" =: emptyDictionary] "" + test "{+a:1}" ["a" =: ["AB" =: "12"]] "AB,12" + test "{+a:1}" ["a" =: ["AB" =: "12", "CD" =: "34"]] "AB,12,CD,34" + test "{+a,a}" [] "" + test "{+a,a}" ["a" =: emptyList] "" + test "{+a,a}" ["a" =: emptyDictionary] "" + test "{+a,a}" ["a" =: ""] "," + test "{+a,b}" ["a" =: ""] "" + test "{+a,b}" ["b" =: ""] "" + test "{+%aa}" ["%aa" =: "A"] "A" + test "{+%aa}" ["%aa" =: ["A", "B"]] "A,B" + test "{+%aa}" ["%aa" =: ["A" =: "1", "B" =: "2"]] "A,1,B,2" + test "{+%aa*}" ["%aa" =: "A"] "A" + test "{+%aa*}" ["%aa" =: ["A", "B"]] "A,B" + test "{+%aa*}" ["%aa" =: ["A" =: "1", "B" =: "2"]] "A=1,B=2" + + label "handles fragment expansion" $ do + test "{#a}" [] "" + test "{#a}" ["a" =: emptyList] "" + test "{#a}" ["a" =: emptyDictionary] "" + test "{#a}" ["a" =: ""] "#" + test "{#a}" ["a" =: "A"] "#A" + test "{#a}" ["a" =: "~"] "#~" + test "{#a}" ["a" =: "%"] "#%25" + test "{#a}" ["a" =: "?"] "#?" + test "{#a}" ["a" =: "&"] "#&" + test "{#a}" ["a" =: "\xa0"] "#%C2%A0" + test "{#a}" ["a" =: "\xd7ff"] "#%ED%9F%BF" + test "{#a}" ["a" =: "\x10000"] "#%F0%90%80%80" + test "{#a}" ["a" =: ["A"]] "#A" + test "{#a}" ["a" =: ["A", "B"]] "#A,B" + test "{#a}" ["a" =: ["%"]] "#%25" + test "{#a}" ["a" =: ["\xa0"]] "#%C2%A0" + test "{#a}" ["a" =: ["A" =: "1"]] "#A,1" + test "{#a}" ["a" =: ["A" =: "1", "B" =: "2"]] "#A,1,B,2" + test "{#a}" ["a" =: ["A" =: "%"]] "#A,%25" + test "{#a}" ["a" =: ["A" =: "\xa0"]] "#A,%C2%A0" + test "{#a}" ["a" =: ["%" =: "1"]] "#%25,1" + test "{#a*}" [] "" + test "{#a*}" ["a" =: ""] "#" + test "{#a*}" ["a" =: "A"] "#A" + test "{#a*}" ["a" =: emptyList] "" + test "{#a*}" ["a" =: ["A"]] "#A" + test "{#a*}" ["a" =: ["A", "B"]] "#A,B" + test "{#a*}" ["a" =: emptyDictionary] "" + test "{#a*}" ["a" =: ["A" =: "1"]] "#A=1" + test "{#a*}" ["a" =: ["A" =: "1", "B" =: "2"]] "#A=1,B=2" + test "{#a:1}" [] "" + test "{#a:1}" ["a" =: ""] "#" + test "{#a:1}" ["a" =: "A"] "#A" + test "{#a:1}" ["a" =: "AB"] "#A" + test "{#a:1}" ["a" =: "%B"] "#%25" + test "{#a:1}" ["a" =: "\xa0\&B"] "#%C2%A0" + test "{#a:1}" ["a" =: "\xd7ff\&B"] "#%ED%9F%BF" + test "{#a:1}" ["a" =: "\x10000\&B"] "#%F0%90%80%80" + test "{#a:1}" ["a" =: emptyList] "" + test "{#a:1}" ["a" =: ["AB"]] "#AB" + test "{#a:1}" ["a" =: ["AB", "CD"]] "#AB,CD" + test "{#a:1}" ["a" =: emptyDictionary] "" + test "{#a:1}" ["a" =: ["AB" =: "12"]] "#AB,12" + test "{#a:1}" ["a" =: ["AB" =: "12", "CD" =: "34"]] "#AB,12,CD,34" + test "{#a,a}" [] "" + test "{#a,a}" ["a" =: emptyList] "" + test "{#a,a}" ["a" =: emptyDictionary] "" + test "{#a,a}" ["a" =: ""] "#," + test "{#a,b}" ["a" =: ""] "#" + test "{#a,b}" ["b" =: ""] "#" + test "{#%aa}" ["%aa" =: "A"] "#A" + test "{#%aa}" ["%aa" =: ["A", "B"]] "#A,B" + test "{#%aa}" ["%aa" =: ["A" =: "1", "B" =: "2"]] "#A,1,B,2" + test "{#%aa*}" ["%aa" =: "A"] "#A" + test "{#%aa*}" ["%aa" =: ["A", "B"]] "#A,B" + test "{#%aa*}" ["%aa" =: ["A" =: "1", "B" =: "2"]] "#A=1,B=2" + + label "handles label expansion" $ do + test "{.a}" [] "" + test "{.a}" ["a" =: emptyList] "" + test "{.a}" ["a" =: emptyDictionary] "" + test "{.a}" ["a" =: ""] "." + test "{.a}" ["a" =: "A"] ".A" + test "{.a}" ["a" =: "~"] ".~" + test "{.a}" ["a" =: "%"] ".%25" + test "{.a}" ["a" =: "?"] ".%3F" + test "{.a}" ["a" =: "&"] ".%26" + test "{.a}" ["a" =: "\xa0"] ".%C2%A0" + test "{.a}" ["a" =: "\xd7ff"] ".%ED%9F%BF" + test "{.a}" ["a" =: "\x10000"] ".%F0%90%80%80" + test "{.a}" ["a" =: ["A"]] ".A" + test "{.a}" ["a" =: ["A", "B"]] ".A,B" + test "{.a}" ["a" =: ["%"]] ".%25" + test "{.a}" ["a" =: ["\xa0"]] ".%C2%A0" + test "{.a}" ["a" =: ["A" =: "1"]] ".A,1" + test "{.a}" ["a" =: ["A" =: "1", "B" =: "2"]] ".A,1,B,2" + test "{.a}" ["a" =: ["A" =: "%"]] ".A,%25" + test "{.a}" ["a" =: ["A" =: "\xa0"]] ".A,%C2%A0" + test "{.a}" ["a" =: ["%" =: "1"]] ".%25,1" + test "{.a*}" [] "" + test "{.a*}" ["a" =: ""] "." + test "{.a*}" ["a" =: "A"] ".A" + test "{.a*}" ["a" =: emptyList] "" + test "{.a*}" ["a" =: ["A"]] ".A" + test "{.a*}" ["a" =: ["A", "B"]] ".A.B" + test "{.a*}" ["a" =: emptyDictionary] "" + test "{.a*}" ["a" =: ["A" =: "1"]] ".A=1" + test "{.a*}" ["a" =: ["A" =: "1", "B" =: "2"]] ".A=1.B=2" + test "{.a:1}" [] "" + test "{.a:1}" ["a" =: ""] "." + test "{.a:1}" ["a" =: "A"] ".A" + test "{.a:1}" ["a" =: "AB"] ".A" + test "{.a:1}" ["a" =: "%B"] ".%25" + test "{.a:1}" ["a" =: "\xa0\&B"] ".%C2%A0" + test "{.a:1}" ["a" =: "\xd7ff\&B"] ".%ED%9F%BF" + test "{.a:1}" ["a" =: "\x10000\&B"] ".%F0%90%80%80" + test "{.a:1}" ["a" =: emptyList] "" + test "{.a:1}" ["a" =: ["AB"]] ".AB" + test "{.a:1}" ["a" =: ["AB", "CD"]] ".AB,CD" + test "{.a:1}" ["a" =: emptyDictionary] "" + test "{.a:1}" ["a" =: ["AB" =: "12"]] ".AB,12" + test "{.a:1}" ["a" =: ["AB" =: "12", "CD" =: "34"]] ".AB,12,CD,34" + test "{.a,a}" [] "" + test "{.a,a}" ["a" =: emptyList] "" + test "{.a,a}" ["a" =: emptyDictionary] "" + test "{.a,a}" ["a" =: ""] ".." + test "{.a,b}" ["a" =: ""] "." + test "{.a,b}" ["b" =: ""] "." + test "{.%aa}" ["%aa" =: "A"] ".A" + test "{.%aa}" ["%aa" =: ["A", "B"]] ".A,B" + test "{.%aa}" ["%aa" =: ["A" =: "1", "B" =: "2"]] ".A,1,B,2" + test "{.%aa*}" ["%aa" =: "A"] ".A" + test "{.%aa*}" ["%aa" =: ["A", "B"]] ".A.B" + test "{.%aa*}" ["%aa" =: ["A" =: "1", "B" =: "2"]] ".A=1.B=2" + + label "handles segment expansion" $ do + test "{/a}" [] "" + test "{/a}" ["a" =: emptyList] "" + test "{/a}" ["a" =: emptyDictionary] "" + test "{/a}" ["a" =: ""] "/" + test "{/a}" ["a" =: "A"] "/A" + test "{/a}" ["a" =: "~"] "/~" + test "{/a}" ["a" =: "%"] "/%25" + test "{/a}" ["a" =: "?"] "/%3F" + test "{/a}" ["a" =: "&"] "/%26" + test "{/a}" ["a" =: "\xa0"] "/%C2%A0" + test "{/a}" ["a" =: "\xd7ff"] "/%ED%9F%BF" + test "{/a}" ["a" =: "\x10000"] "/%F0%90%80%80" + test "{/a}" ["a" =: ["A"]] "/A" + test "{/a}" ["a" =: ["A", "B"]] "/A,B" + test "{/a}" ["a" =: ["%"]] "/%25" + test "{/a}" ["a" =: ["\xa0"]] "/%C2%A0" + test "{/a}" ["a" =: ["A" =: "1"]] "/A,1" + test "{/a}" ["a" =: ["A" =: "1", "B" =: "2"]] "/A,1,B,2" + test "{/a}" ["a" =: ["A" =: "%"]] "/A,%25" + test "{/a}" ["a" =: ["A" =: "\xa0"]] "/A,%C2%A0" + test "{/a}" ["a" =: ["%" =: "1"]] "/%25,1" + test "{/a*}" [] "" + test "{/a*}" ["a" =: ""] "/" + test "{/a*}" ["a" =: "A"] "/A" + test "{/a*}" ["a" =: emptyList] "" + test "{/a*}" ["a" =: ["A"]] "/A" + test "{/a*}" ["a" =: ["A", "B"]] "/A/B" + test "{/a*}" ["a" =: emptyDictionary] "" + test "{/a*}" ["a" =: ["A" =: "1"]] "/A=1" + test "{/a*}" ["a" =: ["A" =: "1", "B" =: "2"]] "/A=1/B=2" + test "{/a:1}" [] "" + test "{/a:1}" ["a" =: ""] "/" + test "{/a:1}" ["a" =: "A"] "/A" + test "{/a:1}" ["a" =: "AB"] "/A" + test "{/a:1}" ["a" =: "%B"] "/%25" + test "{/a:1}" ["a" =: "\xa0\&B"] "/%C2%A0" + test "{/a:1}" ["a" =: "\xd7ff\&B"] "/%ED%9F%BF" + test "{/a:1}" ["a" =: "\x10000\&B"] "/%F0%90%80%80" + test "{/a:1}" ["a" =: emptyList] "" + test "{/a:1}" ["a" =: ["AB"]] "/AB" + test "{/a:1}" ["a" =: ["AB", "CD"]] "/AB,CD" + test "{/a:1}" ["a" =: emptyDictionary] "" + test "{/a:1}" ["a" =: ["AB" =: "12"]] "/AB,12" + test "{/a:1}" ["a" =: ["AB" =: "12", "CD" =: "34"]] "/AB,12,CD,34" + test "{/a,a}" [] "" + test "{/a,a}" ["a" =: emptyList] "" + test "{/a,a}" ["a" =: emptyDictionary] "" + test "{/a,a}" ["a" =: ""] "//" + test "{/a,b}" ["a" =: ""] "/" + test "{/a,b}" ["b" =: ""] "/" + test "{/%aa}" ["%aa" =: "A"] "/A" + test "{/%aa}" ["%aa" =: ["A", "B"]] "/A,B" + test "{/%aa}" ["%aa" =: ["A" =: "1", "B" =: "2"]] "/A,1,B,2" + test "{/%aa*}" ["%aa" =: "A"] "/A" + test "{/%aa*}" ["%aa" =: ["A", "B"]] "/A/B" + test "{/%aa*}" ["%aa" =: ["A" =: "1", "B" =: "2"]] "/A=1/B=2" + + label "handles parameter expansion" $ do + test "{;a}" [] "" + test "{;a}" ["a" =: emptyList] "" + test "{;a}" ["a" =: emptyDictionary] "" + test "{;a}" ["a" =: ""] ";a" + test "{;a}" ["a" =: "A"] ";a=A" + test "{;a}" ["a" =: "~"] ";a=~" + test "{;a}" ["a" =: "%"] ";a=%25" + test "{;a}" ["a" =: "?"] ";a=%3F" + test "{;a}" ["a" =: "&"] ";a=%26" + test "{;a}" ["a" =: "\xa0"] ";a=%C2%A0" + test "{;a}" ["a" =: "\xd7ff"] ";a=%ED%9F%BF" + test "{;a}" ["a" =: "\x10000"] ";a=%F0%90%80%80" + test "{;a}" ["a" =: ["A"]] ";a=A" + test "{;a}" ["a" =: ["A", "B"]] ";a=A,B" + test "{;a}" ["a" =: ["%"]] ";a=%25" + test "{;a}" ["a" =: ["\xa0"]] ";a=%C2%A0" + test "{;a}" ["a" =: ["A" =: "1"]] ";a=A,1" + test "{;a}" ["a" =: ["A" =: "1", "B" =: "2"]] ";a=A,1,B,2" + test "{;a}" ["a" =: ["A" =: "%"]] ";a=A,%25" + test "{;a}" ["a" =: ["A" =: "\xa0"]] ";a=A,%C2%A0" + test "{;a}" ["a" =: ["%" =: "1"]] ";a=%25,1" + test "{;a*}" [] "" + test "{;a*}" ["a" =: ""] ";a" + test "{;a*}" ["a" =: "A"] ";a=A" + test "{;a*}" ["a" =: emptyList] "" + test "{;a*}" ["a" =: ["A"]] ";a=A" + test "{;a*}" ["a" =: ["A", "B"]] ";a=A;a=B" + test "{;a*}" ["a" =: emptyDictionary] "" + test "{;a*}" ["a" =: ["A" =: "1"]] ";A=1" + test "{;a*}" ["a" =: ["A" =: "1", "B" =: "2"]] ";A=1;B=2" + test "{;a:1}" [] "" + test "{;a:1}" ["a" =: ""] ";a" + test "{;a:1}" ["a" =: "A"] ";a=A" + test "{;a:1}" ["a" =: "AB"] ";a=A" + test "{;a:1}" ["a" =: "%B"] ";a=%25" + test "{;a:1}" ["a" =: "\xa0\&B"] ";a=%C2%A0" + test "{;a:1}" ["a" =: "\xd7ff\&B"] ";a=%ED%9F%BF" + test "{;a:1}" ["a" =: "\x10000\&B"] ";a=%F0%90%80%80" + test "{;a:1}" ["a" =: emptyList] "" + test "{;a:1}" ["a" =: ["AB"]] ";a=AB" + test "{;a:1}" ["a" =: ["AB", "CD"]] ";a=AB,CD" + test "{;a:1}" ["a" =: emptyDictionary] "" + test "{;a:1}" ["a" =: ["AB" =: "12"]] ";a=AB,12" + test "{;a:1}" ["a" =: ["AB" =: "12", "CD" =: "34"]] ";a=AB,12,CD,34" + test "{;a,a}" [] "" + test "{;a,a}" ["a" =: emptyList] "" + test "{;a,a}" ["a" =: emptyDictionary] "" + test "{;a,a}" ["a" =: ""] ";a;a" + test "{;a,b}" ["a" =: ""] ";a" + test "{;a,b}" ["b" =: ""] ";b" + test "{;%aa}" ["%aa" =: "A"] ";%aa=A" + test "{;%aa}" ["%aa" =: ["A", "B"]] ";%aa=A,B" + test "{;%aa}" ["%aa" =: ["A" =: "1", "B" =: "2"]] ";%aa=A,1,B,2" + test "{;%aa*}" ["%aa" =: "A"] ";%aa=A" + test "{;%aa*}" ["%aa" =: ["A", "B"]] ";%aa=A;%aa=B" + test "{;%aa*}" ["%aa" =: ["A" =: "1", "B" =: "2"]] ";A=1;B=2" + + label "handles query expansion" $ do + test "{?a}" [] "" + test "{?a}" ["a" =: emptyList] "" + test "{?a}" ["a" =: emptyDictionary] "" + test "{?a}" ["a" =: ""] "?a=" + test "{?a}" ["a" =: "A"] "?a=A" + test "{?a}" ["a" =: "~"] "?a=~" + test "{?a}" ["a" =: "%"] "?a=%25" + test "{?a}" ["a" =: "?"] "?a=%3F" + test "{?a}" ["a" =: "&"] "?a=%26" + test "{?a}" ["a" =: "\xa0"] "?a=%C2%A0" + test "{?a}" ["a" =: "\xd7ff"] "?a=%ED%9F%BF" + test "{?a}" ["a" =: "\x10000"] "?a=%F0%90%80%80" + test "{?a}" ["a" =: ["A"]] "?a=A" + test "{?a}" ["a" =: ["A", "B"]] "?a=A,B" + test "{?a}" ["a" =: ["%"]] "?a=%25" + test "{?a}" ["a" =: ["\xa0"]] "?a=%C2%A0" + test "{?a}" ["a" =: ["A" =: "1"]] "?a=A,1" + test "{?a}" ["a" =: ["A" =: "1", "B" =: "2"]] "?a=A,1,B,2" + test "{?a}" ["a" =: ["A" =: "%"]] "?a=A,%25" + test "{?a}" ["a" =: ["A" =: "\xa0"]] "?a=A,%C2%A0" + test "{?a}" ["a" =: ["%" =: "1"]] "?a=%25,1" + test "{?a*}" [] "" + test "{?a*}" ["a" =: ""] "?a=" + test "{?a*}" ["a" =: "A"] "?a=A" + test "{?a*}" ["a" =: emptyList] "" + test "{?a*}" ["a" =: ["A"]] "?a=A" + test "{?a*}" ["a" =: ["A", "B"]] "?a=A&a=B" + test "{?a*}" ["a" =: emptyDictionary] "" + test "{?a*}" ["a" =: ["A" =: "1"]] "?A=1" + test "{?a*}" ["a" =: ["A" =: "1", "B" =: "2"]] "?A=1&B=2" + test "{?a:1}" [] "" + test "{?a:1}" ["a" =: ""] "?a=" + test "{?a:1}" ["a" =: "A"] "?a=A" + test "{?a:1}" ["a" =: "AB"] "?a=A" + test "{?a:1}" ["a" =: "%B"] "?a=%25" + test "{?a:1}" ["a" =: "\xa0\&B"] "?a=%C2%A0" + test "{?a:1}" ["a" =: "\xd7ff\&B"] "?a=%ED%9F%BF" + test "{?a:1}" ["a" =: "\x10000\&B"] "?a=%F0%90%80%80" + test "{?a:1}" ["a" =: emptyList] "" + test "{?a:1}" ["a" =: ["AB"]] "?a=AB" + test "{?a:1}" ["a" =: ["AB", "CD"]] "?a=AB,CD" + test "{?a:1}" ["a" =: emptyDictionary] "" + test "{?a:1}" ["a" =: ["AB" =: "12"]] "?a=AB,12" + test "{?a:1}" ["a" =: ["AB" =: "12", "CD" =: "34"]] "?a=AB,12,CD,34" + test "{?a,a}" [] "" + test "{?a,a}" ["a" =: emptyList] "" + test "{?a,a}" ["a" =: emptyDictionary] "" + test "{?a,a}" ["a" =: ""] "?a=&a=" + test "{?a,b}" ["a" =: ""] "?a=" + test "{?a,b}" ["b" =: ""] "?b=" + test "{?%aa}" ["%aa" =: "A"] "?%aa=A" + test "{?%aa}" ["%aa" =: ["A", "B"]] "?%aa=A,B" + test "{?%aa}" ["%aa" =: ["A" =: "1", "B" =: "2"]] "?%aa=A,1,B,2" + test "{?%aa*}" ["%aa" =: "A"] "?%aa=A" + test "{?%aa*}" ["%aa" =: ["A", "B"]] "?%aa=A&%aa=B" + test "{?%aa*}" ["%aa" =: ["A" =: "1", "B" =: "2"]] "?A=1&B=2" + + label "handles continuation expansion" $ do + test "{&a}" [] "" + test "{&a}" ["a" =: emptyList] "" + test "{&a}" ["a" =: emptyDictionary] "" + test "{&a}" ["a" =: ""] "&a=" + test "{&a}" ["a" =: "A"] "&a=A" + test "{&a}" ["a" =: "~"] "&a=~" + test "{&a}" ["a" =: "%"] "&a=%25" + test "{&a}" ["a" =: "?"] "&a=%3F" + test "{&a}" ["a" =: "&"] "&a=%26" + test "{&a}" ["a" =: "\xa0"] "&a=%C2%A0" + test "{&a}" ["a" =: "\xd7ff"] "&a=%ED%9F%BF" + test "{&a}" ["a" =: "\x10000"] "&a=%F0%90%80%80" + test "{&a}" ["a" =: ["A"]] "&a=A" + test "{&a}" ["a" =: ["A", "B"]] "&a=A,B" + test "{&a}" ["a" =: ["%"]] "&a=%25" + test "{&a}" ["a" =: ["\xa0"]] "&a=%C2%A0" + test "{&a}" ["a" =: ["A" =: "1"]] "&a=A,1" + test "{&a}" ["a" =: ["A" =: "1", "B" =: "2"]] "&a=A,1,B,2" + test "{&a}" ["a" =: ["A" =: "%"]] "&a=A,%25" + test "{&a}" ["a" =: ["A" =: "\xa0"]] "&a=A,%C2%A0" + test "{&a}" ["a" =: ["%" =: "1"]] "&a=%25,1" + test "{&a*}" [] "" + test "{&a*}" ["a" =: ""] "&a=" + test "{&a*}" ["a" =: "A"] "&a=A" + test "{&a*}" ["a" =: emptyList] "" + test "{&a*}" ["a" =: ["A"]] "&a=A" + test "{&a*}" ["a" =: ["A", "B"]] "&a=A&a=B" + test "{&a*}" ["a" =: emptyDictionary] "" + test "{&a*}" ["a" =: ["A" =: "1"]] "&A=1" + test "{&a*}" ["a" =: ["A" =: "1", "B" =: "2"]] "&A=1&B=2" + test "{&a:1}" [] "" + test "{&a:1}" ["a" =: ""] "&a=" + test "{&a:1}" ["a" =: "A"] "&a=A" + test "{&a:1}" ["a" =: "AB"] "&a=A" + test "{&a:1}" ["a" =: "%B"] "&a=%25" + test "{&a:1}" ["a" =: "\xa0\&B"] "&a=%C2%A0" + test "{&a:1}" ["a" =: "\xd7ff\&B"] "&a=%ED%9F%BF" + test "{&a:1}" ["a" =: "\x10000\&B"] "&a=%F0%90%80%80" + test "{&a:1}" ["a" =: emptyList] "" + test "{&a:1}" ["a" =: ["AB"]] "&a=AB" + test "{&a:1}" ["a" =: ["AB", "CD"]] "&a=AB,CD" + test "{&a:1}" ["a" =: emptyDictionary] "" + test "{&a:1}" ["a" =: ["AB" =: "12"]] "&a=AB,12" + test "{&a:1}" ["a" =: ["AB" =: "12", "CD" =: "34"]] "&a=AB,12,CD,34" + test "{&a,a}" [] "" + test "{&a,a}" ["a" =: emptyList] "" + test "{&a,a}" ["a" =: emptyDictionary] "" + test "{&a,a}" ["a" =: ""] "&a=&a=" + test "{&a,b}" ["a" =: ""] "&a=" + test "{&a,b}" ["b" =: ""] "&b=" + test "{&%aa}" ["%aa" =: "A"] "&%aa=A" + test "{&%aa}" ["%aa" =: ["A", "B"]] "&%aa=A,B" + test "{&%aa}" ["%aa" =: ["A" =: "1", "B" =: "2"]] "&%aa=A,1,B,2" + test "{&%aa*}" ["%aa" =: "A"] "&%aa=A" + test "{&%aa*}" ["%aa" =: ["A", "B"]] "&%aa=A&%aa=B" + test "{&%aa*}" ["%aa" =: ["A" =: "1", "B" =: "2"]] "&A=1&B=2" + +runTests :: Writer.WriterT Test IO a -> IO () +runTests writer = do + tests <- Writer.execWriterT writer + counts <- Test.runTestTT $ unwrapTest tests + let + hasErrors = Test.errors counts /= 0 + hasFailures = Test.failures counts /= 0 + Monad.when (hasErrors || hasFailures) Exit.exitFailure + +label + :: Monad m + => String + -> Writer.WriterT Test m a + -> Writer.WriterT Test m a +label string = Writer.censor $ \tests -> Test $ string Test.~: tests + +test + :: (Stack.HasCallStack, Monad m) + => String + -> Values + -> Expected + -> Writer.WriterT Test m () +test input values output = do + let expand = Burrito.expand $ fmap (fmap unwrapValue) values + Writer.tell + . Test + $ input + Test.~: fmap expand (Burrito.parse input) + Test.~?= expectedToMaybe output + +newtype Test = Test + { unwrapTest :: Test.Test + } deriving (Show) + +instance Monoid Test where + mempty = Test $ Test.TestList [] + +instance Semigroup Test where + x <> y = Test . Test.TestList $ case (unwrapTest x, unwrapTest y) of + (Test.TestList t, Test.TestList u) -> t <> u + (Test.TestList t, u) -> t <> [u] + (t, Test.TestList u) -> t : u + (t, u) -> [t, u] + +instance Test.Testable Test where + test = unwrapTest + +data Expected + = Failure + | Success String + deriving (Eq, Show) + +instance String.IsString Expected where + fromString = Success + +expectedToMaybe :: Expected -> Maybe String +expectedToMaybe expected = case expected of + Failure -> Nothing + Success string -> Just string + +type Values = [(String, Value)] + +newtype Value = Value + { unwrapValue :: Burrito.Value + } deriving (Eq, Show) + +instance Exts.IsList Value where + type Item Value = Item + fromList items = + Value $ case Either.partitionEithers $ fmap unwrapItem items of + (strings, []) -> Burrito.listValue strings + ([], tuples) -> Burrito.dictionaryValue tuples + (_, _) -> error $ "fromList " <> show items <> " :: Value" + toList value = error $ "toList " <> show value + +instance String.IsString Value where + fromString = Value . Burrito.stringValue + +emptyList :: Value +emptyList = Value $ Burrito.listValue [] + +emptyDictionary :: Value +emptyDictionary = Value $ Burrito.dictionaryValue [] + +newtype Item = Item + { unwrapItem :: Either String (String, String) + } deriving (Eq, Show) + +instance String.IsString Item where + fromString = Item . Left + +class Pair a where + type K a + type V a + (=:) :: K a -> V a -> a + +instance Pair (a, b) where + type K (a, b) = a + type V (a, b) = b + (=:) = (,) + +instance Pair Item where + type K Item = String + type V Item = String + key =: value = Item $ Right (key, value)