packages feed

blaze-html 0.4.3.2 → 0.4.3.3

raw patch · 6 files changed

+347/−8 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

blaze-html.cabal view
@@ -1,5 +1,5 @@ Name:         blaze-html-Version:      0.4.3.2+Version:      0.4.3.3 Homepage:     http://jaspervdj.be/blaze Bug-Reports:  http://github.com/jaspervdj/blaze-html/issues License:      BSD3@@ -59,6 +59,12 @@   Hs-source-dirs: src tests   Main-is:        TestSuite.hs   Ghc-options:    -Wall++  Other-modules:+    Text.Blaze.Tests+    Text.Blaze.Tests.Cases+    Text.Blaze.Tests.Util+    Util.Tests    Build-depends:     HUnit                      >= 1.2 && < 1.3,
src/Text/Blaze/Internal.hs view
@@ -173,13 +173,6 @@ newtype Attribute = Attribute (forall a. HtmlM a -> HtmlM a)  instance Monoid Attribute where-    -- Usually function composition does not form a monoid because we can't-    -- prove that-    ---    -- > f . (g . h) == (f . g) . h-    ---    -- but since the functions in 'Attribute' can only apply attributes, this-    -- is not a problem here.     mempty                            = Attribute id     Attribute f `mappend` Attribute g = Attribute (g . f)
+ tests/Text/Blaze/Tests.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Text.Blaze.Tests+    ( tests+    ) where++import Prelude hiding (div, id)+import Data.Monoid (mempty)+import Control.Monad (replicateM)+import Control.Applicative ((<$>))+import Data.Word (Word8)+import Data.Char (ord)+import Data.List (isInfixOf)++import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy.Char8 as LBC+import qualified Data.ByteString.Lazy as LB+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck++import Text.Blaze.Html5 hiding (map)+import Text.Blaze.Html5.Attributes (id, class_, name)+import Text.Blaze.Internal+import Text.Blaze.Tests.Util++tests :: [Test]+tests = [ testProperty "left identity Monoid law"  monoidLeftIdentity+        , testProperty "right identity Monoid law" monoidRightIdentity+        , testProperty "associativity Monoid law"  monoidAssociativity+        , testProperty "mconcat Monoid law"        monoidConcat+        , testProperty "post escaping characters"  postEscapingCharacters+        , testProperty "valid UTF-8"               isValidUtf8+        , testProperty "external </ sequence"      externalEndSequence+        , testProperty "well nested <>"            wellNestedBrackets+        , testProperty "unsafeByteString id"       unsafeByteStringId+        ]++-- | The left identity Monoid law.+--+monoidLeftIdentity :: Html -> Bool+monoidLeftIdentity h = (return () >> h) == h++-- | The right identity Monoid law.+--+monoidRightIdentity :: Html -> Bool+monoidRightIdentity h = (h >> return ()) == h++-- | The associativity Monoid law.+--+monoidAssociativity :: Html -> Html -> Html -> Bool+monoidAssociativity x y z = (x >> (y >> z)) == ((x >> y) >> z)++-- | Concatenation Monoid law.+--+monoidConcat :: [Html] -> Bool+monoidConcat xs = sequence_ xs == foldr (>>) (return ()) xs++-- | Escaped content cannot contain certain characters.+--+postEscapingCharacters :: String -> Bool+postEscapingCharacters str =+    LB.all (`notElem` forbidden) $ renderUsingUtf8 (string str)+  where+    forbidden = map (fromIntegral . ord) "\"'<>"++-- | Check if the produced bytes are valid UTF-8+--+isValidUtf8 :: Html -> Bool+isValidUtf8 = isValidUtf8' . LB.unpack . renderUsingUtf8+  where+    isIn x y z = (x <= z) && (z <= y)+    isValidUtf8' :: [Word8] -> Bool+    isValidUtf8' [] = True+    isValidUtf8' (x:t)+        -- One byte+        | isIn 0x00 0x7f x = isValidUtf8' t+        -- Two bytes+        | isIn 0xc0 0xdf x = case t of+            (y:t') -> isIn 0x80 0xbf y && isValidUtf8' t'+            _      -> False+        -- Three bytes+        | isIn 0xe0 0xef x = case t of+            (y:z:t') -> all (isIn 0x80 0xbf) [y, z] && isValidUtf8' t'+            _        -> False+        -- Four bytes+        | isIn 0xf0 0xf7 x = case t of+            (y:z:u:t') -> all (isIn 0x80 0xbf) [y, z, u] && isValidUtf8' t'+            _          -> False+        | otherwise = False++-- | Rendering an unsafe bytestring should not do anything+--+unsafeByteStringId :: [Word8] -> Bool+unsafeByteStringId ws =+    LB.pack ws == renderUsingUtf8 (unsafeByteString $ SB.pack ws)++-- | Check if the "</" sequence does not appear in @<script>@ or @<style>@ tags.+--+externalEndSequence :: String -> Bool+externalEndSequence = not . isInfixOf "</" . LBC.unpack+                    . renderUsingUtf8 . external . string++-- | Check that the "<>" characters are well-nested.+--+wellNestedBrackets :: Html -> Bool+wellNestedBrackets = wellNested False . LBC.unpack . renderUsingUtf8+  where+    wellNested isOpen [] = not isOpen+    wellNested isOpen (x:xs) = case x of+        '<' -> if isOpen then False else wellNested True xs+        '>' -> if isOpen then wellNested False xs else False+        _   -> wellNested isOpen xs++-- Show instance for the HTML type, so we can debug.+--+instance Show Html where+    show = show . renderUsingUtf8++-- Eq instance for the HTML type, so we can compare the results.+--+instance Eq Html where+    x == y =  renderUsingString x == renderUsingString y+           && renderUsingText x   == renderUsingText y+           && renderUsingUtf8 x   == renderUsingUtf8 y+           -- Some cross-checks+           && renderUsingString x == renderUsingText y+           && renderUsingText x   == renderUsingUtf8 y++-- Arbitrary instance for the HTML type.+--+instance Arbitrary Html where+    arbitrary = arbitraryHtml 4++-- | Auxiliary function for the arbitrary instance of the HTML type, used+-- to limit the depth and size of the type.+--+arbitraryHtml :: Int       -- ^ Maximum depth.+              -> Gen Html  -- ^ Resulting arbitrary HTML snippet.+arbitraryHtml depth = do +    -- Choose the size (width) of this element.+    size <- choose (0, 3)++    -- Generate `size` new HTML snippets.+    children <- replicateM size arbitraryChild++    -- Return a concatenation of these children.+    return $ sequence_ children+  where+    -- Generate an arbitrary child. Do not take a parent when we have no depth+    -- left, obviously.+    arbitraryChild = do+        child <- oneof $  [arbitraryLeaf, arbitraryString, return mempty]+                       ++ [arbitraryParent | depth > 0]++        -- Generate some attributes for the child.+        size <- choose (0, 4)+        attributes <- replicateM size arbitraryAttribute+        return $ foldl (!) child attributes++    -- Generate an arbitrary parent element.+    arbitraryParent = do+        parent <- elements [p, div, table]+        parent <$> arbitraryHtml (depth - 1)++    -- Generate an arbitrary leaf element.+    arbitraryLeaf = oneof $ map return [img, br, area]++    -- Generate arbitrary string element.+    arbitraryString = do+        s <- arbitrary+        return $ string s++    -- Generate an arbitrary HTML attribute.+    arbitraryAttribute = do+        attr <- elements [id, class_, name]+        value <- arbitrary+        return $ attr $ stringValue value
+ tests/Text/Blaze/Tests/Cases.hs view
@@ -0,0 +1,107 @@+-- | A whole bunch of simple test cases+--+{-# LANGUAGE OverloadedStrings #-}+module Text.Blaze.Tests.Cases+    ( tests+    ) where++import Prelude hiding (div, id)+import Control.Monad (forM_)+import Data.Monoid (mempty, mappend, mconcat)++import Data.Text (Text)+import Test.HUnit ((@=?))+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework (Test)+import qualified Data.ByteString.Lazy.Char8 as LBC++import Text.Blaze+import Text.Blaze.Html5 hiding (map)+import qualified Text.Blaze.Html5 as H+import Text.Blaze.Html5.Attributes+import Text.Blaze.Tests.Util++-- | Type for a simple HTML test. This data type contains the expected output+-- and the HTML template.+--+data HtmlTest = HtmlTest LBC.ByteString Html++-- | Create tests from an HTML test+--+makeTests :: String -> HtmlTest -> [Test]+makeTests baseName (HtmlTest expected h) =+    [ testCase (baseName ++ " (String)") $ expected @=? renderUsingString h+    , testCase (baseName ++ " (Text)") $ expected @=? renderUsingText h+    , testCase (baseName ++ " (Utf8)") $ expected @=? renderUsingUtf8 h+    ]++-- | Actual tests+--+tests :: [Test]+tests = concatMap (uncurry makeTests) $ zip names+    -- Simple cases+    [ HtmlTest "<div id=\"foo\"><p>banana</p><span>banana</span></div>" $+        div ! id "foo" $ do+            p "banana"+            H.span "banana"++    , HtmlTest "<img src=\"foo.png\" alt=\"bar\">" $+        img ! src "foo.png" ! alt "bar"++    -- Escaping cases+    , HtmlTest "&quot;&amp;&quot;" "\"&\""++    , HtmlTest "&lt;img&gt;" $ toHtml ("<img>" :: Text)++    , HtmlTest "&quot;&#39;&quot;" "\"'\""++    , HtmlTest "<img src=\"&amp;\">" $ img ! src "&"++    -- Pre-escaping cases+    , HtmlTest "<3 Haskell" $ preEscapedText "<3 Haskell"++    , HtmlTest "<script />" $ preEscapedString "<script />"++    , HtmlTest "<p class=\"'&!;\">bad</p>" $+        p ! class_ (preEscapedTextValue "'&!;") $ "bad"++    -- Unicode cases+    , HtmlTest "<span id=\"&amp;\">\206\187</span>" $+        H.span ! id "&" $ "λ"++    , HtmlTest "\226\136\128x. x \226\136\136 A"+        "∀x. x ∈ A"++    , HtmlTest "$6, \226\130\172\&7.01, \194\163\&75"+        "$6, €7.01, £75"++    -- Control cases+    , HtmlTest "<li>4</li><li>5</li><li>6</li>" $+        forM_ [4 :: Int .. 6] (li . toHtml)++    , HtmlTest "<br><img><area>" $+        sequence_ [br, img, area]++    -- Attribute tests+    , HtmlTest "<p data-foo=\"bar\">A paragraph</p>" $+        p ! (dataAttribute "foo" "bar") $ "A paragraph"++    , HtmlTest "<p dojoType=\"select\">A paragraph</p>" $+        p ! (customAttribute "dojoType" "select") $ "A paragraph"++    , HtmlTest "<p>Hello</p>" $ p ! mempty $ "Hello"++    , HtmlTest "<img src=\"foo.png\" alt=\"foo\">" $+        img ! (src "foo.png" `mappend` alt "foo")++    -- ToHtml/ToValue tests+    , HtmlTest "12345678910" $ mconcat $ map toHtml [1 :: Int .. 10]++    , HtmlTest "<img src=\"funny-picture-4.png\">" $+        img ! src ("funny-picture-" `mappend` toValue (4 :: Integer)+                                    `mappend` ".png")++    , HtmlTest "abcdefghijklmnopqrstuvwxyz" $ forM_ ['a' .. 'z'] toHtml+    ]+  where+    names = map (("Test case " ++) . show) [1 :: Int ..]
+ tests/Text/Blaze/Tests/Util.hs view
@@ -0,0 +1,31 @@+-- | Utility functions for the blaze tests+--+module Text.Blaze.Tests.Util+    ( renderUsingString+    , renderUsingText+    , renderUsingUtf8+    ) where++import Text.Blaze.Html5 hiding (map)+import qualified Data.ByteString.Lazy as LB+import qualified Text.Blaze.Renderer.Utf8 as Utf8 (renderHtml)+import qualified Text.Blaze.Renderer.Text as Text (renderHtml)+import qualified Text.Blaze.Renderer.String as String (renderHtml)+import Blaze.ByteString.Builder as B (toLazyByteString)+import Blaze.ByteString.Builder.Char.Utf8 as B (fromString)+import Data.Text.Lazy.Encoding (encodeUtf8)++-- | Render HTML to an UTF-8 encoded ByteString using the String renderer+--+renderUsingString :: Html -> LB.ByteString+renderUsingString = toLazyByteString . fromString . String.renderHtml++-- | Render HTML to an UTF-8 encoded ByteString using the Text renderer+--+renderUsingText :: Html -> LB.ByteString+renderUsingText = encodeUtf8 . Text.renderHtml++-- | Render HTML to an UTF-8 encoded ByteString using the Utf8 renderer+--+renderUsingUtf8 :: Html -> LB.ByteString+renderUsingUtf8 = Utf8.renderHtml
+ tests/Util/Tests.hs view
@@ -0,0 +1,24 @@+module Util.Tests+    ( tests+    ) where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)++import Util.Sanitize (sanitize)++tests :: [Test]+tests = [ testCase "sanitize case 1" sanitize1+        , testCase "sanitize case 2" sanitize2+        ]++-- | Simple sanitize test case+--+sanitize1 :: Assertion+sanitize1 = "class_" @=? sanitize "CLASS"++-- | Simple sanitize test case+--+sanitize2 :: Assertion+sanitize2 = "httpEquiv" @=? sanitize "http-equiv"