packages feed

uri-templater (empty) → 0.1.0.0

raw patch · 9 files changed

+597/−0 lines, 9 filesdep +HTTPdep +HUnitdep +ansi-wl-pprintsetup-changed

Dependencies added: HTTP, HUnit, ansi-wl-pprint, base, charset, dlist, mtl, parsers, template-haskell, trifecta, uri-templater

Files

+ LICENSE view
@@ -0,0 +1,20 @@+The MIT License (MIT)++Copyright (c) 2013 SaneTracker++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Network/URI/Template.hs view
@@ -0,0 +1,15 @@+module Network.URI.Template (+    uri+  , render+  , parseTemplate+  , UriTemplate(..)+  , TemplateSegment(..)+  , Modifier(..)+  , ValueModifier(..)+  , TemplateValue(..)+  , ToTemplateValue(..)+) where+import Network.URI.Template.Internal+import Network.URI.Template.Parser+import Network.URI.Template.TH+import Network.URI.Template.Types
+ src/Network/URI/Template/Internal.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables #-}+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)+      -- TODO: this is wrong. we need to truncate prior to encoding.+      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+      {-(processVariable m True) : repeat (processVariable m False)-}
+ src/Network/URI/Template/Parser.hs view
@@ -0,0 +1,100 @@+module Network.URI.Template.Parser where+import Control.Applicative+import Data.Char+import Data.List+import Data.Monoid+import Text.Trifecta+import Text.Parser.Char+import Text.PrettyPrint.ANSI.Leijen (Doc)+import Network.URI.Template.Types++range :: Char -> Char -> Parser Char+range l r = satisfy (\c -> l <= c && c <= r)++ranges :: [(Char, Char)] -> Parser Char+ranges = choice . map (uncurry range)++ucschar :: Parser Char+ucschar = ranges+  [ ('\xA0', '\xD7FF')+  , ('\xF900', '\xFDCF')+  , ('\xFDF0', '\xFFEF')+  , ('\x10000', '\x1FFFD')+  , ('\x20000', '\x2FFFD')+  , ('\x30000', '\x3FFFD')+  , ('\x40000', '\x4FFFD')+  , ('\x50000', '\x5FFFD')+  , ('\x60000', '\x6FFFD')+  , ('\x70000', '\x7FFFD')+  , ('\x80000', '\x8FFFD')+  , ('\x90000', '\x9FFFD')+  , ('\xA0000', '\xAFFFD')+  , ('\xB0000', '\xBFFFD')+  , ('\xC0000', '\xCFFFD')+  , ('\xD0000', '\xDFFFD')+  , ('\xE1000', '\xEFFFD')+  ]++iprivate :: Parser Char+iprivate = ranges+  [ ('\xE000', '\xF8FF')+  , ('\xF0000', '\xFFFFD')+  , ('\x100000', '\x10FFFD')+  ]++pctEncoded :: Parser String+pctEncoded = do+  h <- char '%'+  d1 <- hexDigit+  d2 <- hexDigit+  return [h, d1, d2]++literalChar :: Parser Char+literalChar = (choice $ map char ['\x21', '\x23', '\x24', '\x26', '\x3D', '\x5D', '\x5F', '\x7E'])+  <|> ranges [('\x28', '\x3B'), ('\x3F', '\x5B'), ('\x61', '\x7A')]+  <|> ucschar+  <|> iprivate++literal :: Parser TemplateSegment+literal = (Literal . concat) <$> some ((pure <$> literalChar) <|> pctEncoded)++variables :: Parser TemplateSegment+variables = Embed <$> modifier <*> sepBy1 variable (spaces *> char ',' *> spaces)++means :: Parser a -> b -> Parser b+means p v = p *> pure v++charMeans = means . char++modifier :: Parser Modifier+modifier = (choice $ map (uncurry charMeans) modifiers) <|> pure Simple+  where+    modifiers =+      [ ('+', Reserved)+      , ('#', Fragment)+      , ('.', Label)+      , ('/', PathSegment)+      , (';', PathParameter)+      , ('?', Query)+      , ('&', QueryContinuation)+      , ('@', Alias)+      ]++variable :: Parser Variable+variable = Variable <$> name <*> valueModifier+  where+    name = concat <$> some ((pure <$> (alphaNum <|> char '_')) <|> pctEncoded)+    valueModifier = charMeans '*' Explode <|> (MaxLength <$> (char ':' *> parseInt)) <|> pure Normal+    parseInt = read <$> some digit++embed :: Parser TemplateSegment+embed = between (char '{') (char '}') variables++uriTemplate :: Parser UriTemplate+uriTemplate = spaces *> many (literal <|> embed)++parseTemplate :: String -> Either Doc UriTemplate+parseTemplate t = case parseString uriTemplate mempty t of+                        Failure err -> Left err+                        Success r -> Right r+
+ src/Network/URI/Template/TH.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+module Network.URI.Template.TH where+import Data.List+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote+import Network.HTTP.Base+import Network.URI.Template.Internal+import Network.URI.Template.Parser+import Network.URI.Template.Types++{-+  mTpl <- parse qqInput+  case mTpl of+    Left err -> error err+    Right tpl -> do+      varNames <- distinct <$> getAllVariableNames+      convert varNames to [(varName, toTemplateValue $ varExpr for varName)]+      render tpl convertedValues+-}++variableNames :: UriTemplate -> [String]+variableNames = nub . foldr go []+  where+    go (Literal _) l = l+    go (Embed m vs) l = map variableName vs ++ l++segmentToExpr :: TemplateSegment -> Q Exp+segmentToExpr (Literal str) = appE (conE 'Literal) (litE $ StringL str)+segmentToExpr (Embed m vs) = appE (appE (conE 'Embed) modifier) $ listE $ map variableToExpr vs+  where+    modifier = conE $ mkName ("Network.URI.Template.Types." ++ show m)+    variableToExpr (Variable varName varModifier) = [| Variable $(litE $ StringL varName) $(varModifierE varModifier) |]+    varModifierE vm = case vm of+      Normal -> conE 'Normal+      Explode -> conE 'Explode+      (MaxLength x) -> appE (conE 'MaxLength) $ litE $ IntegerL $ fromIntegral x++templateToExp :: UriTemplate -> Q Exp+templateToExp ts = [| render' $(listE $ map segmentToExpr ts) $(templateValues) |]+  where+    templateValues = listE $ map makePair vns+    vns = variableNames ts+    makePair str = [| ($(litE $ StringL str), internalize $ toTemplateValue $ $(varE $ mkName str)) |]++-- AppE (VarE 'concat) $ ListE $ concatMap segmentToExp ts++{-segmentToExp (Literal s) = [LitE $ StringL s]-}+{-segmentToExp (Embed m v) = map (AppE prefix . enc . VarE . mkName) v-}+  {-where-}+    {-enc = AppE (VarE $ encoder m)-}+    {--- cons the prefix onto the beginning of each embedded segment-}+    {-prefix = InfixE (Just $ LitE $ CharL $ subsequentSeparator m) (ConE $ '(:)) Nothing-}++quasiEval :: String -> Q Exp+quasiEval str = do+  l <- location+  let parseLoc = loc_module l ++ ":" ++ show (loc_start l)+  let res = parseTemplate str+  case res of+    Left err -> fail $ show err+    Right tpl -> templateToExp tpl++uri :: QuasiQuoter+uri = QuasiQuoter+  { quoteExp = quasiEval+  , quotePat = error "Cannot use uri quasiquoter in pattern"+  , quoteType = error "Cannot use uri quasiquoter in type"+  , quoteDec = error "Cannot use uri quasiquoter as declarations"+  }
+ src/Network/URI/Template/Types.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE EmptyDataDecls, GADTs, FunctionalDependencies, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}+module Network.URI.Template.Types where++data SingleElement+data AssociativeListElement+data ListElement++newtype ListElem a = ListElem { fromListElem :: a }++data TemplateValue a where+  Single :: String -> TemplateValue SingleElement+  Associative :: [(String, TemplateValue SingleElement)] -> TemplateValue AssociativeListElement+  List :: [TemplateValue SingleElement] -> TemplateValue ListElement++data InternalTemplateValue+  = SingleVal String+  | AssociativeVal [(String, String)]+  | ListVal [String]++fromSingle :: TemplateValue SingleElement -> String+fromSingle (Single s) = s++fromSingleVal :: InternalTemplateValue -> String+fromSingleVal (SingleVal s) = s++internalize :: TemplateValue a -> InternalTemplateValue+internalize (Single s) = SingleVal s+internalize (Associative ls) = AssociativeVal $ map (\(l, r) -> (l, fromSingleVal $ internalize r)) ls+internalize (List l) = ListVal $ map (fromSingleVal . internalize) l++class ToTemplateValue a e | a -> e where+  toTemplateValue :: a -> TemplateValue e++instance ToTemplateValue Int SingleElement where+  toTemplateValue = Single . show++instance ToTemplateValue a SingleElement => ToTemplateValue (ListElem [a]) ListElement where+  toTemplateValue = List . map toTemplateValue . fromListElem++instance ToTemplateValue a SingleElement => ToTemplateValue [(String, a)] AssociativeListElement where+  toTemplateValue = Associative . map (\(l, r) -> (l, toTemplateValue r))++instance ToTemplateValue String SingleElement where+  toTemplateValue = Single++data ValueModifier+  = Normal+  | Explode+  | MaxLength Int+  deriving (Read, Show, Eq)++data Variable = Variable { variableName :: String, variableValueModifier :: ValueModifier }+  deriving (Read, Show, Eq)++data TemplateSegment+  = Literal String+  | Embed Modifier [Variable]+  deriving (Read, Show, Eq)++type UriTemplate = [TemplateSegment]++data Modifier+  = Simple+  | Reserved+  | Fragment+  | Label+  | PathSegment+  | PathParameter+  | Query+  | QueryContinuation+  | Alias+  deriving (Read, Show, Eq)++
+ test/Test.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE QuasiQuotes #-}+module Main where+import Control.Monad.Writer.Strict+import Network.URI.Template.Parser+import Network.URI.Template+import Network.URI.Template.TH+import Network.URI.Template.Types+import System.Exit+import Text.PrettyPrint.ANSI.Leijen (Doc, renderCompact, displayS)+import Test.HUnit hiding (test, path, Label)++-- Just being lazy here+instance Eq Doc where+  (==) d1 d2 = show d1 == show d2++type TestRegistry = Writer [Test]++test :: Assertion -> TestRegistry ()+test t = tell [TestCase t]++suite :: TestRegistry () -> TestRegistry ()+suite t = tell [TestList $ execWriter t]++label :: String -> TestRegistry () -> TestRegistry ()+label n = censor (\l -> [TestLabel n $ TestList l])++runTestRegistry :: TestRegistry () -> IO Counts+runTestRegistry = runTestTT . TestList . execWriter++main = do+  counts <- testRun+  let statusCode = errors counts + failures counts+  if statusCode > 0+    then exitFailure+    else exitSuccess+  where+    testRun = runTestRegistry (parserTests >> quasiQuoterTests >> embedTests)++parserTests = label "Parser Tests" $ suite $ do+  let foo = Variable "foo" Normal+  label "Literal" $ parserTest "foo" $ Literal "foo"+  label "Simple" $ parserTest "{foo}" $ Embed Simple [foo]+  label "Reserved" $ parserTest "{+foo}" $ Embed Reserved [foo]+  label "Fragment" $ parserTest "{#foo}" $ Embed Fragment [foo]+  label "Label" $ parserTest "{.foo}" $ Embed Label [foo]+  label "Path Segment" $ parserTest "{/foo}" $ Embed PathSegment [foo]+  label "Path Parameter" $ parserTest "{;foo}" $ Embed PathParameter [foo]+  label "Query" $ parserTest "{?foo}" $ Embed Query [foo]+  label "Query Continuation" $ parserTest "{&foo}" $ Embed QueryContinuation [foo]+  label "Explode" $ parserTest "{foo*}" $ Embed Simple [Variable "foo" Explode]+  label "Max Length" $ parserTest "{foo:1}" $ Embed Simple [Variable "foo" $ MaxLength 1]+  label "Multiple Variables" $ parserTest "{foo,bar}" $ Embed Simple [Variable "foo" Normal, Variable "bar" Normal]++parserTest :: String -> TemplateSegment -> TestRegistry ()+parserTest t e = test $ parseTemplate t @?= Right [e]++embedTests = label "Embed Tests" $ suite $ do+  label "Literal" $ embedTest "foo" "foo"+  label "Simple" $ embedTest "{foo}" "bar"+  label "Reserved" $ embedTest "{+foo}" "bar"+  label "Fragment" $ embedTest "{#foo}" "#bar"+  label "Label" $ embedTest "{.foo}" ".bar"+  label "Path Segment" $ embedTest "{/foo}" "/bar"+  label "Path Parameter" $ embedTest "{;foo}" ";foo=bar"+  label "Query" $ embedTest "{?foo}" "?foo=bar"+  label "Query Continuation" $ embedTest "{&foo}" "&foo=bar"+  label "Explode" $ embedTest "{foo*}" "bar"+  label "Max Length" $ embedTest "{foo:1}" "b"++embedTestEnv = [("foo", Single "bar")]++embedTest :: String -> String -> TestRegistry ()+embedTest t expect = test $ do+  let (Right tpl) = parseTemplate t+  let rendered = render tpl embedTestEnv+  rendered @?= expect++var :: String+var = "value"++hello :: String+hello = "Hello World!"++path :: String+path = "/foo/bar"++list :: ListElem [String]+list = ListElem ["red", "green", "blue"]++keys :: [(String, String)]+keys = [("semi", ";"), ("dot", "."), ("comma", ",")]++quasiQuoterTests = label "QuasiQuoter Tests" $ suite $ do+  label "Simple" $ test ([uri|{var}|] @?= "value")+  label "Multiple" $ test ([uri|{var,hello}|] @?= "value,Hello%20World%21")+  label "Length Constraint" $ test ([uri|{var:3}|] @?= "val")+  label "Sufficiently large length constraint" $ test ([uri|{var:10}|] @?= "value")+  label "List" $ test ([uri|{list}|] @?= "red,green,blue")+  label "Explode List" $ test ([uri|{list*}|] @?= "red,green,blue")+  label "Associative List" $ test ([uri|{keys}|] @?= "semi,%3B,dot,.,comma,%2C")+  label "Explode Associative List" $ test ([uri|{?keys*}|] @?= "?semi=%3B&dot=.&comma=%2C")++unescaped = do+  [uri|{+path:6}/here|] @?= "/foo/b/here"+  [uri|{+list}|] @?= "red,green,blue"+  [uri|{+list}|] @?= "red,green,blue"+  [uri|{+keys}|] @?= "semi,;,dot,.,comma,,"+  [uri|{+keys}|] @?= "semi=;,dot=.,comma=,"++fragment = 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+  [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+  [uri|{/var:1,var}|] @?= "/v/value"+  [uri|{/list}|] @?= "/red,green,blue"+  [uri|{/list*}|] @?= "/red/green/blue"+  [uri|{/list*,path:4}|] @?= "/red/green/blue/%2Ffoo"+  [uri|{/keys}|] @?= "/semi,%3B,dot,.,comma,%2C"+  [uri|{/keys*}|] @?= "/semi=%3B/dot=./comma=%2C"++pathParams = 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++continuedQueryParams = do+  [uri|{&foo}|] @?= "&foo=1"+  [uri|{&foo,bar}|] @?= "&foo=1&bar=2"+  where+    foo :: Int+    foo = 1+    bar :: Int+    bar = 2
+ uri-templater.cabal view
@@ -0,0 +1,48 @@+-- Initial uri-template.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                uri-templater+version:             0.1.0.0+synopsis:            Parsing & Quasiquoting for RFC 6570 URI Templates+description:         Parsing & Quasiquoting for RFC 6570 URI Templates+homepage:            http://github.com/sanetracker/uri-templater+license:             MIT+license-file:        LICENSE+author:              Ian Duncan+maintainer:          ian@iankduncan.com+copyright:           SaneTracker+category:            Network+build-type:          Simple+cabal-version:       >=1.8+source-repository    head+  type:                git+  location:            http://github.com/sanetracker/uri-templater+++library+  exposed-modules:   Network.URI.Template,+                     Network.URI.Template.TH,+                     Network.URI.Template.Types,+                     Network.URI.Template.Parser,+                     Network.URI.Template.Internal+  build-depends:     base <5,+                     trifecta,+                     charset,+                     parsers,+                     template-haskell,+                     HTTP,+                     dlist,+                     mtl,+                     ansi-wl-pprint+  hs-source-dirs:    src++test-suite test-uri-templates+   type:             exitcode-stdio-1.0+   main-is:          Test.hs+   hs-source-dirs:   test+   build-depends:    base,+                     mtl,+                     uri-templater,+                     template-haskell,+                     HUnit,+                     ansi-wl-pprint