diff --git a/Text/Markdown.hs b/Text/Markdown.hs --- a/Text/Markdown.hs +++ b/Text/Markdown.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Text.Markdown ( -- * Functions markdown @@ -7,7 +8,7 @@ , msXssProtect -- * Newtype , Markdown (..) - -- * Convenience re-exports. + -- * Convenience re-exports , def ) where @@ -26,6 +27,8 @@ import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as HA import Text.HTML.SanitizeXSS (sanitizeBalance) +import qualified Data.Map as Map +import Data.String (IsString) -- | A settings type providing various configuration options. -- @@ -43,6 +46,7 @@ -- | A newtype wrapper providing a @ToHtml@ instance. newtype Markdown = Markdown TL.Text + deriving(Monoid, IsString) instance ToMarkup Markdown where toMarkup (Markdown t) = markdown def t @@ -57,13 +61,29 @@ -- >>> renderHtml $ markdown def { msXssProtect = False } "" -- "" 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 +markdown ms tl = runIdentity + $ CL.sourceList blocksH + $= toHtmlB ms + $$ CL.fold mappend mempty + where + fixBlock :: Block Text -> Block Html + fixBlock = fmap $ toHtmlI ms . toInline refs + blocksH :: [Block Html] + blocksH = map fixBlock blocks + + blocks :: [Block Text] + blocks = runIdentity + $ CL.sourceList (TL.toChunks tl) + $$ toBlocks + =$ CL.consume + + refs = + Map.unions $ map toRef blocks + where + toRef (BlockReference x y) = Map.singleton x y + toRef _ = Map.empty + data MState = NoState | InList ListType toHtmlB :: Monad m => MarkdownSettings -> GInfConduit (Block Html) m Html @@ -110,6 +130,7 @@ wrap 4 = H.h4 wrap 5 = H.h5 wrap _ = H.h6 + go BlockReference{} = return () blocksToHtml bs = runIdentity $ mapM_ yield bs $$ toHtmlB ms =$ CL.fold mappend mempty diff --git a/Text/Markdown/Block.hs b/Text/Markdown/Block.hs --- a/Text/Markdown/Block.hs +++ b/Text/Markdown/Block.hs @@ -28,6 +28,7 @@ | BlockHtml Text | BlockRule | BlockHeading Int inline + | BlockReference Text Text deriving (Show, Eq) instance Functor Block where @@ -39,71 +40,146 @@ fmap _ (BlockHtml t) = BlockHtml t fmap _ BlockRule = BlockRule fmap f (BlockHeading level i) = BlockHeading level (f i) + fmap _ (BlockReference x y) = BlockReference x y toBlocks :: Monad m => Conduit Text m (Block Text) -toBlocks = mapOutput noCR CT.lines =$= toBlocksLines +toBlocks = + mapOutput fixWS CT.lines =$= toBlocksLines + where + fixWS = T.pack . go 0 . T.unpack -toBlocksLines :: Monad m => GLInfConduit Text m (Block Text) -toBlocksLines = awaitForever start + go _ [] = [] + go i ('\r':cs) = go i cs + go i ('\t':cs) = + (replicate j ' ') ++ go (i + j) cs + where + j = 4 - (i `mod` 4) + go i (c:cs) = c : go (i + 1) cs -noCR :: Text -> Text -noCR t - | T.null t = t - | T.last t == '\r' = T.init t - | otherwise = t +toBlocksLines :: Monad m => Conduit Text m (Block Text) +toBlocksLines = awaitForever start =$= tightenLists -start :: Monad m => Text -> GLConduit Text m (Block Text) +tightenLists :: Monad m => GLInfConduit (Either Blank (Block Text)) m (Block Text) +tightenLists = + go Nothing + where + go mTightList = + awaitE >>= either return go' + where + go' (Left Blank) = go mTightList + go' (Right (BlockList ltNew contents)) = + case mTightList of + Just (ltOld, isTight) | ltOld == ltNew -> do + yield $ BlockList ltNew $ (if isTight then tighten else untighten) contents + go mTightList + _ -> do + isTight <- checkTight ltNew False + yield $ BlockList ltNew $ (if isTight then tighten else untighten) contents + go $ Just (ltNew, isTight) + go' (Right b) = yield b >> go Nothing + + tighten (Right [BlockPara t]) = Left t + tighten (Right []) = Left T.empty + tighten x = x + + untighten (Left t) = Right [BlockPara t] + untighten x = x + + checkTight lt sawBlank = do + await >>= maybe (return $ not sawBlank) go' + where + go' (Left Blank) = checkTight lt True + go' b@(Right (BlockList ltNext _)) | ltNext == lt = do + leftover b + return $ not sawBlank + go' b = leftover b >> return False + +data Blank = Blank + +start :: Monad m => Text -> GLConduit Text m (Either Blank (Block Text)) start t - | T.null $ T.strip t = return () - | isRule t = yield BlockRule + | T.null $ T.strip t = yield $ Left Blank | 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) + case finished of + Just _ -> yield $ Right $ BlockCode (if T.null lang then Nothing else Just lang) $ T.intercalate "\n" ls + Nothing -> mapM_ leftover (reverse $ T.cons ' ' t : ls) + | Just lang <- T.stripPrefix "```" t = do + (finished, ls) <- takeTill (== "```") >+> withUpstream CL.consume + case finished of + Just _ -> yield $ Right $ BlockCode (if T.null lang then Nothing else Just lang) $ T.intercalate "\n" ls + Nothing -> 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' + yield $ Right $ BlockQuote blocks + | Just (level, t') <- stripHeading t = yield $ Right $ 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 + yield $ Right $ BlockCode Nothing $ T.intercalate "\n" $ t' : ls + | isRule t = yield $ Right BlockRule + | isHtmlStart t = do ls <- takeTill (T.null . T.strip) >+> CL.consume - yield $ BlockHtml $ T.intercalate "\n" $ t : ls + yield $ Right $ 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'' + let t'' = T.dropWhile (== ' ') t' + let leader = T.length t - T.length t'' + ls <- getIndented leader >+> CL.consume + let blocks = runIdentity $ mapM_ yield (t'' : ls) $$ toBlocksLines =$ CL.consume + yield $ Right $ BlockList ltype $ Right blocks + | Just (x, y) <- getReference t = yield $ Right $ BlockReference x y + | 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 + let listStartIndent x = + case listStart x of + Just (_, y) -> T.take 2 y == " " + Nothing -> False + (mfinal, ls) <- takeTill (\x -> T.null (T.strip x) || listStartIndent x) >+> withUpstream CL.consume + maybe (return ()) leftover mfinal + yield $ Right $ BlockPara $ T.intercalate "\n" $ t : ls Just level -> do CL.drop 1 - yield $ BlockHeading level t + yield $ Right $ BlockHeading level t -takeTill :: Monad m => (i -> Bool) -> Pipe l i i u m Bool +isHtmlStart :: T.Text -> Bool +isHtmlStart t = + case T.stripPrefix "<" t of + Nothing -> False + Just t' -> + let (name, rest) = T.break (\c -> c `elem` " >/") t' + in T.all isValidTagName name && + not (T.null name) && + (not ("/" `T.isPrefixOf` rest) || ("/>" `T.isPrefixOf` rest)) + where + isValidTagName :: Char -> Bool + isValidTagName c = + ('A' <= c && c <= 'Z') || + ('a' <= c && c <= 'z') || + ('0' <= c && c <= '9') || + (c == '-') || + (c == '_') || + (c == '!') + +takeTill :: Monad m => (i -> Bool) -> Pipe l i i u m (Maybe i) takeTill f = loop where - loop = await >>= maybe (return False) (\x -> if f x then return True else yield x >> loop) + loop = await >>= maybe (return Nothing) (\x -> if f x then return (Just x) else yield x >> loop) listStart :: Text -> Maybe (ListType, Text) -listStart t +listStart t0 | Just t' <- T.stripPrefix "* " t = Just (Unordered, t') + | Just t' <- T.stripPrefix "+ " t = Just (Unordered, t') + | Just t' <- T.stripPrefix "- " t = Just (Unordered, t') | Just t' <- stripNumber t, Just t'' <- stripSeparator t' = Just (Ordered, t'') | otherwise = Nothing + where + t = T.stripStart t0 stripNumber :: Text -> Maybe Text stripNumber x @@ -146,11 +222,17 @@ | otherwise = leftover t isRule :: Text -> Bool -isRule "* * *" = True -isRule "***" = True -isRule "*****" = True -isRule "- - -" = True -isRule t = T.length (T.takeWhile (== '-') t) >= 5 +isRule = + go . T.strip + where + go "* * *" = True + go "***" = True + go "*****" = True + go "- - -" = True + go "---" = True + go "___" = True + go "_ _ _" = True + go t = T.length (T.takeWhile (== '-') t) >= 5 stripHeading :: Text -> Maybe (Int, Text) stripHeading t @@ -165,3 +247,10 @@ | T.all (== '=') t = Just 1 | T.all (== '-') t = Just 2 | otherwise = Nothing + +getReference :: Text -> Maybe (Text, Text) +getReference a = do + b <- T.stripPrefix "[" $ T.dropWhile (== ' ') a + let (name, c) = T.break (== ']') b + d <- T.stripPrefix "]:" c + Just (name, T.strip d) diff --git a/Text/Markdown/Inline.hs b/Text/Markdown/Inline.hs --- a/Text/Markdown/Inline.hs +++ b/Text/Markdown/Inline.hs @@ -12,10 +12,13 @@ import Data.Attoparsec.Text import Control.Applicative import Data.Monoid (Monoid, mappend) +import qualified Data.Map as Map -toInline :: Text -> [Inline] -toInline t = - case parseOnly inlineParser t of +type RefMap = Map.Map Text Text + +toInline :: RefMap -> Text -> [Inline] +toInline refmap t = + case parseOnly (inlineParser refmap) t of Left s -> [InlineText $ T.pack s] Right is -> is @@ -31,8 +34,8 @@ | InlineImage Text (Maybe Text) Text -- ^ URL, title, content deriving (Show, Eq) -inlineParser :: Parser [Inline] -inlineParser = combine <$> many inlineAny +inlineParser :: RefMap -> Parser [Inline] +inlineParser = fmap combine . many . inlineAny combine :: [Inline] -> [Inline] combine [] = [] @@ -48,37 +51,38 @@ 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 +inlineAny :: RefMap -> Parser Inline +inlineAny refs = + inline refs <|> special where special = InlineText . T.singleton <$> satisfy (`elem` specials) -inline :: Parser Inline -inline = +inline :: RefMap -> Parser Inline +inline refs = text <|> escape <|> paired "**" InlineBold <|> paired "__" InlineBold <|> paired "*" InlineItalic <|> paired "_" InlineItalic - <|> code + <|> doubleCode <|> code <|> link <|> image + <|> autoLink <|> html <|> entity where + inlinesTill :: Text -> Parser [Inline] + inlinesTill end = + go id + where + go front = + (string end *> pure (front [])) + <|> (do + x <- inlineAny refs + go $ front . (x:)) + text = InlineText <$> takeWhile1 (`notElem` specials) paired t wrap = wrap <$> do @@ -86,32 +90,97 @@ is <- inlinesTill t if null is then fail "wrapped around something missing" else return is + doubleCode = InlineCode . T.pack <$> (string "`` " *> manyTill anyChar (string " ``")) code = InlineCode <$> (char '`' *> takeWhile1 (/= '`') <* char '`') - escape = InlineText . T.singleton <$> (char '\\' *> satisfy (`elem` specials)) + escape = InlineText . T.singleton <$> (char '\\' *> satisfy (`elem` "\\`*_{}[]()#+-.!>")) + takeBalancedBrackets = + T.pack <$> go (0 :: Int) + where + go i = do + c <- anyChar + case c of + '[' -> (c:) <$> go (i + 1) + ']' + | i == 0 -> return [] + | otherwise -> (c:) <$> go (i - 1) + _ -> (c:) <$> go i + + parseUrl = fixUrl . T.pack <$> parseUrl' (0 :: Int) + + parseUrl' level + | level > 0 = do + c <- anyChar + let level' + | c == ')' = level - 1 + | otherwise = level + c' <- + if c == '\\' + then anyChar + else return c + cs <- parseUrl' level' + return $ c' : cs + | otherwise = (do + c <- hrefChar + if c == '(' + then (c:) <$> parseUrl' 1 + else (c:) <$> parseUrl' 0) <|> return [] + + parseUrlTitle defRef = parseUrlTitleInline <|> parseUrlTitleRef defRef + + parseUrlTitleInside endTitle = do + url <- parseUrl + mtitle <- (Just <$> title) <|> (skipSpace >> endTitle >> pure Nothing) + return (url, mtitle) + where + title = do + _ <- space + skipSpace + _ <- char '"' + t <- T.stripEnd . T.pack <$> go + return $ + if not (T.null t) && T.last t == '"' + then T.init t + else t + where + go = (char '\\' *> anyChar >>= \c -> (c:) <$> go) + <|> (endTitle *> return []) + <|> (anyChar >>= \c -> (c:) <$> go) + + parseUrlTitleInline = char '(' *> parseUrlTitleInside (char ')') + + parseUrlTitleRef defRef = do + ref' <- (skipSpace *> char '[' *> takeWhile (/= ']') <* char ']') <|> return "" + let ref = if T.null ref' then defRef else ref' + case Map.lookup (T.unwords $ T.words ref) refs of + Nothing -> fail "ref not found" + Just t -> either fail return $ parseOnly (parseUrlTitleInside endOfInput) t + link = do _ <- char '[' - content <- inlinesTill "]" - _ <- char '(' - url <- T.pack <$> many1 hrefChar - mtitle <- (Just <$> title) <|> pure Nothing - _ <- char ')' + rawContent <- takeBalancedBrackets + content <- either fail return $ parseOnly (inlineParser refs) rawContent + (url, mtitle) <- parseUrlTitle rawContent return $ InlineLink url mtitle content image = do _ <- string "![" - content <- takeWhile (/= ']') - _ <- string "](" - url <- T.pack <$> many1 hrefChar - mtitle <- (Just <$> title) <|> pure Nothing - _ <- char ')' + content <- takeBalancedBrackets + (url, mtitle) <- parseUrlTitle content return $ InlineImage url mtitle content - title = T.pack <$> (space *> char '"' *> many titleChar <* char '"') + fixUrl t + | T.length t > 2 && T.head t == '<' && T.last t == '>' = T.init $ T.tail t + | otherwise = t - titleChar :: Parser Char - titleChar = (char '\\' *> anyChar) <|> satisfy (/= '"') + autoLink = do + _ <- char '<' + a <- string "http:" <|> string "https:" + b <- takeWhile1 (/= '>') + _ <- char '>' + let url = a `T.append` b + return $ InlineLink url Nothing [InlineText url] html = do c <- char '<' diff --git a/markdown.cabal b/markdown.cabal --- a/markdown.cabal +++ b/markdown.cabal @@ -1,5 +1,5 @@ Name: markdown -Version: 0.1.0.1 +Version: 0.1.1 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 @@ -25,6 +25,8 @@ , text , data-default >= 0.3 , xss-sanitize + , containers + ghc-options: -Wall test-suite test hs-source-dirs: test @@ -36,8 +38,7 @@ ghc-options: -Wall build-depends: markdown , base >= 4 && < 5 - , HUnit - , hspec >= 1.2 + , hspec >= 1.3 , blaze-html , text , system-fileio diff --git a/test/Block.hs b/test/Block.hs --- a/test/Block.hs +++ b/test/Block.hs @@ -2,17 +2,15 @@ module Block ( blockSpecs ) where -import Test.Hspec.Monadic -import Test.Hspec.HUnit () -import Test.HUnit hiding (Test) +import Test.Hspec 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 +check :: Text -> [Block Text] -> Expectation +check md blocks = runIdentity (yield md $$ toBlocks =$ CL.consume) `shouldBe` blocks blockSpecs :: Spec blockSpecs = do @@ -28,8 +26,8 @@ [BlockPara " ~~~\nfoo", BlockPara "bar"] describe "list" $ do it "simple" $ check - "* foo\n* bar" - [ BlockList Unordered (Left "foo") + "* foo\n\n* bar\n\n" + [ BlockList Unordered (Right [BlockPara "foo"]) , BlockList Unordered (Right [BlockPara "bar"]) ] it "nested" $ check @@ -41,12 +39,14 @@ ]) ] it "with blank" $ check - "* foo\n\n bar\n* baz" + "* foo\n\n bar\n\n* baz" [ BlockList Unordered $ Right [ BlockPara "foo" , BlockPara "bar" ] - , BlockList Unordered $ Left "baz" + , BlockList Unordered $ Right + [ BlockPara "baz" + ] ] describe "blockquote" $ do it "simple" $ check diff --git a/test/Inline.hs b/test/Inline.hs --- a/test/Inline.hs +++ b/test/Inline.hs @@ -3,14 +3,13 @@ ( inlineSpecs ) where -import Test.Hspec.Monadic -import Test.Hspec.HUnit () -import Test.HUnit hiding (Test) +import Test.Hspec import Text.Markdown.Inline import Data.Text (Text) +import Data.Monoid (mempty) -check :: Text -> [Inline] -> Assertion -check md ins = toInline md @?= ins +check :: Text -> [Inline] -> Expectation +check md ins = toInline mempty md `shouldBe` ins inlineSpecs :: Spec inlineSpecs = do diff --git a/test/examples/list-blocks.html b/test/examples/list-blocks.html --- a/test/examples/list-blocks.html +++ b/test/examples/list-blocks.html @@ -1,1 +1,1 @@ - + diff --git a/test/examples/list-blocks.md b/test/examples/list-blocks.md --- a/test/examples/list-blocks.md +++ b/test/examples/list-blocks.md @@ -7,6 +7,5 @@ * Item. * Sublist item. - * 1. Item 1 2. Item 2 diff --git a/test/examples/lists-code.html b/test/examples/lists-code.html new file mode 100644 --- /dev/null +++ b/test/examples/lists-code.html @@ -0,0 +1,2 @@ +
  1. hello +world

  2. hello

    data Foo
