Template.hs

{- |
  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)