markdown 0.1.0.1 → 0.1.1
raw patch · 11 files changed
+310/−106 lines, 11 filesdep +containersdep −HUnitdep ~hspec
Dependencies added: containers
Dependencies removed: HUnit
Dependency ranges changed: hspec
Files
- Text/Markdown.hs +28/−7
- Text/Markdown/Block.hs +127/−38
- Text/Markdown/Inline.hs +104/−35
- markdown.cabal +4/−3
- test/Block.hs +9/−9
- test/Inline.hs +4/−5
- test/examples/list-blocks.html +1/−1
- test/examples/list-blocks.md +0/−1
- test/examples/lists-code.html +2/−0
- test/examples/lists-code.md +7/−0
- test/main.hs +24/−7
Text/Markdown.hs view
@@ -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 } "<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+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
Text/Markdown/Block.hs view
@@ -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)
Text/Markdown/Inline.hs view
@@ -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 '<'
markdown.cabal view
@@ -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
test/Block.hs view
@@ -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
test/Inline.hs view
@@ -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
test/examples/list-blocks.html view
@@ -1,1 +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>+<ul><li><p>This is a paragraph.</p><p>Another paragraph.</p></li><li><p>Non-paragraph.</p></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
@@ -7,6 +7,5 @@ * Item. * Sublist item.- * 1. Item 1 2. Item 2
+ test/examples/lists-code.html view
@@ -0,0 +1,2 @@+<ol><li>hello+world</li><li><p>hello</p><pre><code class="haskell">data Foo</code></pre></li></ol>
+ test/examples/lists-code.md view
@@ -0,0 +1,7 @@+1. hello+ world+2. hello++ ```haskell+ data Foo+ ```
test/main.hs view
@@ -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')" "<script>alert('evil')</script>" it "should be escaped" $ check "<p>1 < 2</p>" "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)