{-# 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  -- links don't nest inside links
           , 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

-- | Rebase a relative path, by adding the (relative) directory
-- of the containing source position.  Absolute links and URLs
-- are untouched.
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 from http://www.iana.org/assignments/uri-schemes.html plus
-- the unofficial schemes doi, javascript, isbn, pmid.
schemes :: Set.Set T.Text
schemes :: Set Text
schemes = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
  -- Official IANA schemes
  [ 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"
  -- Unofficial schemes
  , Text
"doi", Text
"isbn", Text
"javascript", Text
"pmid"
  ]

-- | Check if the string is a valid URL with a IANA or frequently used but
-- unofficial scheme (see @schemes@).
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