packages feed

markdown (empty) → 0.1.0

raw patch · 17 files changed

+926/−0 lines, 17 filesdep +HUnitdep +attoparsecdep +attoparsec-conduitsetup-changed

Dependencies added: HUnit, attoparsec, attoparsec-conduit, base, blaze-html, conduit, data-default, hspec, markdown, system-fileio, system-filepath, text, transformers, xss-sanitize

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Michael Snoyman++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Michael Snoyman nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/Markdown.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Markdown+    ( -- * Functions+      markdown+      -- * Settings+    , MarkdownSettings+    , msXssProtect+      -- * Newtype+    , Markdown (..)+      -- * Convenience re-exports.+    , def+    ) where++import Text.Markdown.Inline+import Text.Markdown.Block+import Prelude hiding (sequence, takeWhile)+import Data.Default (Default (..))+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import Text.Blaze.Html (ToMarkup (..), Html)+import Text.Blaze.Html.Renderer.Text (renderHtml)+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Monoid (Monoid (mappend, mempty, mconcat))+import Data.Functor.Identity (runIdentity)+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as HA+import Text.HTML.SanitizeXSS (sanitizeBalance)++-- | A settings type providing various configuration options.+--+-- See <http://www.yesodweb.com/book/settings-types> for more information on+-- settings types. In general, you can use @def@.+data MarkdownSettings = MarkdownSettings+    { msXssProtect :: Bool+      -- ^ Whether to automatically apply XSS protection to embedded HTML. Default: @True@.+    }++instance Default MarkdownSettings where+    def = MarkdownSettings+        { msXssProtect = True+        }++-- | A newtype wrapper providing a @ToHtml@ instance.+newtype Markdown = Markdown TL.Text++instance ToMarkup Markdown where+    toMarkup (Markdown t) = markdown def t++-- | Convert the given textual markdown content to HTML.+--+-- >>> :set -XOverloadedStrings+-- >>> import Text.Blaze.Html.Renderer.Text+-- >>> renderHtml $ markdown def "# Hello World!"+-- "<h1>Hello World!</h1>"+--+-- >>> renderHtml $ markdown def { msXssProtect = False } "<script>alert('evil')</script>"+-- "<script>alert('evil')</script>"+markdown :: MarkdownSettings -> TL.Text -> Html+markdown ms tl =+    runIdentity+  $ CL.sourceList (TL.toChunks tl)+ $$ mapOutput (fmap (toHtmlI ms . toInline)) toBlocks+ =$ toHtmlB ms+ =$ CL.fold mappend mempty++data MState = NoState | InList ListType++toHtmlB :: Monad m => MarkdownSettings -> GInfConduit (Block Html) m Html+toHtmlB ms =+    loop NoState+  where+    loop state = awaitE >>= either+        (\e -> closeState state >> return e)+        (\x -> do+            state' <- getState state x+            yield $ go x+            loop state')++    closeState NoState = return ()+    closeState (InList Unordered) = yield $ escape "</ul>"+    closeState (InList Ordered) = yield $ escape "</ol>"++    getState NoState (BlockList ltype _) = do+        yield $ escape $+            case ltype of+                Unordered -> "<ul>"+                Ordered -> "<ol>"+        return $ InList ltype+    getState NoState _ = return NoState+    getState state@(InList lt1) b@(BlockList lt2 _)+        | lt1 == lt2 = return state+        | otherwise = closeState state >> getState NoState b+    getState state@(InList _) _ = closeState state >> return NoState++    go (BlockPara h) = H.p h+    go (BlockList _ (Left h)) = H.li h+    go (BlockList _ (Right bs)) = H.li $ blocksToHtml bs+    go (BlockHtml t) = escape $ (if msXssProtect ms then sanitizeBalance else id) t+    go (BlockCode Nothing t) = H.pre $ H.code $ toMarkup t+    go (BlockCode (Just lang) t) = H.pre $ H.code H.! HA.class_ (H.toValue lang) $ toMarkup t+    go (BlockQuote bs) = H.blockquote $ blocksToHtml bs+    go BlockRule = H.hr+    go (BlockHeading level h) =+        wrap level h+      where+       wrap 1 = H.h1+       wrap 2 = H.h2+       wrap 3 = H.h3+       wrap 4 = H.h4+       wrap 5 = H.h5+       wrap _ = H.h6++    blocksToHtml bs = runIdentity $ mapM_ yield bs $$ toHtmlB ms =$ CL.fold mappend mempty++escape :: Text -> Html+escape = preEscapedToMarkup++toHtmlI :: MarkdownSettings -> [Inline] -> Html+toHtmlI ms is0+    | msXssProtect ms = escape $ sanitizeBalance $ TL.toStrict $ renderHtml final+    | otherwise = final+  where+    final = gos is0+    gos = mconcat . map go++    go (InlineText t) = toMarkup t+    go (InlineItalic is) = H.i $ gos is+    go (InlineBold is) = H.b $ gos is+    go (InlineCode t) = H.code $ toMarkup t+    go (InlineLink url Nothing content) = H.a H.! HA.href (H.toValue url) $ gos content+    go (InlineLink url (Just title) content) = H.a H.! HA.href (H.toValue url) H.! HA.title (H.toValue title) $ gos content+    go (InlineImage url Nothing content) = H.img H.! HA.src (H.toValue url) H.! HA.alt (H.toValue content)+    go (InlineImage url (Just title) content) = H.img H.! HA.src (H.toValue url) H.! HA.alt (H.toValue content) H.! HA.title (H.toValue title)+    go (InlineHtml t) = escape t
+ Text/Markdown/Block.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_HADDOCK hide #-}+module Text.Markdown.Block+    ( Block (..)+    , ListType (..)+    , toBlocks+    ) where++import Prelude+import Data.Conduit+import qualified Data.Conduit.Text as CT+import qualified Data.Conduit.List as CL+import Data.Text (Text)+import qualified Data.Text as T+import Data.Functor.Identity (runIdentity)+import Data.Char (isDigit)++data ListType = Ordered | Unordered+  deriving (Show, Eq)++data Block inline+    = BlockPara inline+    | BlockList ListType (Either inline [Block inline])+    | BlockCode (Maybe Text) Text+    | BlockQuote [Block inline]+    | BlockHtml Text+    | BlockRule+    | BlockHeading Int inline+  deriving (Show, Eq)++instance Functor Block where+    fmap f (BlockPara i) = BlockPara (f i)+    fmap f (BlockList lt (Left i)) = BlockList lt $ Left $ f i+    fmap f (BlockList lt (Right bs)) = BlockList lt $ Right $ map (fmap f) bs+    fmap _ (BlockCode a b) = BlockCode a b+    fmap f (BlockQuote bs) = BlockQuote $ map (fmap f) bs+    fmap _ (BlockHtml t) = BlockHtml t+    fmap _ BlockRule = BlockRule+    fmap f (BlockHeading level i) = BlockHeading level (f i)++toBlocks :: Monad m => Conduit Text m (Block Text)+toBlocks = mapOutput noCR CT.lines =$= toBlocksLines++toBlocksLines :: Monad m => GLInfConduit Text m (Block Text)+toBlocksLines = awaitForever start++noCR :: Text -> Text+noCR t+    | T.null t = t+    | T.last t == '\r' = T.init t+    | otherwise = t++start :: Monad m => Text -> GLConduit Text m (Block Text)+start t+    | T.null $ T.strip t = return ()+    | isRule t = yield BlockRule+    | Just lang <- T.stripPrefix "~~~" t = do+        (finished, ls) <- takeTill (== "~~~") >+> withUpstream CL.consume+        if finished+            then yield $ BlockCode (if T.null lang then Nothing else Just lang) $ T.intercalate "\n" ls+            else mapM_ leftover (reverse $ T.cons ' ' t : ls)+    | Just t' <- T.stripPrefix "> " t = do+        ls <- takeQuotes >+> CL.consume+        let blocks = runIdentity $ mapM_ yield (t' : ls) $$ toBlocksLines =$ CL.consume+        yield $ BlockQuote blocks+    | Just (level, t') <- stripHeading t = yield $ BlockHeading level t'+    | Just t' <- T.stripPrefix "    " t = do+        ls <- getIndented 4 >+> CL.consume+        yield $ BlockCode Nothing $ T.intercalate "\n" $ t' : ls+    | T.isPrefixOf "<" t = do+        ls <- takeTill (T.null . T.strip) >+> CL.consume+        yield $ BlockHtml $ T.intercalate "\n" $ t : ls+    | Just (ltype, t') <- listStart t = do+        let (spaces, t'') = T.span (== ' ') t'+        if T.length spaces >= 2+            then do+                let leader = T.length t - T.length t''+                ls <- getIndented leader >+> CL.consume+                let blocks = runIdentity $ mapM_ yield (t'' : ls) $$ toBlocksLines =$ CL.consume+                yield $ BlockList ltype $ Right blocks+            else yield $ BlockList ltype $ Left t''++    | otherwise = do+        -- Check for underline headings+        t2 <- CL.peek+        case t2 >>= getUnderline of+            Nothing -> do+                ls <- takeTill (T.null . T.strip) >+> CL.consume+                yield $ BlockPara $ T.intercalate "\n" $ t : ls+            Just level -> do+                CL.drop 1+                yield $ BlockHeading level t++takeTill :: Monad m => (i -> Bool) -> Pipe l i i u m Bool+takeTill f =+    loop+  where+    loop = await >>= maybe (return False) (\x -> if f x then return True else yield x >> loop)++listStart :: Text -> Maybe (ListType, Text)+listStart t+    | Just t' <- T.stripPrefix "* " t = Just (Unordered, t')+    | Just t' <- stripNumber t, Just t'' <- stripSeparator t' = Just (Ordered, t'')+    | otherwise = Nothing++stripNumber :: Text -> Maybe Text+stripNumber x+    | T.null y = Nothing+    | otherwise = Just z+  where+    (y, z) = T.span isDigit x++stripSeparator :: Text -> Maybe Text+stripSeparator x =+    case T.uncons x of+        Nothing -> Nothing+        Just ('.', y) -> Just y+        Just (')', y) -> Just y+        _ -> Nothing++getIndented :: Monad m => Int -> GLConduit Text m Text+getIndented leader =+    go []+  where+    go blanks = await >>= maybe (mapM_ leftover blanks) (go' blanks)++    go' blanks t+        | T.null $ T.strip t = go (T.drop leader t : blanks)+        | T.length x == leader && T.null (T.strip x) = do+            mapM_ yield $ reverse blanks+            yield y+            go []+        | otherwise = mapM_ leftover blanks >> leftover t+      where+        (x, y) = T.splitAt leader t++takeQuotes :: Monad m => GLConduit Text m Text+takeQuotes =+    await >>= maybe (return ()) go+  where+    go ">" = yield "" >> takeQuotes+    go t+        | Just t' <- T.stripPrefix "> " t = yield t' >> takeQuotes+        | otherwise = leftover t++isRule :: Text -> Bool+isRule "* * *" = True+isRule "***" = True+isRule "*****" = True+isRule "- - -" = True+isRule t = T.length (T.takeWhile (== '-') t) >= 5++stripHeading :: Text -> Maybe (Int, Text)+stripHeading t+    | T.null x = Nothing+    | otherwise = Just (T.length x, T.strip $ T.dropWhileEnd (== '#') y)+  where+    (x, y) = T.span (== '#') t++getUnderline :: Text -> Maybe Int+getUnderline t+    | T.length t < 2 = Nothing+    | T.all (== '=') t = Just 1+    | T.all (== '-') t = Just 2+    | otherwise = Nothing
+ Text/Markdown/Inline.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide #-}+module Text.Markdown.Inline+    ( Inline (..)+    , inlineParser+    , toInline+    ) where++import Prelude hiding (takeWhile)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Attoparsec.Text+import Control.Applicative+import Data.Monoid (Monoid, mappend)++toInline :: Text -> [Inline]+toInline t =+    case parseOnly inlineParser t of+        Left s -> [InlineText $ T.pack s]+        Right is -> is++(<>) :: Monoid m => m -> m -> m+(<>) = mappend++data Inline = InlineText Text+            | InlineItalic [Inline]+            | InlineBold [Inline]+            | InlineCode Text+            | InlineHtml Text+            | InlineLink Text (Maybe Text) [Inline] -- ^ URL, title, content+            | InlineImage Text (Maybe Text) Text -- ^ URL, title, content+    deriving (Show, Eq)++inlineParser :: Parser [Inline]+inlineParser = combine <$> many inlineAny++combine :: [Inline] -> [Inline]+combine [] = []+combine (InlineText x:InlineText y:rest) = combine (InlineText (x <> y):rest)+combine (InlineText x:rest) = InlineText x : combine rest+combine (InlineItalic x:InlineItalic y:rest) = combine (InlineItalic (x <> y):rest)+combine (InlineItalic x:rest) = InlineItalic (combine x) : combine rest+combine (InlineBold x:InlineBold y:rest) = combine (InlineBold (x <> y):rest)+combine (InlineBold x:rest) = InlineBold (combine x) : combine rest+combine (InlineCode x:InlineCode y:rest) = combine (InlineCode (x <> y):rest)+combine (InlineCode x:rest) = InlineCode x : combine rest+combine (InlineLink u t c:rest) = InlineLink u t (combine c) : combine rest+combine (InlineImage u t c:rest) = InlineImage u t c : combine rest+combine (InlineHtml t:rest) = InlineHtml t : combine rest++inlinesTill :: Text -> Parser [Inline]+inlinesTill end =+    go id+  where+    go front =+        (string end *> pure (front []))+        <|> (do+            x <- inline+            go $ front . (x:))++specials :: [Char]+specials = "*_`\\[]!<&"++inlineAny :: Parser Inline+inlineAny =+    inline <|> special+  where+    special = InlineText . T.singleton <$> satisfy (`elem` specials)++inline :: Parser Inline+inline =+    text+    <|> escape+    <|> paired "**" InlineBold <|> paired "__" InlineBold+    <|> paired "*" InlineItalic <|> paired "_" InlineItalic+    <|> code+    <|> link+    <|> image+    <|> html+    <|> entity+  where+    text = InlineText <$> takeWhile1 (`notElem` specials)++    paired t wrap = wrap <$> do+        _ <- string t+        is <- inlinesTill t+        if null is then fail "wrapped around something missing" else return is++    code = InlineCode <$> (char '`' *> takeWhile1 (/= '`') <* char '`')++    escape = InlineText . T.singleton <$> (char '\\' *> satisfy (`elem` specials))++    link = do+        _ <- char '['+        content <- inlinesTill "]"+        _ <- char '('+        url <- T.pack <$> many1 hrefChar+        mtitle <- (Just <$> title) <|> pure Nothing+        _ <- char ')'+        return $ InlineLink url mtitle content++    image = do+        _ <- string "!["+        content <- takeWhile (/= ']')+        _ <- string "]("+        url <- T.pack <$> many1 hrefChar+        mtitle <- (Just <$> title) <|> pure Nothing+        _ <- char ')'+        return $ InlineImage url mtitle content++    title = T.pack <$> (space *> char '"' *> many titleChar <* char '"')++    titleChar :: Parser Char+    titleChar = (char '\\' *> anyChar) <|> satisfy (/= '"')++    html = do+        c <- char '<'+        t <- takeWhile1 (\x -> ('A' <= x && x <= 'Z') || ('a' <= x && x <= 'z') || x == '/')+        if T.null t+            then fail "invalid tag"+            else do+                t2 <- takeWhile (/= '>')+                c2 <- char '>'+                return $ InlineHtml $ T.concat+                    [ T.singleton c+                    , t+                    , t2+                    , T.singleton c2+                    ]++    entity =+            rawent "&lt;"+        <|> rawent "&gt;"+        <|> rawent "&amp;"+        <|> rawent "&quot;"+        <|> rawent "&apos;"+        <|> decEnt+        <|> hexEnt++    rawent t = InlineHtml <$> string t++    decEnt = do+        s <- string "&#"+        t <- takeWhile1 $ \x -> ('0' <= x && x <= '9')+        c <- char ';'+        return $ InlineHtml $ T.concat+            [ s+            , t+            , T.singleton c+            ]++    hexEnt = do+        s <- string "&#x" <|> string "&#X"+        t <- takeWhile1 $ \x -> ('0' <= x && x <= '9') || ('A' <= x && x <= 'F') || ('a' <= x && x <= 'f')+        c <- char ';'+        return $ InlineHtml $ T.concat+            [ s+            , t+            , T.singleton c+            ]++hrefChar :: Parser Char+hrefChar = (char '\\' *> anyChar) <|> satisfy (notInClass " )")
+ markdown.cabal view
@@ -0,0 +1,50 @@+Name:                markdown+Version:             0.1.0+Synopsis:            Convert Markdown to HTML, with XSS protection+Description:         This library leverages existing high-performance libraries (attoparsec, blaze-html, text, and conduit), and should integrate well with existing codebases.+Homepage:            https://github.com/snoyberg/markdown+License:             BSD3+License-file:        LICENSE+Author:              Michael Snoyman+Maintainer:          michael@snoyman.com+Category:            Web+Build-type:          Simple+Extra-source-files:  test/examples/*.html, test/examples/*.md+Cabal-version:       >=1.8++Library+  Exposed-modules:     Text.Markdown+                       Text.Markdown.Block+                       Text.Markdown.Inline+  Build-depends:       base                   >= 4       && < 5+                     , blaze-html             >= 0.4+                     , attoparsec             >= 0.10+                     , attoparsec-conduit     >= 0.5     && < 0.6+                     , transformers           >= 0.2.2+                     , conduit                >= 0.5.2.1 && < 0.6+                     , text+                     , data-default           >= 0.3+                     , xss-sanitize++test-suite test+    hs-source-dirs: test+    main-is: main.hs+    other-modules: Block+                   Inline+    type: exitcode-stdio-1.0++    ghc-options:   -Wall+    build-depends: markdown+                 , base             >= 4       && < 5+                 , HUnit+                 , hspec            >= 1.2+                 , blaze-html+                 , text+                 , system-fileio+                 , system-filepath+                 , transformers+                 , conduit++source-repository head+  type:     git+  location: git://github.com/snoyberg/markdown.git
+ test/Block.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}+module Block+    ( blockSpecs+    ) where+import Test.Hspec.Monadic+import Test.Hspec.HUnit ()+import Test.HUnit hiding (Test)+import Data.Text (Text)+import Data.Conduit+import qualified Data.Conduit.List as CL+import Text.Markdown.Block+import Data.Functor.Identity (runIdentity)++check :: Text -> [Block Text] -> Assertion+check md blocks = runIdentity (yield md $$ toBlocks =$ CL.consume) @?= blocks++blockSpecs :: Spec+blockSpecs = do+    describe "tilde code" $ do+        it "simple" $ check+            "~~~haskell\nfoo\n\nbar\n~~~"+            [BlockCode (Just "haskell") "foo\n\nbar"]+        it "no lang" $ check+            "~~~\nfoo\n\nbar\n~~~"+            [BlockCode Nothing "foo\n\nbar"]+        it "no close" $ check+            "~~~\nfoo\n\nbar\n"+            [BlockPara " ~~~\nfoo", BlockPara "bar"]+    describe "list" $ do+        it "simple" $ check+            "* foo\n*    bar"+            [ BlockList Unordered (Left "foo")+            , BlockList Unordered (Right [BlockPara "bar"])+            ]+        it "nested" $ check+            "* foo\n*    1. bar\n     2. baz"+            [ BlockList Unordered (Left "foo")+            , BlockList Unordered (Right+                [ BlockList Ordered $ Left "bar"+                , BlockList Ordered $ Left "baz"+                ])+            ]+        it "with blank" $ check+            "*   foo\n\n    bar\n* baz"+            [ BlockList Unordered $ Right+                [ BlockPara "foo"+                , BlockPara "bar"+                ]+            , BlockList Unordered $ Left "baz"+            ]+    describe "blockquote" $ do+        it "simple" $ check+            "> foo\n>\n> * bar"+            [ BlockQuote+                [ BlockPara "foo"+                , BlockList Unordered $ Left "bar"+                ]+            ]+        it "blank" $ check+            "> foo\n\n> * bar"+            [ BlockQuote [BlockPara "foo"]+            , BlockQuote [BlockList Unordered $ Left "bar"]+            ]+    describe "indented code" $ do+        it "simple" $ check+            "    foo\n    bar\n"+            [ BlockCode Nothing "foo\nbar"+            ]+        it "blank" $ check+            "    foo\n\n    bar\n"+            [ BlockCode Nothing "foo\n\nbar"+            ]+        it "extra space" $ check+            "    foo\n\n     bar\n"+            [ BlockCode Nothing "foo\n\n bar"+            ]+    describe "html" $ do+        it "simple" $ check+            "<p>Hello world!</p>"+            [ BlockHtml "<p>Hello world!</p>"+            ]+        it "multiline" $ check+            "<p>Hello world!\n</p>"+            [ BlockHtml "<p>Hello world!\n</p>"+            ]
+ test/Inline.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}+module Inline+    ( inlineSpecs+    ) where++import Test.Hspec.Monadic+import Test.Hspec.HUnit ()+import Test.HUnit hiding (Test)+import Text.Markdown.Inline+import Data.Text (Text)++check :: Text -> [Inline] -> Assertion+check md ins = toInline md @?= ins++inlineSpecs :: Spec+inlineSpecs = do+    describe "raw text" $ do+        it "simple"+            $ check "raw text" [InlineText "raw text"]+        it "multiline"+            $ check "raw\ntext" [InlineText "raw\ntext"]+    describe "italic" $ do+        it "asterisk"+            $ check "raw *text*" [InlineText "raw ", InlineItalic [InlineText "text"]]+        it "underline"+            $ check "raw _text_" [InlineText "raw ", InlineItalic [InlineText "text"]]+        it "multiline"+            $ check "*raw\ntext*" [InlineItalic [InlineText "raw\ntext"]]+        it "mismatched"+            $ check "*foo* *bar" [InlineItalic [InlineText "foo"], InlineText " *bar"]+    describe "bold" $ do+        it "asterisk"+            $ check "raw **text**" [InlineText "raw ", InlineBold [InlineText "text"]]+        it "underline"+            $ check "raw __text__" [InlineText "raw ", InlineBold [InlineText "text"]]+        it "multiline"+            $ check "**raw\ntext**" [InlineBold [InlineText "raw\ntext"]]+        it "mismatched"+            $ check "**foo** *bar" [InlineBold [InlineText "foo"], InlineText " *bar"]+    describe "nested" $ do+        it "bold inside italic"+            $ check "*i __ib__ i*" [InlineItalic [InlineText "i ", InlineBold [InlineText "ib"], InlineText " i"]]+        it "bold inside italic swap"+            $ check "_i **ib** i_" [InlineItalic [InlineText "i ", InlineBold [InlineText "ib"], InlineText " i"]]+        it "italic inside bold"+            $ check "**b _ib_ b**" [InlineBold [InlineText "b ", InlineItalic [InlineText "ib"], InlineText " b"]]+        it "italic inside bold swap"+            $ check "__b *ib* b__" [InlineBold [InlineText "b ", InlineItalic [InlineText "ib"], InlineText " b"]]+    describe "code" $ do+        it "takes all characters"+            $ check "`foo*__*bar` baz`"+                [ InlineCode "foo*__*bar"+                , InlineText " baz`"+                ]+    describe "escaping" $ do+        it "asterisk"+            $ check "\\*foo*\\\\" [InlineText "*foo*\\"]+    describe "links" $ do+        it "simple" $ check "[bar](foo)" [InlineLink "foo" Nothing [InlineText "bar"]]+        it "title" $ check+            "[bar](foo \"baz\")"+            [InlineLink "foo" (Just "baz") [InlineText "bar"]]+            {-+        it "escaped href" $ check+            "<p><a href=\"foo)\" title=\"baz\">bar</a></p>"+            "[bar](foo\\) \"baz\")"+        it "escaped title" $ check+            "<p><a href=\"foo)\" title=\"baz&quot;\">bar</a></p>"+            "[bar](foo\\) \"baz\\\"\")"+        it "inside a paragraph" $ check+            "<p>Hello <a href=\"foo\">bar</a> World</p>"+            "Hello [bar](foo) World"+        it "not a link" $ check+            "<p>Not a [ link</p>"+            "Not a [ link"+            -}
+ test/examples/closing-tags.html view
@@ -0,0 +1,1 @@+<ul><li><p>foo</p></li></ul>
+ test/examples/closing-tags.md view
@@ -0,0 +1,1 @@+* <p>foo</p>
+ test/examples/entities.html view
@@ -0,0 +1,1 @@+<p>1 &lt; 2 &amp; 2 &gt; 1, also 1 &lt; 2 &amp; 2 &gt; 1   ý &amp;#xP;</p>
+ test/examples/entities.md view
@@ -0,0 +1,1 @@+1 < 2 & 2 > 1, also 1 &lt; 2 &amp; 2 &gt; 1 &#160; &#xfd; &#xP;
+ test/examples/list-blocks.html view
@@ -0,0 +1,1 @@+<ul><li><p>This is a paragraph.</p><p>Another paragraph.</p></li><li>Non-paragraph.</li><li><p>Item.</p><ul><li>Sublist item.</li><li><ol><li>Item 1</li><li>Item 2</li></ol></li></ul></li></ul>
+ test/examples/list-blocks.md view
@@ -0,0 +1,12 @@+*   This is a paragraph.++    Another paragraph.++* Non-paragraph.++*   Item.++    * Sublist item.++    *    1. Item 1+         2. Item 2
+ test/examples/tilde-code.html view
@@ -0,0 +1,4 @@+<pre><code class="haskell">foo+bar++baz</code></pre>
+ test/examples/tilde-code.md view
@@ -0,0 +1,6 @@+~~~haskell+foo+bar++baz+~~~
+ test/main.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE OverloadedStrings #-}+import Test.Hspec.Monadic+import Test.Hspec.HUnit ()+import Test.HUnit hiding (Test)+import Text.Markdown+import Data.Text.Lazy (Text, unpack, snoc, fromStrict)+import qualified Data.Text as T+import Text.Blaze.Html.Renderer.Text (renderHtml)+import Control.Monad (forM_)++import qualified Filesystem.Path.CurrentOS as F+import qualified Filesystem as F++import Block+import Inline++check :: Text -> Text -> Assertion+check html md = html @=? renderHtml (markdown def md)++check' :: Text -> Text -> Assertion+check' html md = html @=? renderHtml (markdown def { msXssProtect = False } md)++-- FIXME add quickcheck: all input is valid++main :: IO ()+main = do+  examples <- getExamples+  hspec $ do+    describe "block" blockSpecs+    describe "inline" inlineSpecs+    describe "paragraphs" $ do+        it "simple"+            $ check "<p>Hello World!</p>" "Hello World!"+        it "multiline"+            $ check "<p>Hello\nWorld!</p>" "Hello\nWorld!"+        it "multiple"+            $ check "<p>Hello</p><p>World!</p>" "Hello\n\nWorld!"+    describe "italics" $ do+        it "simple"+            $ check "<p><i>foo</i></p>" "*foo*"+        it "hanging"+            $ check "<p><i>foo</i> *</p>" "*foo* *"+        it "two"+            $ check "<p><i>foo</i> <i>bar</i></p>" "*foo* *bar*"+    describe "italics under" $ do+        it "simple"+            $ check "<p><i>foo</i></p>" "_foo_"+        it "hanging"+            $ check "<p><i>foo</i> _</p>" "_foo_ _"+        it "two"+            $ check "<p><i>foo</i> <i>bar</i></p>" "_foo_ _bar_"+    describe "bold" $ do+        it "simple"+            $ check "<p><b>foo</b></p>" "**foo**"+        it "hanging"+            $ check "<p><b>foo</b> **</p>" "**foo** **"+        it "two"+            $ check "<p><b>foo</b> <b>bar</b></p>" "**foo** **bar**"+    describe "bold under" $ do+        it "simple"+            $ check "<p><b>foo</b></p>" "__foo__"+        it "hanging"+            $ check "<p><b>foo</b> __</p>" "__foo__ __"+        it "two"+            $ check "<p><b>foo</b> <b>bar</b></p>" "__foo__ __bar__"+    describe "html" $ do+        it "simple"+            $ check "<div>Hello</div>" "<div>Hello</div>"+        it "dangerous"+            $ check "<div>Hello</div>" "<div onclick='alert(foo)'>Hello</div>"+        it "dangerous and allowed"+            $ check' "<div onclick='alert(foo)'>Hello</div>" "<div onclick='alert(foo)'>Hello</div>"++        let ml = "<div>foo\nbar\nbaz</div>"+        it "multiline" $ check ml ml++        let close = "<div>foo\nbar\nbaz"+        it "autoclose" $ check ml close++        let close2 = "<div>foo\nbar\nbaz\n\nparagraph"+        it "autoclose 2"+            $ check "<div>foo\nbar\nbaz</div><p>paragraph</p>" close2+    describe "inline code" $ do+        it "simple"+            $ check "<p>foo <code>bar</code> baz</p>" "foo `bar` baz"+    describe "code block" $ do+        it "simple"+            $ check+                "<pre><code>foo\n bar\nbaz</code></pre>"+                "    foo\n     bar\n    baz"+    describe "escaping" $ do+        it "everything"+            $ check+                "<p>*foo_bar<i>baz</i>\\`bin</p>"+                "\\*foo\\_bar_baz_\\\\\\`bin"+    describe "bullets" $ do+        it "simple"+            $ check+                "<ul><li>foo</li><li>bar</li><li>baz</li></ul>"+                "* foo\n* bar\n* baz\n"+    describe "numbers" $ do+        it "simple"+            $ check+                "<ol><li>foo</li><li>bar</li><li>baz</li></ol>"+                "5. foo\n2. bar\n1. baz\n"+    describe "headings" $ do+        it "hashes"+            $ check+                "<h1>foo</h1><h2>bar</h2><h3>baz</h3>"+                "# foo\n\n##     bar\n\n###baz"+        it "trailing hashes"+            $ check+                "<h1>foo</h1>"+                "# foo    ####"+        it "underline"+            $ check+                "<h1>foo</h1><h2>bar</h2>"+                "foo\n=============\n\nbar\n----------------\n"+    describe "blockquotes" $ do+        it "simple"+            $ check+                "<blockquote><p>foo</p><pre><code>bar</code></pre></blockquote>"+                "> foo\n>\n>     bar"+    describe "links" $ do+        it "simple" $ check "<p><a href=\"foo\">bar</a></p>" "[bar](foo)"+        it "title" $ check+            "<p><a href=\"foo\" title=\"baz\">bar</a></p>"+            "[bar](foo \"baz\")"+        it "escaped href" $ check+            "<p><a href=\"foo)\" title=\"baz\">bar</a></p>"+            "[bar](foo\\) \"baz\")"+        it "escaped title" $ check+            "<p><a href=\"foo)\" title=\"baz&quot;\">bar</a></p>"+            "[bar](foo\\) \"baz\\\"\")"+        it "inside a paragraph" $ check+            "<p>Hello <a href=\"foo\">bar</a> World</p>"+            "Hello [bar](foo) World"+        it "not a link" $ check+            "<p>Not a [ link</p>"+            "Not a [ link"++    {-+    describe "github links" $ do+        it "simple" $ check "<p><a href=\"foo\">bar</a></p>" "[[bar|foo]]"+        it "no link text" $ check "<p><a href=\"foo\">foo</a></p>" "[[foo]]"+        it "escaping" $ check "<p><a href=\"foo-baz-bin\">bar</a></p>" "[[bar|foo/baz bin]]"+        it "inside a list" $ check "<ul><li><a href=\"foo\">foo</a></li></ul>" "* [[foo]]"+    -}++    describe "images" $ do+        it "simple" $ check +            "<p><img src=\"http://link.to/image.jpg\" alt=\"foo\"></p>"+            "![foo](http://link.to/image.jpg)"+        it "title" $ check+            "<p><img src=\"http://link.to/image.jpg\" alt=\"foo\" title=\"bar\"></p>"+            "![foo](http://link.to/image.jpg \"bar\")"+        it "inside a paragraph" $ check+            "<p>Hello <img src=\"http://link.to/image.jpg\" alt=\"foo\"> World</p>"+            "Hello ![foo](http://link.to/image.jpg) World"+        it "not an image" $ check+            "<p>Not an ![ image</p>"+            "Not an ![ image"++    describe "rules" $ do+        let options = concatMap (\t -> [t, snoc t '\n'])+                [ "* * *"+                , "***"+                , "*****"+                , "- - -"+                , "---------------------------------------"+                , "----------------------------------"+                ]+        forM_ options $ \o -> it (unpack o) $ check "<hr>" o++    describe "html" $ do+        it "inline" $ check "<p>foo<br>bar</p>" "foo<br>bar"+        it "inline xss" $ check "<p>foo<br>bar</p>" "foo<br onclick='evil'>bar"+        it "block" $ check "<div>hello world</div>" "<div>hello world</div>"+        it "block xss" $ check "alert('evil')" "<script>alert('evil')</script>"+        it "should be escaped" $ check "<p>1 &lt; 2</p>" "1 < 2"+    describe "examples" $ sequence_ examples++getExamples :: IO [Spec]+getExamples = do+    files <- F.listDirectory "test/examples"+    mapM go $ filter (flip F.hasExtension "md") files+  where+    go fp = do+        input <- F.readTextFile fp+        output <- F.readTextFile $ F.replaceExtension fp "html"+        return $ it (F.encodeString $ F.basename fp) $ check (fromStrict $ T.strip output) (fromStrict input)