{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} -- | An 'Html' data type and associated 'ConvertSuccess' instances. This has -- useful conversions in web development: -- -- * Automatic generation of simple HTML documents from 'HtmlObject' (mostly -- useful for testing, you would never want to actually show them to an end -- user). -- -- * Converts to JSON, which gives fully HTML escaped JSON. Very nice for Ajax. -- -- * Can be used with HStringTemplate. module Data.Object.Html ( -- * Data type Html (..) , HtmlDoc (..) , HtmlObject -- * Standard 'Object' functions , toHtmlObject , fromHtmlObject #if TEST , testSuite #endif ) where import Data.Generics import Data.Object.Text import Data.Object.Json import Data.Convertible.Text import qualified Data.Text.Lazy as TL import Web.Encodings import Text.StringTemplate.Classes import qualified Data.Map as Map import Control.Arrow (second) import Data.Attempt #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) import Text.StringTemplate #endif -- | A single piece of HTML code. data Html = Html Text -- ^ Already encoded HTML. | Text Text -- ^ Text which should be HTML escaped. | Tag String [(String, String)] [Html] -- ^ Tag which needs a closing tag. | EmptyTag String [(String, String)] -- ^ Tag without a closing tag. | HtmlList [Html] deriving (Eq, Show, Typeable) -- | A full HTML document. newtype HtmlDoc = HtmlDoc { unHtmlDoc :: Text } type HtmlObject = Object String Html toHtmlObject :: ConvertSuccess x HtmlObject => x -> HtmlObject toHtmlObject = cs fromHtmlObject :: ConvertAttempt HtmlObject x => HtmlObject -> Attempt x fromHtmlObject = ca instance ConvertSuccess String Html where convertSuccess = Text . cs instance ConvertSuccess Text Html where convertSuccess = Text $(deriveAttempts [ (''String, ''Html) , (''Text, ''Html) ]) showAttribs :: [(String, String)] -> Text showAttribs = TL.concat . map helper where helper :: (String, String) -> Text helper (k, v) = TL.concat [ cs " " , encodeHtml $ cs k , cs "=\"" , encodeHtml $ cs v , cs "\"" ] instance ConvertSuccess Html Text where convertSuccess (Html t) = t convertSuccess (Text t) = encodeHtml t convertSuccess (Tag n as content) = TL.concat [ cs "<" , cs n , showAttribs as , cs ">" , TL.concat $ map convertSuccess content , cs "" ] convertSuccess (EmptyTag n as) = TL.concat [ cs "<" , cs n , showAttribs as , cs ">" ] convertSuccess (HtmlList l) = TL.concat $ map cs l instance ConvertSuccess Html String where convertSuccess = cs . (cs :: Html -> Text) instance ConvertSuccess Html HtmlDoc where convertSuccess h = HtmlDoc $ TL.concat [ cs "HtmlDoc (autogenerated)" , cs "" , cs h , cs "" ] instance ConvertSuccess HtmlObject Html where convertSuccess (Scalar h) = h convertSuccess (Sequence hs) = Tag "ul" [] $ map addLi hs where addLi h = Tag "li" [] [cs h] convertSuccess (Mapping pairs) = Tag "dl" [] $ concatMap addDtDd pairs where addDtDd (k, v) = [ Tag "dt" [] [Text $ cs k] , Tag "dd" [] [cs v] ] instance ConvertSuccess HtmlObject HtmlDoc where convertSuccess = cs . (cs :: HtmlObject -> Html) instance ConvertSuccess Html JsonScalar where convertSuccess = cs . (cs :: Html -> Text) instance ConvertSuccess HtmlObject JsonObject where convertSuccess = mapKeysValues convertSuccess convertSuccess instance ConvertSuccess HtmlObject JsonDoc where convertSuccess = cs . (cs :: HtmlObject -> JsonObject) $(deriveAttempts [ (''Html, ''String) , (''Html, ''Text) , (''Html, ''HtmlDoc) , (''Html, ''JsonScalar) ]) $(deriveSuccessConvs ''String ''Html [''String, ''Text] [''Html, ''String, ''Text]) instance ToSElem HtmlObject where toSElem (Scalar h) = STR $ TL.unpack $ cs h toSElem (Sequence hs) = LI $ map toSElem hs toSElem (Mapping pairs) = SM $ Map.fromList $ map (second toSElem) pairs #if TEST caseHtmlToText :: Assertion caseHtmlToText = do let actual = Tag "div" [("id", "foo"), ("class", "bar")] [ Html $ cs "
Some HTML
" , Text $ cs "<'this should be escaped'>" , EmptyTag "img" [("src", "baz&")] ] let expected = "

Some HTML
" ++ "<'this should be escaped'>" ++ "
" cs actual @?= (cs expected :: Text) caseStringTemplate :: Assertion caseStringTemplate = do let content = Mapping [ ("foo", Sequence [ Scalar $ Html $ cs "
" , Scalar $ Text $ cs "
"]) , ("bar", Scalar $ EmptyTag "img" [("src", "file.jpg")]) ] let temp = newSTMP "foo:$o.foo$,bar:$o.bar$" let expected = "foo:
<hr>,bar:" expected @=? toString (setAttribute "o" content temp) caseJson :: Assertion caseJson = do let content = Mapping [ ("foo", Sequence [ Scalar $ Html $ cs "
" , Scalar $ Text $ cs "
"]) , ("bar", Scalar $ EmptyTag "img" [("src", "file.jpg")]) ] let expected = "{\"bar\":\"\"" ++ ",\"foo\":[\"
\",\"<hr>\"]" ++ "}" JsonDoc (cs expected) @=? cs content testSuite :: Test testSuite = testGroup "Data.Object.Html" [ testCase "caseHtmlToText" caseHtmlToText , testCase "caseStringTemplate" caseStringTemplate , testCase "caseJson" caseJson ] #endif