module Network.URI.Template.Internal where
import Control.Monad.Writer.Strict
import Data.DList hiding (map)
import Data.List (intersperse)
import Data.Maybe
import Data.Monoid
import Network.HTTP.Base (urlEncode)
import Network.URI.Template.Types
type StringBuilder = Writer (DList Char)
addChar :: Char -> StringBuilder ()
addChar = tell . singleton
addString :: String -> StringBuilder ()
addString = tell . fromList
data Allow = Unreserved | UnreservedOrReserved
allowEncoder Unreserved = urlEncode
allowEncoder UnreservedOrReserved = id
data ProcessingOptions = ProcessingOptions
{ modifierPrefix :: Maybe Char
, modifierSeparator :: Char
, modifierSupportsNamed :: Bool
, modifierIfEmpty :: Maybe Char
, modifierAllow :: Allow
}
option :: Maybe Char -> Char -> Bool -> Maybe Char -> Allow -> ProcessingOptions
option = ProcessingOptions
options :: Modifier -> ProcessingOptions
options m = case m of
Simple -> option Nothing ',' False Nothing Unreserved
Reserved -> option Nothing ',' False Nothing UnreservedOrReserved
Label -> option (Just '.') '.' False Nothing Unreserved
PathSegment -> option (Just '/') '/' False Nothing Unreserved
PathParameter -> option (Just ';') ';' True Nothing Unreserved
Query -> option (Just '?') '&' True (Just '=') Unreserved
QueryContinuation -> option (Just '&') '&' True (Just '=') Unreserved
Fragment -> option (Just '#') ',' False Nothing UnreservedOrReserved
templateValueIsEmpty :: InternalTemplateValue -> Bool
templateValueIsEmpty (SingleVal s) = null s
templateValueIsEmpty (AssociativeVal s) = null s
templateValueIsEmpty (ListVal s) = null s
namePrefix :: ProcessingOptions -> String -> InternalTemplateValue -> StringBuilder ()
namePrefix opts name val = do
addString name
if templateValueIsEmpty val
then maybe (return ()) addChar $ modifierIfEmpty opts
else addChar '='
processVariable :: Modifier -> Bool -> Variable -> InternalTemplateValue -> StringBuilder ()
processVariable m isFirst (Variable varName varMod) 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)
censor (fromList . take l . toList) unexploded
where
settings = options m
addEncodeString = addString . (allowEncoder $ modifierAllow settings)
sepByCommas = sequence_ . intersperse (addChar ',')
associativeCommas (n, v) = addEncodeString n >> addChar ',' >> addEncodeString v
unexploded = case val of
(AssociativeVal l) -> sepByCommas $ map associativeCommas l
(ListVal l) -> sepByCommas $ map addEncodeString l
(SingleVal s) -> addEncodeString s
explodedAssociative (k, v) = do
addEncodeString k
addChar '='
addEncodeString v
exploded :: StringBuilder ()
exploded = case val of
(SingleVal s) -> do
when (modifierSupportsNamed settings) (namePrefix settings varName val)
addEncodeString s
(AssociativeVal l) -> sequence_ $ intersperse (addChar $ modifierSeparator settings) $ map explodedAssociative l
(ListVal l) -> sequence_ $ intersperse (addChar $ modifierSeparator settings) $ map addEncodeString l
processVariables :: [(String, InternalTemplateValue)] -> Modifier -> [Variable] -> StringBuilder ()
processVariables env m vs = sequence_ $ processedVariables
where
findValue (Variable varName _) = lookup varName env
nonEmptyVariables :: [(Variable, InternalTemplateValue)]
nonEmptyVariables = catMaybes $ map (\v -> fmap (\mv -> (v, mv)) $ findValue v) vs
processors :: [Variable -> InternalTemplateValue -> StringBuilder ()]
processors = (processVariable m True) : repeat (processVariable m False)
processedVariables :: [StringBuilder ()]
processedVariables = zipWith uncurry processors nonEmptyVariables
render :: forall a. UriTemplate -> [(String, TemplateValue a)] -> String
render tpl env = render' tpl $ map (\(l, r) -> (l, internalize r)) env
render' :: UriTemplate -> [(String, InternalTemplateValue)] -> String
render' tpl env = toList $ execWriter $ mapM_ go tpl
where
go :: TemplateSegment -> StringBuilder ()
go (Literal s) = addString s
go (Embed m vs) = processVariables env m vs