diff --git a/src/Network/URI/Template.hs b/src/Network/URI/Template.hs --- a/src/Network/URI/Template.hs +++ b/src/Network/URI/Template.hs @@ -10,6 +10,7 @@ , ToTemplateValue(..) , AList(..) , TemplateString(..) + , Buildable(..) ) where import Network.URI.Template.Internal import Network.URI.Template.Parser diff --git a/src/Network/URI/Template/Internal.hs b/src/Network/URI/Template/Internal.hs --- a/src/Network/URI/Template/Internal.hs +++ b/src/Network/URI/Template/Internal.hs @@ -1,21 +1,78 @@ -{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} module Network.URI.Template.Internal where import Control.Monad.Writer.Strict +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB + import Data.DList hiding (map) import Data.List (intersperse) import Data.Maybe import Data.Monoid +import Data.Proxy import Network.HTTP.Base (urlEncode) import Network.URI.Template.Types -type StringBuilder = Writer (DList Char) +class Monoid (StringBuilder a) => Buildable a where + type StringBuilder a + build :: StringBuilder a -> a + addChar :: Proxy a -> Char -> StringBuilder a + addString :: Proxy a -> String -> StringBuilder a -addChar :: Char -> StringBuilder () -addChar = tell . singleton +instance Buildable String where + type StringBuilder String = DList Char + build = Data.DList.toList + addChar _ = singleton + addString _ = fromList -addString :: String -> StringBuilder () -addString = tell . fromList +instance Buildable BS.ByteString where + type StringBuilder BS.ByteString = BB.Builder + build = BL.toStrict . BB.toLazyByteString + addChar _ = BB.char8 + addString _ = BB.string8 +instance Buildable BL.ByteString where + type StringBuilder BL.ByteString = BB.Builder + build = BB.toLazyByteString + addChar _ = BB.char8 + addString _ = BB.string8 + +instance Buildable T.Text where + type StringBuilder T.Text = TB.Builder + build = TL.toStrict . TB.toLazyText + addChar _ = TB.singleton + addString _ = TB.fromString + +instance Buildable TL.Text where + type StringBuilder TL.Text = TB.Builder + build = TB.toLazyText + addChar _ = TB.singleton + addString _ = TB.fromString + +instance Buildable BB.Builder where + type StringBuilder BB.Builder = BB.Builder + build = id + addChar _ = BB.char8 + addString _ = BB.string8 + +instance Buildable TB.Builder where + type StringBuilder TB.Builder = TB.Builder + build = id + addChar _ = TB.singleton + addString _ = TB.fromString + +-- instance Buildable (Path, QueryParams, Hash) + data Allow = Unreserved | UnreservedOrReserved allowEncoder Unreserved = urlEncode @@ -50,36 +107,47 @@ templateValueIsEmpty (Associative s) = null s templateValueIsEmpty (List s) = null s -namePrefix :: ProcessingOptions -> String -> TemplateValue a -> StringBuilder () -namePrefix opts name val = do - addString name - if templateValueIsEmpty val - then maybe (return ()) addChar $ modifierIfEmpty opts - else addChar '=' +namePrefix :: forall str a. + (Buildable str) + => Proxy str -> ProcessingOptions -> String -> TemplateValue a -> StringBuilder str +namePrefix p opts name val = addString p name <> if templateValueIsEmpty val + then maybe mempty (addChar p) $ modifierIfEmpty opts + else addChar p '=' -processVariable :: Modifier -> Bool -> Variable -> WrappedValue -> StringBuilder () -processVariable m isFirst (Variable varName varMod) (WrappedValue val) = do - if isFirst - then maybe (return ()) addChar $ modifierPrefix settings - else addChar $ modifierSeparator settings - case varMod of - Normal -> do - when (modifierSupportsNamed settings) (namePrefix settings varName val) - unexploded - Explode -> exploded - (MaxLength l) -> do - when (modifierSupportsNamed settings) (namePrefix settings varName val) - unexploded +whenM :: Monoid m => Bool -> m -> m +whenM pred m = if pred then m else mempty + +processVariable + :: forall str. + (Buildable str) + => Proxy str -> Modifier -> Bool -> Variable -> WrappedValue -> StringBuilder str +processVariable p m isFirst (Variable varName varMod) (WrappedValue val) = + let prefix = maybe mempty (addChar p) $ modifierPrefix settings + separator = addChar p $ modifierSeparator settings + rest = case varMod of + Normal -> do + whenM + (modifierSupportsNamed settings) + (namePrefix p settings varName val) <> unexploded + Explode -> exploded + MaxLength l -> + whenM + (modifierSupportsNamed settings) + (namePrefix p settings varName val) <> unexploded + in (if isFirst then prefix else separator) <> rest where settings = options m - addEncodeString :: String -> StringBuilder () - addEncodeString = addString . (allowEncoder $ modifierAllow settings) + addEncodeString :: String -> StringBuilder str + addEncodeString = addString p . (allowEncoder $ modifierAllow settings) - sepByCommas = sequence_ . intersperse (addChar ',') + sepByCommas = mconcat . intersperse (addChar p ',') - associativeCommas :: (String -> String) -> (TemplateValue Single, TemplateValue Single) -> StringBuilder () - associativeCommas f (Single n, Single v) = addEncodeString n >> addChar ',' >> addEncodeString (f v) + associativeCommas :: (String -> String) -> (TemplateValue Single, TemplateValue Single) -> StringBuilder str + associativeCommas f (Single n, Single v) = + addEncodeString n <> + addChar p ',' <> + addEncodeString (f v) preprocess :: String -> String preprocess = case varMod of @@ -91,43 +159,57 @@ (List l) -> sepByCommas $ map (\(Single s) -> addEncodeString $ preprocess s) l (Single s) -> addEncodeString $ preprocess s - explodedAssociative :: (TemplateValue Single, TemplateValue Single) -> StringBuilder () - explodedAssociative (Single k, Single v) = do - addEncodeString k - addChar '=' - addEncodeString $ preprocess v + explodedAssociative :: (TemplateValue Single, TemplateValue Single) -> StringBuilder str + explodedAssociative (Single k, Single v) = + addEncodeString k <> + addChar p '=' <> + addEncodeString (preprocess v) - exploded :: StringBuilder () + exploded :: StringBuilder str exploded = case val of - (Single s) -> do - when (modifierSupportsNamed settings) (namePrefix settings varName val) - addEncodeString $ preprocess s - (Associative l) -> sequence_ $ intersperse (addChar $ modifierSeparator settings) $ map explodedAssociative l - (List l) -> sequence_ $ intersperse (addChar $ modifierSeparator settings) $ map (\(Single s) -> addEncodeString $ preprocess s) l + (Single s) -> whenM + (modifierSupportsNamed settings) + (namePrefix p settings varName val) <> addEncodeString (preprocess s) + (Associative l) -> + mconcat $ + intersperse (addChar p $ modifierSeparator settings) $ + map explodedAssociative l + (List l) -> + mconcat $ + intersperse (addChar p $ modifierSeparator settings) $ + map (\(Single s) -> + whenM + (modifierSupportsNamed settings) + (namePrefix p settings varName val) <> addEncodeString (preprocess s)) l -processVariables :: [(String, WrappedValue)] -> Modifier -> [Variable] -> StringBuilder () -processVariables env m vs = sequence_ $ processedVariables +processVariables :: forall str. + (Buildable str) + => Proxy str -> [(String, WrappedValue)] -> Modifier -> [Variable] -> StringBuilder str +processVariables p env m vs = mconcat processedVariables where findValue (Variable varName _) = lookup varName env nonEmptyVariables :: [(Variable, WrappedValue)] nonEmptyVariables = catMaybes $ map (\v -> fmap (\mv -> (v, mv)) $ findValue v) vs - processors :: [Variable -> WrappedValue -> StringBuilder ()] - processors = (processVariable m True) : repeat (processVariable m False) + processors :: [Variable -> WrappedValue -> StringBuilder str] + processors = (processVariable p m True) : repeat (processVariable p m False) - processedVariables :: [StringBuilder ()] + processedVariables :: [StringBuilder str] processedVariables = zipWith uncurry processors nonEmptyVariables -render :: UriTemplate -> [BoundValue] -> String +render :: (Buildable str) => UriTemplate -> [BoundValue] -> str render tpl env = render' tpl env -render' :: UriTemplate -> [BoundValue] -> String -render' tpl env = Data.DList.toList $ execWriter $ mapM_ go tpl +render' :: forall str. (Buildable str) => UriTemplate -> [BoundValue] -> str +render' tpl env = build $ mconcat $ map go tpl where - go :: TemplateSegment -> StringBuilder () - go (Literal s) = addString s - go (Embed m vs) = processVariables env m vs + p :: Proxy str + p = Proxy + + go :: TemplateSegment -> StringBuilder str + go (Literal s) = addString p s + go (Embed m vs) = processVariables p env m vs diff --git a/src/Network/URI/Template/Types.hs b/src/Network/URI/Template/Types.hs --- a/src/Network/URI/Template/Types.hs +++ b/src/Network/URI/Template/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE EmptyDataDecls, GADTs, FunctionalDependencies, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies, OverlappingInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE EmptyDataDecls, GADTs, FunctionalDependencies, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving #-} module Network.URI.Template.Types where import Control.Arrow import Data.Foldable as F @@ -67,6 +67,10 @@ instance ToTemplateValue TL.Text where type TemplateRep TL.Text = Single toTemplateValue = Single . TL.unpack + +instance (ToTemplateValue a, TemplateRep a ~ Single) => ToTemplateValue (Maybe a) where + type TemplateRep (Maybe a) = Single + toTemplateValue = maybe (Single "") toTemplateValue instance (ToTemplateValue k, (TemplateRep k) ~ Single, ToTemplateValue v, (TemplateRep v) ~ Single) => ToTemplateValue (HS.HashMap k v) where type TemplateRep (HS.HashMap k v) = Associative diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeApplications #-} module Main where import Control.Arrow import Control.Monad.Writer.Strict +import Data.String import Network.URI.Template.Parser import Network.URI.Template import Network.URI.Template.TH @@ -35,7 +36,19 @@ then exitFailure else exitSuccess where - testRun = runTestRegistry (parserTests >> quasiQuoterTests >> embedTests) + strEq = (@?=) @String + testRun = runTestRegistry $ do + parserTests + quasiQuoterTests strEq + embedTests + label "RFC example cases" $ 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 $ queryParams strEq parserTests = label "Parser Tests" $ suite $ do let foo = Variable "foo" Normal @@ -94,7 +107,8 @@ keys :: AList TemplateString TemplateString keys = AList [("semi", ";"), ("dot", "."), ("comma", ",")] -quasiQuoterTests = label "QuasiQuoter Tests" $ suite $ do +quasiQuoterTests :: (Eq 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") @@ -106,30 +120,35 @@ 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" $ test ([uri|{keys*}|] @?= "semi=%3B,dot=.,comma=%2C") + label "Explode Associative List Query Params" $ test ([uri|{?keys*}|] @?= "?semi=%3B&dot=.&comma=%2C") -unescaped = do +unescaped :: (Eq 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|{+list*}|] @?= "red,green,blue" [uri|{+keys}|] @?= "semi,;,dot,.,comma,," - [uri|{+keys}|] @?= "semi=;,dot=.,comma=," + [uri|{+keys*}|] @?= "semi=;,dot=.,comma=," -fragment = do +fragment :: (Eq 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 = test $ do +labelTests :: (Eq 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 = test $ do +pathTests :: (Eq 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" @@ -137,27 +156,26 @@ [uri|{/keys}|] @?= "/semi,%3B,dot,.,comma,%2C" [uri|{/keys*}|] @?= "/semi=%3B/dot=./comma=%2C" -pathParams = do +pathParams :: (Eq 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 = do - [uri|{?foo}|] @?= "?foo=1" - [uri|{?foo,bar}|] @?= "?foo=1&bar=2" - where - foo :: Int - foo = 1 - bar :: Int - bar = 2 +queryParams :: (Eq 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 = do - [uri|{&foo}|] @?= "&foo=1" - [uri|{&foo,bar}|] @?= "&foo=1&bar=2" - where - foo :: Int - foo = 1 - bar :: Int - bar = 2 +continuedQueryParams :: (Eq 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" diff --git a/uri-templater.cabal b/uri-templater.cabal --- a/uri-templater.cabal +++ b/uri-templater.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: uri-templater -version: 0.2.2.0 +version: 0.3.0.0 synopsis: Parsing & Quasiquoting for RFC 6570 URI Templates description: Parsing & Quasiquoting for RFC 6570 URI Templates homepage: https://github.com/iand675/uri-templater @@ -36,7 +36,8 @@ vector, containers, unordered-containers, - text + text, + bytestring hs-source-dirs: src test-suite test-uri-templates