Added Data.Object.Html with main conversions.
Has support for raw output, conversion to JSON, and use in HStringTemplate.
This commit is contained in:
Michael Snoyman
parent
ab65accb44
commit
a70fba9426
164
Data/Object/Html.hs
Normal file
164
Data/Object/Html.hs
Normal 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>" ++
|
||||
"<'this should be escaped'>" ++
|
||||
"<img src=\"baz&\"></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><hr>,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>\",\"<hr>\"]" ++
|
||||
"}"
|
||||
Json (cs expected) @=? cs content
|
||||
|
||||
testSuite :: Test
|
||||
testSuite = testGroup "Data.Object.Html"
|
||||
[ testCase "caseHtmlToText" caseHtmlToText
|
||||
, testCase "caseStringTemplate" caseStringTemplate
|
||||
, testCase "caseJson" caseJson
|
||||
]
|
||||
|
||||
#endif
|
||||
@ -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
|
||||
]
|
||||
|
||||
@ -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,
|
||||
|
||||
Loading…
Reference in New Issue
Block a user