diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs new file mode 100644 index 00000000..a26c7d20 --- /dev/null +++ b/Data/Object/Html.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +-- | An 'Html' data type and associated 'HtmlObject'. 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 +#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) + +#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. + deriving (Eq, Show, Typeable) + +-- | A full HTML document. +newtype HtmlDoc = HtmlDoc Text + +type HtmlObject = Object String Html + +cs :: ConvertSuccess x y => x -> y +cs = convertSuccess + +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 ">" + ] + +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 Html JsonScalar where + convertSuccess = cs . (cs :: Html -> Text) +instance ConvertSuccess HtmlObject JsonObject where + convertSuccess = mapKeysValues convertSuccess convertSuccess +instance ConvertSuccess HtmlObject Json where + convertSuccess = cs . (cs :: HtmlObject -> JsonObject) + +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 + +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 "\"" + ] + +#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>\"]" ++ + "}" + Json (cs expected) @=? cs content + +testSuite :: Test +testSuite = testGroup "Data.Object.Html" + [ testCase "caseHtmlToText" caseHtmlToText + , testCase "caseStringTemplate" caseStringTemplate + , testCase "caseJson" caseJson + ] + +#endif diff --git a/runtests.hs b/runtests.hs index a35ea155..c2c41b0b 100644 --- a/runtests.hs +++ b/runtests.hs @@ -3,10 +3,12 @@ import Test.Framework (defaultMain) import qualified Yesod.Response import qualified Yesod.Utils import qualified Yesod.Resource +import qualified Data.Object.Html main :: IO () main = defaultMain [ Yesod.Response.testSuite , Yesod.Utils.testSuite , Yesod.Resource.testSuite + , Data.Object.Html.testSuite ] diff --git a/yesod.cabal b/yesod.cabal index c03fb3aa..a3e56004 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -42,7 +42,10 @@ library text >= 0.5 && < 0.6, convertible-text >= 0.0.0 && < 0.1, clientsession >= 0.0.1 && < 0.1, - zlib >= 0.5.2.0 && < 0.6 + zlib >= 0.5.2.0 && < 0.6, + containers >= 0.2.0.1 && < 0.3, + HStringTemplate >= 0.6.2 && < 0.7, + data-object-json >= 0.0.0 && < 0.1 exposed-modules: Yesod, Yesod.Constants, Yesod.Request, @@ -52,6 +55,7 @@ library Yesod.Handler, Yesod.Application, Yesod.Resource, + Data.Object.Html, Data.Object.Instances, Data.Object.Translate, Hack.Middleware.MethodOverride,