Shared: Provide custom isURI that rejects unknown schemes [isURI]

We also export the set of known `schemes`.

The new function replaces the function of the same name
from `Network.URI`, as the latter did not check whether a scheme is
well-known.  E.g. MediaWiki wikis frequently feature pages with names
like `User:John`. These links were interpreted as URIs, thus turning
internal links into global links. This is prevented by also checking
whether the scheme of a URI is frequently used (i.e. is IANA registered
or an otherwise well-known scheme).

Fixes: #2713

Update set of well-known URIs from IANA list
All official IANA schemes (as of 2017-05-22) are included in the set of
known schemes.  The four non-official schemes doi, isbn, javascript, and
pmid are kept.

1 files changed, 68 insertions, 1 deletions

diff --git a/src/Text/Pandoc/Shared.hs b/src/Text/Pandoc/Shared.hs
index 3a61656e5..7a1e6f3e3 100644
--- a/src/Text/Pandoc/Shared.hs
+++ b/src/Text/Pandoc/Shared.hs
@@ -81,6 +81,9 @@ module Text.Pandoc.Shared (
                      openURL,
                      collapseFilePath,
                      filteredFilesFromArchive,
+                     -- * URI handling
+                     schemes,
+                     isURI,
                      -- * Error handling
                      mapLeft,
                      -- * for squashing blocks
@@ -104,7 +107,7 @@ import Data.List ( find, stripPrefix, intercalate )
 import Data.Maybe (mapMaybe)
 import Data.Version ( showVersion )
 import qualified Data.Map as M
-import Network.URI ( escapeURIString, unEscapeString )
+import Network.URI ( URI(uriScheme), escapeURIString, unEscapeString, parseURI )
 import qualified Data.Set as Set
 import System.Directory
 import System.FilePath (splitDirectories, isPathSeparator)
@@ -774,6 +777,70 @@ filteredFilesFromArchive zf f =
     fileAndBinary :: Archive -> FilePath -> Maybe (FilePath, BL.ByteString)
     fileAndBinary a fp = findEntryByPath fp a >>= \e -> Just (fp, fromEntry e)
 
+
+--
+-- IANA URIs
+--
+
+-- | Schemes from http://www.iana.org/assignments/uri-schemes.html plus
+-- the unofficial schemes doi, javascript, isbn, pmid.
+schemes :: Set.Set String
+schemes = Set.fromList
+  -- Official IANA schemes
+  [ "aaa", "aaas", "about", "acap", "acct", "acr", "adiumxtra", "afp", "afs"
+  , "aim", "appdata", "apt", "attachment", "aw", "barion", "beshare", "bitcoin"
+  , "blob", "bolo", "browserext", "callto", "cap", "chrome", "chrome-extension"
+  , "cid", "coap", "coaps", "com-eventbrite-attendee", "content", "crid", "cvs"
+  , "data", "dav", "dict", "dis", "dlna-playcontainer", "dlna-playsingle"
+  , "dns", "dntp", "dtn", "dvb", "ed2k", "example", "facetime", "fax", "feed"
+  , "feedready", "file", "filesystem", "finger", "fish", "ftp", "geo", "gg"
+  , "git", "gizmoproject", "go", "gopher", "graph", "gtalk", "h323", "ham"
+  , "hcp", "http", "https", "hxxp", "hxxps", "hydrazone", "iax", "icap", "icon"
+  , "im", "imap", "info", "iotdisco", "ipn", "ipp", "ipps", "irc", "irc6"
+  , "ircs", "iris", "iris.beep", "iris.lwz", "iris.xpc", "iris.xpcs"
+  , "isostore", "itms", "jabber", "jar", "jms", "keyparc", "lastfm", "ldap"
+  , "ldaps", "lvlt", "magnet", "mailserver", "mailto", "maps", "market"
+  , "message", "mid", "mms", "modem", "mongodb", "moz", "ms-access"
+  , "ms-browser-extension", "ms-drive-to", "ms-enrollment", "ms-excel"
+  , "ms-gamebarservices", "ms-getoffice", "ms-help", "ms-infopath"
+  , "ms-media-stream-id", "ms-officeapp", "ms-project", "ms-powerpoint"
+  , "ms-publisher", "ms-search-repair", "ms-secondary-screen-controller"
+  , "ms-secondary-screen-setup", "ms-settings", "ms-settings-airplanemode"
+  , "ms-settings-bluetooth", "ms-settings-camera", "ms-settings-cellular"
+  , "ms-settings-cloudstorage", "ms-settings-connectabledevices"
+  , "ms-settings-displays-topology", "ms-settings-emailandaccounts"
+  , "ms-settings-language", "ms-settings-location", "ms-settings-lock"
+  , "ms-settings-nfctransactions", "ms-settings-notifications"
+  , "ms-settings-power", "ms-settings-privacy", "ms-settings-proximity"
+  , "ms-settings-screenrotation", "ms-settings-wifi", "ms-settings-workplace"
+  , "ms-spd", "ms-sttoverlay", "ms-transit-to", "ms-virtualtouchpad"
+  , "ms-visio", "ms-walk-to", "ms-whiteboard", "ms-whiteboard-cmd", "ms-word"
+  , "msnim", "msrp", "msrps", "mtqp", "mumble", "mupdate", "mvn", "news", "nfs"
+  , "ni", "nih", "nntp", "notes", "ocf", "oid", "onenote", "onenote-cmd"
+  , "opaquelocktoken", "pack", "palm", "paparazzi", "pkcs11", "platform", "pop"
+  , "pres", "prospero", "proxy", "pwid", "psyc", "qb", "query", "redis"
+  , "rediss", "reload", "res", "resource", "rmi", "rsync", "rtmfp", "rtmp"
+  , "rtsp", "rtsps", "rtspu", "secondlife", "service", "session", "sftp", "sgn"
+  , "shttp", "sieve", "sip", "sips", "skype", "smb", "sms", "smtp", "snews"
+  , "snmp", "soap.beep", "soap.beeps", "soldat", "spotify", "ssh", "steam"
+  , "stun", "stuns", "submit", "svn", "tag", "teamspeak", "tel", "teliaeid"
+  , "telnet", "tftp", "things", "thismessage", "tip", "tn3270", "tool", "turn"
+  , "turns", "tv", "udp", "unreal", "urn", "ut2004", "v-event", "vemmi"
+  , "ventrilo", "videotex", "vnc", "view-source", "wais", "webcal", "wpid"
+  , "ws", "wss", "wtai", "wyciwyg", "xcon", "xcon-userid", "xfire"
+  , "xmlrpc.beep", "xmlrpc.beeps", "xmpp", "xri", "ymsgr", "z39.50", "z39.50r"
+  , "z39.50s"
+  -- Inofficial schemes
+  , "doi", "isbn", "javascript", "pmid"
+  ]
+
+-- | Check if the string is a valid URL with a IANA or frequently used but
+-- unofficial scheme (see @schemes@).
+isURI :: String -> Bool
+isURI = maybe False hasKnownScheme . parseURI
+  where
+    hasKnownScheme = (`Set.member` schemes) . filter (/= ':') . uriScheme
+
 ---
 --- Squash blocks into inlines
 ---