haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added Data.Object.Html with main conversions.

Browse Source 
Has support for raw output, conversion to JSON, and use in
HStringTemplate.
This commit is contained in:
Michael Snoyman 2009-12-11 13:19:20 +02:00
parent ab65accb44
commit a70fba9426
3 changed files with 171 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

164
Data/Object/Html.hs Normal file
View File

@ -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 "</"
, cs n
, cs ">"
]
convertSuccess (EmptyTag n as) = TL.concat
[ cs "<"
, cs n
, showAttribs as
, cs ">"
]
instance ConvertSuccess Html HtmlDoc where
convertSuccess h = HtmlDoc $ TL.concat
[ cs "<!DOCTYPE html><html><head><title>HtmlDoc (autogenerated)"
, cs "</title></head><body>"
, cs h
, cs "</body></html>"
]
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 "<br>Some HTML<br>"
, Text $ cs "<'this should be escaped'>"
, EmptyTag "img" [("src", "baz&")]
]
let expected =
"<div id=\"foo\" class=\"bar\"><br>Some HTML<br>" ++
"&lt;&#39;this should be escaped&#39;&gt;" ++
"<img src=\"baz&amp;\"></div>"
cs actual @?= (cs expected :: Text)
caseStringTemplate :: Assertion
caseStringTemplate = do
let content = Mapping
[ ("foo", Sequence [ Scalar $ Html $ cs "<br>"
, Scalar $ Text $ cs "<hr>"])
, ("bar", Scalar $ EmptyTag "img" [("src", "file.jpg")])
]
let temp = newSTMP "foo:$o.foo$,bar:$o.bar$"
let expected = "foo:<br>&lt;hr&gt;,bar:<img src=\"file.jpg\">"
expected @=? toString (setAttribute "o" content temp)
caseJson :: Assertion
caseJson = do
let content = Mapping
[ ("foo", Sequence [ Scalar $ Html $ cs "<br>"
, Scalar $ Text $ cs "<hr>"])
, ("bar", Scalar $ EmptyTag "img" [("src", "file.jpg")])
]
let expected = "{\"bar\":\"<img src=\\\"file.jpg\\\">\"" ++
",\"foo\":[\"<br>\",\"&lt;hr&gt;\"]" ++
"}"
Json (cs expected) @=? cs content
testSuite :: Test
testSuite = testGroup "Data.Object.Html"
[ testCase "caseHtmlToText" caseHtmlToText
, testCase "caseStringTemplate" caseStringTemplate
, testCase "caseJson" caseJson
]
#endif

2
runtests.hs
View File

@ -3,10 +3,12 @@ import Test.Framework (defaultMain)
import qualified Yesod.Response import qualified Yesod.Response
import qualified Yesod.Utils import qualified Yesod.Utils
import qualified Yesod.Resource import qualified Yesod.Resource
import qualified Data.Object.Html
main :: IO () main :: IO ()
main = defaultMain main = defaultMain
[ Yesod.Response.testSuite [ Yesod.Response.testSuite
, Yesod.Utils.testSuite , Yesod.Utils.testSuite
, Yesod.Resource.testSuite , Yesod.Resource.testSuite
, Data.Object.Html.testSuite
] ]

6
yesod.cabal
View File

@ -42,7 +42,10 @@ library
text >= 0.5 && < 0.6, text >= 0.5 && < 0.6,
convertible-text >= 0.0.0 && < 0.1, convertible-text >= 0.0.0 && < 0.1,
clientsession >= 0.0.1 && < 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, exposed-modules: Yesod,
Yesod.Constants, Yesod.Constants,
Yesod.Request, Yesod.Request,
@ -52,6 +55,7 @@ library
Yesod.Handler, Yesod.Handler,
Yesod.Application, Yesod.Application,
Yesod.Resource, Yesod.Resource,
Data.Object.Html,
Data.Object.Instances, Data.Object.Instances,
Data.Object.Translate, Data.Object.Translate,
Hack.Middleware.MethodOverride, Hack.Middleware.MethodOverride,