aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Text/Pandoc/Parsing.hs77
-rw-r--r--tests/markdown-reader-more.native2
2 files changed, 51 insertions, 28 deletions
diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs
index 922799171..503aa7f46 100644
--- a/src/Text/Pandoc/Parsing.hs
+++ b/src/Text/Pandoc/Parsing.hs
@@ -151,9 +151,9 @@ import Text.Pandoc.Builder (Blocks, Inlines)
import qualified Text.Pandoc.UTF8 as UTF8 (putStrLn)
import Text.Parsec
import Text.Parsec.Pos (newPos)
-import Data.Char ( toLower, toUpper, ord, isAscii, isAlphaNum, isDigit, isPunctuation )
+import Data.Char ( toLower, toUpper, ord, isAscii, isAlphaNum, isDigit, isHexDigit,
+ isSpace )
import Data.List ( intercalate, transpose )
-import Network.URI ( parseURI, URI (..), isAllowedInURI, isUnescapedInURI, escapeURIString )
import Text.Pandoc.Shared
import qualified Data.Map as M
import Text.TeXMath.Macros (applyMacros, Macro, parseMacroDefinitions)
@@ -354,37 +354,60 @@ emailAddress = try $ liftA2 toResult mailbox (char '@' *> domain)
sepby1 p sep = liftA2 (:) p (many (try $ sep >> p))
+-- Schemes from http://www.iana.org/assignments/uri-schemes.html plus
+-- the unofficial schemes coap, doi, javascript.
+schemes :: [String]
+schemes = ["coap","doi","javascript","aaa","aaas","about","acap","cap","cid",
+ "crid","data","dav","dict","dns","file","ftp","geo","go","gopher",
+ "h323","http","https","iax","icap","im","imap","info","ipp","iris",
+ "iris.beep","iris.xpc","iris.xpcs","iris.lwz","ldap","mailto","mid",
+ "msrp","msrps","mtqp","mupdate","news","nfs","ni","nih","nntp",
+ "opaquelocktoken","pop","pres","rtsp","service","session","shttp","sieve",
+ "sip","sips","sms","snmp","soap.beep","soap.beeps","tag","tel","telnet",
+ "tftp","thismessage","tn3270","tip","tv","urn","vemmi","ws","wss","xcon",
+ "xcon-userid","xmlrpc.beep","xmlrpc.beeps","xmpp","z39.50r","z39.50s",
+ "adiumxtra","afp","afs","aim","apt","attachment","aw","beshare","bitcoin",
+ "bolo","callto","chrome","chrome-extension","com-eventbrite-attendee",
+ "content", "cvs","dlna-playsingle","dlna-playcontainer","dtn","dvb",
+ "ed2k","facetime","feed","finger","fish","gg","git","gizmoproject",
+ "gtalk","hcp","icon","ipn","irc","irc6","ircs","itms","jar","jms",
+ "keyparc","lastfm","ldaps","magnet","maps","market","message","mms",
+ "ms-help","msnim","mumble","mvn","notes","oid","palm","paparazzi",
+ "platform","proxy","psyc","query","res","resource","rmi","rsync",
+ "rtmp","secondlife","sftp","sgn","skype","smb","soldat","spotify",
+ "ssh","steam","svn","teamspeak","things","udp","unreal","ut2004",
+ "ventrilo","view-source","webcal","wtai","wyciwyg","xfire","xri",
+ "ymsgr"]
+
-- | Parses a URI. Returns pair of original and URI-escaped version.
uri :: Parser [Char] st (String, String)
uri = try $ do
- let protocols = [ "http:", "https:", "ftp:", "file:", "mailto:",
- "news:", "telnet:" ]
- lookAhead $ oneOfStrings protocols
- -- Scan non-ascii characters and ascii characters allowed in a URI.
- -- We allow punctuation except when followed by a space, since
- -- we don't want the trailing '.' in 'http://google.com.'
- let innerPunct = try $ satisfy isPunctuation >>~
- notFollowedBy (newline <|> spaceChar)
- let uriChar = innerPunct <|>
- satisfy (\c -> not (isPunctuation c) &&
- (not (isAscii c) || isAllowedInURI c))
- -- We want to allow
+ scheme <- oneOfStrings schemes
+ char ':'
+ -- /^[\/\w\u0080-\uffff]+|%[A-Fa-f0-9]+|&#?\w+;|(?:[,]+|[\S])[%&~\w\u0080-\uffff]/
+ -- We allow punctuation except at the end, since
+ -- we don't want the trailing '.' in 'http://google.com.' We want to allow
-- http://en.wikipedia.org/wiki/State_of_emergency_(disambiguation)
-- as a URL, while NOT picking up the closing paren in
- -- (http://wikipedia.org)
- -- So we include balanced parens in the URL.
- let inParens = try $ do char '('
- res <- many uriChar
- char ')'
- return $ '(' : res ++ ")"
- str <- liftM concat $ many1 $ inParens <|> count 1 (innerPunct <|> uriChar)
+ -- (http://wikipedia.org). So we include balanced parens in the URL.
+ let isWordChar c = isAlphaNum c || c == '_' || c == '/' || not (isAscii c)
+ let wordChar = satisfy isWordChar
+ let percentEscaped = try $ char '%' >> skipMany1 (satisfy isHexDigit)
+ let entity = () <$ characterReference
+ let punct = skipMany1 (char ',')
+ <|> () <$ (satisfy (not . isSpace))
+ let uriChunk = skipMany1 wordChar
+ <|> percentEscaped
+ <|> entity
+ <|> (try $ punct >> notFollowedBy (satisfy $ not . isWordChar))
+ str <- snd `fmap` withRaw (skipMany1 ( () <$
+ (enclosed (char '(') (char ')') uriChunk
+ <|> enclosed (char '{') (char '}') uriChunk
+ <|> enclosed (char '[') (char ']') uriChunk)
+ <|> uriChunk))
str' <- option str $ char '/' >> return (str ++ "/")
- -- now see if they amount to an absolute URI
- case parseURI (escapeURIString isUnescapedInURI str') of
- Just uri' -> if uriScheme uri' `elem` protocols
- then return (str', show uri')
- else fail "not a URI"
- Nothing -> fail "not a URI"
+ let uri' = scheme ++ ":" ++ str'
+ return (uri', escapeURI uri')
-- | Applies a parser, returns tuple of its results and its horizontal
-- displacement (the difference between the source column at the end
diff --git a/tests/markdown-reader-more.native b/tests/markdown-reader-more.native
index 057bcf585..e76b12918 100644
--- a/tests/markdown-reader-more.native
+++ b/tests/markdown-reader-more.native
@@ -29,7 +29,7 @@
,Para [Str "`hi"]
,Para [Str "there`"]
,Header 2 ("multilingual-urls",[],[]) [Str "Multilingual",Space,Str "URLs"]
-,Para [Link [Str "http://\27979.com?\27979=\27979"] ("http://%E6%B5%8B.com?%E6%B5%8B=%E6%B5%8B","")]
+,Para [Link [Str "http://\27979.com?\27979=\27979"] ("http://\27979.com?\27979=\27979","")]
,Para [Link [Str "foo"] ("/bar/\27979?x=\27979","title")]
,Para [Link [Str "\27979@foo.\27979.baz"] ("mailto:\27979@foo.\27979.baz","")]
,Header 2 ("numbered-examples",[],[]) [Str "Numbered",Space,Str "examples"]