uri-template (empty) → 0.2
raw patch · 7 files changed
+345/−0 lines, 7 filesdep +basedep +containersdep +utf8-stringsetup-changed
Dependencies added: base, containers, utf8-string
Files
- Codec/Web/Percent.hs +48/−0
- LICENSE +27/−0
- Main.hs +16/−0
- Network/URI/Template.hs +194/−0
- README +14/−0
- Setup.hs +7/−0
- uri-template.cabal +39/−0
+ Codec/Web/Percent.hs view
@@ -0,0 +1,48 @@+{-+ Codec for de/encoding URI strings via percent encodings+ (cf. RFC 3986.)+-}+module Codec.Web.Percent where++import Data.Char ( chr, isAlphaNum )+import Numeric ( readHex, showHex )+++getEncodedString :: String -> String+getEncodedString "" = ""+getEncodedString (x:xs) = + case getEncodedChar x of+ Nothing -> x : getEncodedString xs+ Just ss -> ss ++ getEncodedString xs++getDecodedString :: String -> String+getDecodedString "" = ""+getDecodedString ls@(x:xs) = + case getDecodedChar ls of+ Nothing -> x : getDecodedString xs+ Just (ch,xs1) -> ch : getDecodedString xs1++getEncodedChar :: Char -> Maybe String+getEncodedChar x+ | isAlphaNum x || + x `elem` "-_.~" = Nothing+ | xi < 0xff = Just ('%':showHex (xi `div` 16) (showHex (xi `mod` 16) ""))+ | otherwise = -- ToDo: import utf8 lib+ error "getEncodedChar: can only handle 8-bit chars right now."+ where+ xi :: Int+ xi = fromEnum x++getDecodedChar :: String -> Maybe (Char, String)+getDecodedChar str =+ case str of+ "" -> Nothing+ (x:xs) + | x /= '%' -> Nothing+ | otherwise -> do+ case xs of+ (b1:b2:bs) -> + case readHex [b1,b2] of+ ((v,_):_) -> Just (Data.Char.chr v, bs)+ _ -> Nothing+ _ -> Nothing
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Sigbjorn Finne 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,16 @@+module Main(main) where++import Network.URI.Template++testEnv :: TemplateEnv+testEnv =+ addToEnv "searchTerm" "google" $+ addToEnv "type" "int" $+ addListToEnv "vals" ["a", "b", "a cd e"] $+ newEnv++main :: IO () +main = do+ putStrLn (expand testEnv "http://google.com/q={searchTerm?}&{-join|&|type,searchTerm}")+ return ()+
+ Network/URI/Template.hs view
@@ -0,0 +1,194 @@+{- |+ Module : Network.URI.Template+ Copyright : (c) Sigbjorn Finne, 2008+ License : BSD3++ Maintainer : sof@forkio.com+ Stability : provisional+ Portability : portable++ URI templates and their expansion. For details+ (and up-to-date specs), see + http://bitworking.org/projects/++ Also implements the OpenSearch 1.1 style with '?' suffix chars+ + support for namespace prefixes {xmlns:foo?} => xmlns:bar++-}+module Network.URI.Template + ( TemplateEnv+ , newEnv -- :: TemplateEnv+ , addToEnv -- :: TemplateEnv -> String -> String -> TemplateEnv+ , addListToEnv -- :: TemplateEnv -> String -> [String] -> TemplateEnv+ + , URITemplate -- String synonym+ , URIString -- ditto.++ , expand -- :: TemplateEnv -> URITemplate -> URIString + ) where++import Data.Map as M+import Data.List++import Codec.Binary.UTF8.String as UTF8+import Codec.Web.Percent++type URIString = String+type URITemplate = String++-- | @TemplateEnv@ holds the key,value mapping for the expansion+-- context for a URI template.+newtype TemplateEnv = TemplateEnv { tenv :: Map String TempValue }++data TempValue+ = ValStr URIString+ | ValList [URIString]++-- | Construct a new, empty 'TemplateEnv'.+newEnv :: TemplateEnv+newEnv = TemplateEnv{tenv=M.empty}++-- | UTF-8ifies the RHS, followed by percent encoding it.+normalize :: String -> String+normalize s = getEncodedString (UTF8.encodeString s)++-- | @addToEnv key value env@ augments @env@ with a new+-- key,value pair.+addToEnv :: String -> String -> TemplateEnv -> TemplateEnv+addToEnv k v env+ = TemplateEnv{tenv=M.insert k (ValStr (normalize v)) (tenv env)}++-- | @addListToEnv key vals env@ expands the template environment @env@+-- with a list-valued key,value(s) pair.+addListToEnv :: String -> [String] -> TemplateEnv -> TemplateEnv+addListToEnv k vs env+ = TemplateEnv{tenv=M.insert k (ValList (Data.List.map normalize vs)) (tenv env)}++-- | @expand tenv tpl@ performs template expansion on URL template @tpl@ wrt+-- @tenv@. The result contains the expansion, _but_ leaving unbound template+-- variables intact.+expand :: TemplateEnv -> URITemplate -> URIString+expand _ "" = ""+expand env ('{':xs) =+ -- look for the sentinel..+ case break (=='}') xs of+ (_,[]) -> '{' : expand env xs+ ('-':str,_:bs) -> + case wordsBy "|" str of+ [fun,arg,vars] ->+ case Data.List.lookup fun funEnv of+ Just f -> (f env arg vars) ++ expand env bs+ -- unknown/ill-formed, but just ignored.+ Nothing -> expand env bs+ -- ditto.+ _ -> expand env bs+ (str,_:bs) -> + case break (=='=') str of+ (k,_:def) -> + let (def',_isOpt) = if last def == '?' then (init def, True) else (def,False) in+ case M.lookup k (tenv env) of+ Nothing -> def' ++ expand env bs+ Just (ValStr v) -> v ++ expand env bs+ Just (ValList vs) -> concat (intersperse "," vs) ++ expand env bs+ _ -> + let+ -- check for OpenSearch-style opt suffixes..+ (k0,_isOpt) + | last str == '?' = (init str, True)+ | otherwise = (str,False)+ -- ..and its NS-prefixed forms+ (k,pre) = + case break (==':') k0 of+ (as,_:rs) -> (rs,as++":")+ _ -> (k0,"")+ in+ case M.lookup k (tenv env) of+ Nothing -> expand env bs -- ToDo: flag an error if not optional.+ Just (ValStr v) -> pre ++ v ++ expand env bs+ Just (ValList vs) -> concat (intersperse "," $+ Data.List.map (pre++) vs) ++ expand env bs+expand env (x:xs) = x : expand env xs+ +type TemplateFun = TemplateEnv -> String -> String -> String++funEnv :: [(String, TemplateFun)]+funEnv =+ [ ("opt", optExp False)+ , ("neg", optExp True)+ , ("prefix", preExp)+ , ("suffix", sufExp)+ , ("join", joinExp)+ , ("list", listExp)+ ]+ +optExp :: Bool -> TemplateFun+optExp isNeg env sep vs + | all isEmpty vals = if isNeg then sep else ""+ | otherwise = if isNeg then "" else sep+ where+ vals = wordsBy "," vs+ + isEmpty x = + case M.lookup x (tenv env) of+ Nothing -> True+ Just (ValList []) -> True+ _ -> False++preExp :: TemplateFun+preExp env sep vs =+ case wordsBy "," vs of+ [_] -> + case M.lookup vs (tenv env) of+ Just (ValStr x) -> sep ++ x+ Just (ValList xs) -> sep ++ concat (intersperse sep xs)+ _ -> ""+ _ -> "" -- an error condition, really.++sufExp :: TemplateFun+sufExp env sep vs =+ case wordsBy "," vs of+ [_] -> + case M.lookup vs (tenv env) of+ Just (ValStr x) -> x ++ sep+ Just (ValList xs) -> concat (intersperse sep xs) ++ sep+ _ -> ""+ _ -> "" -- an error condition, really.++joinExp :: TemplateFun+joinExp env sep vs = concat (intersperse sep (go (wordsBy "," vs)))+ where+ go [] = []+ go (k:ks) = + case M.lookup k (tenv env) of+ Nothing -> go ks+ Just ValList{} -> go ks -- an error, really.+ Just (ValStr s) -> (k ++ '=':s ) : go ks++listExp :: TemplateFun+listExp env sep vs = + case wordsBy "," vs of+ [_] -> case M.lookup vs (tenv env) of+ Nothing -> ""+ Just (ValList []) -> ""+ Just (ValList as) -> concat (intersperse sep as) + _ -> "" -- an error, really.+ _ -> ""++-- helpers++wordsBy :: String -> String -> [String]+wordsBy _ "" = []+wordsBy sep ls =+ case spanUntil (sep `isPrefixOf`) ls of+ (as,[]) -> [as]+ (as,bs) -> as : wordsBy sep (drop (length sep) bs)++spanUntil :: ([a] -> Bool) -> [a] -> ([a],[a])+spanUntil _ [] = ([],[])+spanUntil p ls@(x:xs)+ | p ls = ([],ls)+ | otherwise = + case spanUntil p xs of+ (as,bs) -> (x:as,bs)++
+ README view
@@ -0,0 +1,14 @@+A little package containing code for expanding URI Templates wrt an+input environment map. The URI template syntax is that of the draft+IETF RFC that Joe Gregorio is driving forward:++ http://bitworking.org/projects/++simple and useful (a combo to strive for :-) ) It is is used in a+couple of feed-related projects already (e.g., FIQL), and WADL. More+to come, mb.++The expansion code also recognizes OpenSearch-1.1 style templates+(e.g., '?' suffixes and its NS-prefix expansion forms.)++--sof 9/2008
+ Setup.hs view
@@ -0,0 +1,7 @@+module Main where + +import Distribution.Simple + + +main :: IO () +main = defaultMain
+ uri-template.cabal view
@@ -0,0 +1,39 @@+name: uri-template +version: 0.2 +synopsis: URI template library for Haskell +description: + A URI template expansion library for Haskell. Provides + support for Joe Gregorio's standardized format, OpenSearch 1.1's + format + WADL/WSDL-style templates. + +category: Web +license: BSD3 +license-file: LICENSE +author: Sigbjorn Finne <sof@forkIO.com> +maintainer: sof@forkIO.com +build-depends: base, containers +cabal-version: >= 1.2 +build-type: Simple +Extra-source-files:README + +flag new-base + Description: Build with new smaller base library + Default: False + +library + Exposed-modules: Network.URI.Template + Other-modules: Codec.Web.Percent + Extra-libraries: + Ghc-Options: -Wall + + Build-Depends: base, containers, utf8-string + if flag(new-base) + Build-Depends: base >= 3 + else + Build-Depends: base < 3 + +executable main { + build-depends: base + main-is: Main.hs + ghc-options: -Wall +}