HTML.hs

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

module Text.CxML.HTML where

import Text.CxML.Types
import Text.CxML.Tags(input)

-- | escape HTML

--newtype HtmlSafeString = HtSfString String -- this is a type safe way to prevent XSS. We may do that in the future
-- see http://blog.moertel.com/articles/2006/10/18/a-type-based-solution-to-the-strings-problem

hText = HText . escapeBrackets -- poor man's solution to the "strings problem" (see link above)

escapeBrackets :: String -> String
escapeBrackets [] = []
escapeBrackets ('<':t) = "&lt;"++escapeBrackets t
escapeBrackets ('>':t) = "&gt;"++escapeBrackets t
escapeBrackets ('&':t) = "&amp;"++escapeBrackets t
escapeBrackets ('\'':t) = "&apos;"++escapeBrackets t
escapeBrackets ('"':t) = "&qout;"++escapeBrackets t
escapeBrackets ('(':'C':')':t) = "&copy;"++escapeBrackets t --copyright
escapeBrackets (h:t) = h:(escapeBrackets t)

-- | create a text node. Automatically escape HTML to protect against XSS
t ::  String-> CxML a
t str = CxML (\_->[hText str],[],[],[])

-- modify HTML part of CxML - used in navList?
modHElems :: (HElem->HElem)->CxML a->CxML a
modHElems f (CxML (h,ts,c,j)) =  CxML (\ctx->map f $ h ctx, ts, c, j)


class CxMLChild a b where
    (//) :: CxML a -> b -> CxML a

instance CxMLChild a (CxML a)where
    p//c= withChildren p [c]

instance CxMLChild a [CxML a]where
    p//c= withChildren p c

instance CxMLChild a [Char]where
    p//c= withChildren p [t c]

instance CxMLChild a [[Char]] where
    p//c= withChildren p $ map t c

infixl 5 //




-- | create an operator to set an attribute of HTML elements
setAttrOp ::  String -> (CxML a) -> String -> (CxML a)
setAttrOp at= \tag-> \val-> 
              CxML (\ctx-> map (add_attr at val) $ htm tag ctx, titleParts tag, css tag,js tag )

-- | helper function for setAttrOp
add_attr :: String->String->HElem->HElem
add_attr _ _ s@(HText str)= s
add_attr nm vl (HTag tn ats chs) = HTag tn (add_attr' nm vl ats) chs
               where
                 add_attr' nm vl [] = [(nm,vl)]
                 add_attr' nm vl ((nm',vl'):ats) 
                          = if (nm==nm') 
                              then (nm,vl' ++ " " ++ vl):ats
                              else (nm',vl'): add_attr' nm vl ats
--FIXME: a Map could be used for the attributes, although there should be just a few per tag


infixl 8 ^#
(^#)=setAttrOp "id"

infixl 8 ^.
(^.)=setAttrOp "class"

infixl 7 ^>
(^>)=setAttrOp "href"


{-
maybe one day I would like ^> to set href for <a> but src for <img>
(^>) = \tag-> \val-> 
       CxML (\ctx-> map (add_attr at val) $ (htm tag) ctx, css tag,js tag )
       where tagAtAssoc = [("img", "src"),
                          ("a", "href")

]-}

-- | set any attribute of HTML element
infixl 8 !
(!) :: (CxML a)->(String, String)->(CxML a)
tag ! (at,vl)  = CxML (\ctx-> map (add_attr at vl) $ htm tag ctx, titleParts tag, css tag, js tag)


--------------------------------------------------
-----Modified from module Text.XHtml.Extras  -----
--------------------------------------------------

{-widget :: String -> String -> [HtmlAttr] -> Html
widget w n markupAttrs = input ! ([thetype w,name n,identifier n] ++ markupAttrs)

checkbox :: String -> String -> Html
hidden   :: String -> String -> Html
radio    :: String -> String -> Html
reset    :: String -> String -> Html
submit   :: String -> String -> Html
password :: String           -> Html
textfield :: String          -> Html
afile    :: String           -> Html
clickmap :: String           -> Html

checkbox n v = widget "checkbox" n [value v]
hidden   n v = widget "hidden"   n [value v]
radio    n v = widget "radio"    n [value v]
reset    n v = widget "reset"    n [value v]
submit   n v = widget "submit"   n [value v]
password n   = widget "password" n []
textfield n  = widget "text"     n []
afile    n   = widget "file"     n []
clickmap n   = widget "image"    n []
-}

widget :: String -> String -> [(String,String)] -> CxML a
widget w n markupAttrs = foldl (!) input (("type",w):("name",n):("id",n):markupAttrs)

textfield n = widget "text" n []
hidden n v = widget "hidden" n [("value",v)]
afile n = widget "file" n []