{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Commonmark.Extensions.RebaseRelativePaths
( rebaseRelativePathsSpec )
where
import Commonmark.Types
import Commonmark.Syntax
import Commonmark.Inlines
import Data.Text (Text)
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
import Text.Parsec (getPosition)
import Text.Parsec.Pos (sourceName)
import System.FilePath
import qualified System.FilePath.Windows as Windows
import qualified System.FilePath.Posix as Posix
import Network.URI (URI (uriScheme), parseURI)
import qualified Data.Set as Set
rebaseRelativePathsSpec
:: forall m bl il . (Monad m , IsInline il , IsBlock il bl)
=> SyntaxSpec m il bl
rebaseRelativePathsSpec :: SyntaxSpec m il bl
rebaseRelativePathsSpec =
SyntaxSpec m il bl
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl
defaultSyntaxSpec {
syntaxBracketedSpecs :: [BracketedSpec il]
syntaxBracketedSpecs = [BracketedSpec il
rebasedImageSpec, BracketedSpec il
rebasedLinkSpec] }
where
rebasedImageSpec :: BracketedSpec il
rebasedImageSpec :: BracketedSpec il
rebasedImageSpec =BracketedSpec :: forall il.
Text
-> Bool
-> Maybe Char
-> Maybe Char
-> (ReferenceMap -> Text -> Parsec [Tok] () (il -> il))
-> BracketedSpec il
BracketedSpec
{ bracketedName :: Text
bracketedName = Text
"Image"
, bracketedNests :: Bool
bracketedNests = Bool
True
, bracketedPrefix :: Maybe Char
bracketedPrefix = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'!'
, bracketedSuffixEnd :: Maybe Char
bracketedSuffixEnd = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
')'
, bracketedSuffix :: ReferenceMap -> Text -> Parsec [Tok] () (il -> il)
bracketedSuffix = ReferenceMap -> Text -> Parsec [Tok] () (il -> il)
forall c u.
IsInline c =>
ReferenceMap -> Text -> ParsecT [Tok] u Identity (c -> c)
newImageSuffix
}
rebasedLinkSpec :: BracketedSpec il
rebasedLinkSpec :: BracketedSpec il
rebasedLinkSpec = BracketedSpec :: forall il.
Text
-> Bool
-> Maybe Char
-> Maybe Char
-> (ReferenceMap -> Text -> Parsec [Tok] () (il -> il))
-> BracketedSpec il
BracketedSpec
{ bracketedName :: Text
bracketedName = Text
"Link"
, bracketedNests :: Bool
bracketedNests = Bool
False
, bracketedPrefix :: Maybe Char
bracketedPrefix = Maybe Char
forall a. Maybe a
Nothing
, bracketedSuffixEnd :: Maybe Char
bracketedSuffixEnd = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
')'
, bracketedSuffix :: ReferenceMap -> Text -> Parsec [Tok] () (il -> il)
bracketedSuffix = ReferenceMap -> Text -> Parsec [Tok] () (il -> il)
forall c u.
IsInline c =>
ReferenceMap -> Text -> ParsecT [Tok] u Identity (c -> c)
newLinkSuffix
}
newImageSuffix :: ReferenceMap -> Text -> ParsecT [Tok] u Identity (c -> c)
newImageSuffix ReferenceMap
rm Text
key = do
SourcePos
pos <- ParsecT [Tok] u Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
LinkInfo Text
target Text
title Attributes
attrs Maybe SourcePos
mbpos <- ReferenceMap -> Text -> Parsec [Tok] u LinkInfo
forall s. ReferenceMap -> Text -> Parsec [Tok] s LinkInfo
pLink ReferenceMap
rm Text
key
let pos' :: SourcePos
pos' = SourcePos -> Maybe SourcePos -> SourcePos
forall a. a -> Maybe a -> a
fromMaybe SourcePos
pos Maybe SourcePos
mbpos
(c -> c) -> ParsecT [Tok] u Identity (c -> c)
forall (m :: * -> *) a. Monad m => a -> m a
return ((c -> c) -> ParsecT [Tok] u Identity (c -> c))
-> (c -> c) -> ParsecT [Tok] u Identity (c -> c)
forall a b. (a -> b) -> a -> b
$! Attributes -> c -> c
forall a. HasAttributes a => Attributes -> a -> a
addAttributes Attributes
attrs (c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> c -> c
forall a. IsInline a => Text -> Text -> a -> a
image (SourcePos -> Text -> Text
rebasePath SourcePos
pos' Text
target) Text
title
newLinkSuffix :: ReferenceMap -> Text -> ParsecT [Tok] u Identity (c -> c)
newLinkSuffix ReferenceMap
rm Text
key = do
SourcePos
pos <- ParsecT [Tok] u Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
LinkInfo Text
target Text
title Attributes
attrs Maybe SourcePos
mbpos <- ReferenceMap -> Text -> Parsec [Tok] u LinkInfo
forall s. ReferenceMap -> Text -> Parsec [Tok] s LinkInfo
pLink ReferenceMap
rm Text
key
let pos' :: SourcePos
pos' = SourcePos -> Maybe SourcePos -> SourcePos
forall a. a -> Maybe a -> a
fromMaybe SourcePos
pos Maybe SourcePos
mbpos
(c -> c) -> ParsecT [Tok] u Identity (c -> c)
forall (m :: * -> *) a. Monad m => a -> m a
return ((c -> c) -> ParsecT [Tok] u Identity (c -> c))
-> (c -> c) -> ParsecT [Tok] u Identity (c -> c)
forall a b. (a -> b) -> a -> b
$! Attributes -> c -> c
forall a. HasAttributes a => Attributes -> a -> a
addAttributes Attributes
attrs (c -> c) -> (c -> c) -> c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> c -> c
forall a. IsInline a => Text -> Text -> a -> a
link (SourcePos -> Text -> Text
rebasePath SourcePos
pos' Text
target) Text
title
rebasePath :: SourcePos -> Text -> Text
rebasePath :: SourcePos -> Text -> Text
rebasePath SourcePos
pos Text
path = do
let fp :: SourceName
fp = SourcePos -> SourceName
sourceName SourcePos
pos
isFragment :: Bool
isFragment = Int -> Text -> Text
T.take Int
1 Text
path Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"#"
path' :: SourceName
path' = Text -> SourceName
T.unpack Text
path
isAbsolutePath :: Bool
isAbsolutePath = SourceName -> Bool
Posix.isAbsolute SourceName
path' Bool -> Bool -> Bool
|| SourceName -> Bool
Windows.isAbsolute SourceName
path'
in if Text -> Bool
T.null Text
path Bool -> Bool -> Bool
|| Bool
isFragment Bool -> Bool -> Bool
|| Bool
isAbsolutePath Bool -> Bool -> Bool
|| Text -> Bool
isURI Text
path
then Text
path
else
case SourceName -> SourceName
takeDirectory SourceName
fp of
SourceName
"" -> Text
path
SourceName
"." -> Text
path
SourceName
d -> SourceName -> Text
T.pack SourceName
d Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path
schemes :: Set.Set T.Text
schemes :: Set Text
schemes = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
[ Text
"aaa", Text
"aaas", Text
"about", Text
"acap", Text
"acct", Text
"acr", Text
"adiumxtra", Text
"afp", Text
"afs"
, Text
"aim", Text
"appdata", Text
"apt", Text
"attachment", Text
"aw", Text
"barion", Text
"beshare", Text
"bitcoin"
, Text
"blob", Text
"bolo", Text
"browserext", Text
"callto", Text
"cap", Text
"chrome", Text
"chrome-extension"
, Text
"cid", Text
"coap", Text
"coaps", Text
"com-eventbrite-attendee", Text
"content", Text
"crid", Text
"cvs"
, Text
"data", Text
"dav", Text
"dict", Text
"dis", Text
"dlna-playcontainer", Text
"dlna-playsingle"
, Text
"dns", Text
"dntp", Text
"dtn", Text
"dvb", Text
"ed2k", Text
"example", Text
"facetime", Text
"fax", Text
"feed"
, Text
"feedready", Text
"file", Text
"filesystem", Text
"finger", Text
"fish", Text
"ftp", Text
"geo", Text
"gg"
, Text
"git", Text
"gizmoproject", Text
"go", Text
"gopher", Text
"graph", Text
"gtalk", Text
"h323", Text
"ham"
, Text
"hcp", Text
"http", Text
"https", Text
"hxxp", Text
"hxxps", Text
"hydrazone", Text
"iax", Text
"icap", Text
"icon"
, Text
"im", Text
"imap", Text
"info", Text
"iotdisco", Text
"ipn", Text
"ipp", Text
"ipps", Text
"irc", Text
"irc6"
, Text
"ircs", Text
"iris", Text
"iris.beep", Text
"iris.lwz", Text
"iris.xpc", Text
"iris.xpcs"
, Text
"isostore", Text
"itms", Text
"jabber", Text
"jar", Text
"jms", Text
"keyparc", Text
"lastfm", Text
"ldap"
, Text
"ldaps", Text
"lvlt", Text
"magnet", Text
"mailserver", Text
"mailto", Text
"maps", Text
"market"
, Text
"message", Text
"mid", Text
"mms", Text
"modem", Text
"mongodb", Text
"moz", Text
"ms-access"
, Text
"ms-browser-extension", Text
"ms-drive-to", Text
"ms-enrollment", Text
"ms-excel"
, Text
"ms-gamebarservices", Text
"ms-getoffice", Text
"ms-help", Text
"ms-infopath"
, Text
"ms-media-stream-id", Text
"ms-officeapp", Text
"ms-project", Text
"ms-powerpoint"
, Text
"ms-publisher", Text
"ms-search-repair", Text
"ms-secondary-screen-controller"
, Text
"ms-secondary-screen-setup", Text
"ms-settings", Text
"ms-settings-airplanemode"
, Text
"ms-settings-bluetooth", Text
"ms-settings-camera", Text
"ms-settings-cellular"
, Text
"ms-settings-cloudstorage", Text
"ms-settings-connectabledevices"
, Text
"ms-settings-displays-topology", Text
"ms-settings-emailandaccounts"
, Text
"ms-settings-language", Text
"ms-settings-location", Text
"ms-settings-lock"
, Text
"ms-settings-nfctransactions", Text
"ms-settings-notifications"
, Text
"ms-settings-power", Text
"ms-settings-privacy", Text
"ms-settings-proximity"
, Text
"ms-settings-screenrotation", Text
"ms-settings-wifi", Text
"ms-settings-workplace"
, Text
"ms-spd", Text
"ms-sttoverlay", Text
"ms-transit-to", Text
"ms-virtualtouchpad"
, Text
"ms-visio", Text
"ms-walk-to", Text
"ms-whiteboard", Text
"ms-whiteboard-cmd", Text
"ms-word"
, Text
"msnim", Text
"msrp", Text
"msrps", Text
"mtqp", Text
"mumble", Text
"mupdate", Text
"mvn", Text
"news", Text
"nfs"
, Text
"ni", Text
"nih", Text
"nntp", Text
"notes", Text
"ocf", Text
"oid", Text
"onenote", Text
"onenote-cmd"
, Text
"opaquelocktoken", Text
"pack", Text
"palm", Text
"paparazzi", Text
"pkcs11", Text
"platform", Text
"pop"
, Text
"pres", Text
"prospero", Text
"proxy", Text
"pwid", Text
"psyc", Text
"qb", Text
"query", Text
"redis"
, Text
"rediss", Text
"reload", Text
"res", Text
"resource", Text
"rmi", Text
"rsync", Text
"rtmfp", Text
"rtmp"
, Text
"rtsp", Text
"rtsps", Text
"rtspu", Text
"secondlife", Text
"service", Text
"session", Text
"sftp", Text
"sgn"
, Text
"shttp", Text
"sieve", Text
"sip", Text
"sips", Text
"skype", Text
"smb", Text
"sms", Text
"smtp", Text
"snews"
, Text
"snmp", Text
"soap.beep", Text
"soap.beeps", Text
"soldat", Text
"spotify", Text
"ssh", Text
"steam"
, Text
"stun", Text
"stuns", Text
"submit", Text
"svn", Text
"tag", Text
"teamspeak", Text
"tel", Text
"teliaeid"
, Text
"telnet", Text
"tftp", Text
"things", Text
"thismessage", Text
"tip", Text
"tn3270", Text
"tool", Text
"turn"
, Text
"turns", Text
"tv", Text
"udp", Text
"unreal", Text
"urn", Text
"ut2004", Text
"v-event", Text
"vemmi"
, Text
"ventrilo", Text
"videotex", Text
"vnc", Text
"view-source", Text
"wais", Text
"webcal", Text
"wpid"
, Text
"ws", Text
"wss", Text
"wtai", Text
"wyciwyg", Text
"xcon", Text
"xcon-userid", Text
"xfire"
, Text
"xmlrpc.beep", Text
"xmlrpc.beeps", Text
"xmpp", Text
"xri", Text
"ymsgr", Text
"z39.50", Text
"z39.50r"
, Text
"z39.50s"
, Text
"doi", Text
"isbn", Text
"javascript", Text
"pmid"
]
isURI :: T.Text -> Bool
isURI :: Text -> Bool
isURI = Bool -> (URI -> Bool) -> Maybe URI -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False URI -> Bool
hasKnownScheme (Maybe URI -> Bool) -> (Text -> Maybe URI) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceName -> Maybe URI
parseURI (SourceName -> Maybe URI)
-> (Text -> SourceName) -> Text -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SourceName
T.unpack
where
hasKnownScheme :: URI -> Bool
hasKnownScheme = (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
schemes) (Text -> Bool) -> (URI -> Text) -> URI -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower (Text -> Text) -> (URI -> Text) -> URI -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') (Text -> Text) -> (URI -> Text) -> URI -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceName -> Text
T.pack (SourceName -> Text) -> (URI -> SourceName) -> URI -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> SourceName
uriScheme