diff --git a/test/examples/lists-code.md b/test/examples/lists-code.md new file mode 100644 --- /dev/null +++ b/test/examples/lists-code.md @@ -0,0 +1,7 @@ +1. hello + world +2. hello + + ```haskell + data Foo + ``` diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,10 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Hspec.Monadic -import Test.Hspec.HUnit () -import Test.HUnit hiding (Test) +import Test.Hspec import Text.Markdown import Data.Text.Lazy (Text, unpack, snoc, fromStrict) import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import Text.Blaze.Html.Renderer.Text (renderHtml) import Control.Monad (forM_) @@ -14,17 +13,24 @@ import Block import Inline -check :: Text -> Text -> Assertion -check html md = html @=? renderHtml (markdown def md) +check :: Text -> Text -> Expectation +check html md = renderHtml (markdown def md) `shouldBe` html -check' :: Text -> Text -> Assertion -check' html md = html @=? renderHtml (markdown def { msXssProtect = False } md) +check' :: Text -> Text -> Expectation +check' html md = renderHtml (markdown def { msXssProtect = False } md) `shouldBe` html +checkNoNL :: Text -> Text -> Expectation +checkNoNL html md = + f (renderHtml $ markdown def { msXssProtect = False } md) `shouldBe` f html + where + f = TL.filter (/= '\n') + -- FIXME add quickcheck: all input is valid main :: IO () main = do examples <- getExamples + gruber <- getGruber hspec $ do describe "block" blockSpecs describe "inline" inlineSpecs @@ -179,6 +185,7 @@ it "block xss" $ check "alert('evil')" "" it "should be escaped" $ check "

1 < 2

" "1 < 2" describe "examples" $ sequence_ examples + describe "John Gruber's test suite" $ sequence_ gruber getExamples :: IO [Spec] getExamples = do @@ -189,3 +196,13 @@ 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) + +getGruber :: IO [Spec] +getGruber = do + files <- F.listDirectory "test/Tests" + mapM go $ filter (flip F.hasExtension "text") files + where + go fp = do + input <- F.readTextFile fp + output <- F.readTextFile $ F.replaceExtension fp "html" + return $ it (F.encodeString $ F.basename fp) $ checkNoNL (fromStrict $ T.strip output) (fromStrict input)