207 lines
6.2 KiB
Haskell
207 lines
6.2 KiB
Haskell
{-# 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 qualified Data.Text.Lazy as TL
|
|
import Data.ByteString.Lazy (ByteString)
|
|
import Web.Encodings
|
|
import Text.StringTemplate.Classes
|
|
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 ">"
|
|
, cs content
|
|
, cs "</"
|
|
, cs n
|
|
, 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 ByteString where
|
|
convertSuccess = cs . (cs :: Html -> Text)
|
|
|
|
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" [] $ HtmlList $ map addLi hs
|
|
where
|
|
addLi h = Tag "li" [] $ cs h
|
|
convertSuccess (Mapping pairs) =
|
|
Tag "dl" [] $ HtmlList $ 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) = helper $ map (second toSElem) pairs where
|
|
helper :: [(String, SElem b)] -> SElem b
|
|
helper = SM . 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>\"]" ++
|
|
"}"
|
|
JsonDoc (cs expected) @=? cs content
|
|
|
|
testSuite :: Test
|
|
testSuite = testGroup "Data.Object.Html"
|
|
[ testCase "caseHtmlToText" caseHtmlToText
|
|
, testCase "caseStringTemplate" caseStringTemplate
|
|
, testCase "caseJson" caseJson
|
|
]
|
|
|
|
#endif
|