{-# 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 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 :: forall (m :: * -> *) bl il.
(Monad m, IsInline il, IsBlock il bl) =>
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 = [rebasedImageSpec, rebasedLinkSpec] }

 where

  rebasedImageSpec :: BracketedSpec il
  rebasedImageSpec :: BracketedSpec il
rebasedImageSpec =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
           { 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 a. a -> ParsecT [Tok] u Identity a
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 a. a -> ParsecT [Tok] u Identity a
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 :: FilePath
fp = SourcePos -> FilePath
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' :: FilePath
path' = Text -> FilePath
T.unpack Text
path
      isAbsolutePath :: Bool
isAbsolutePath = FilePath -> Bool
Posix.isAbsolute FilePath
path' Bool -> Bool -> Bool
|| FilePath -> Bool
Windows.isAbsolute FilePath
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 FilePath -> FilePath
takeDirectory FilePath
fp of
             FilePath
""  -> Text
path
             FilePath
"." -> Text
path
             FilePath
d   -> FilePath -> Text
T.pack FilePath
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
. FilePath -> Maybe URI
parseURI (FilePath -> Maybe URI) -> (Text -> FilePath) -> Text -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
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
. FilePath -> Text
T.pack (FilePath -> Text) -> (URI -> FilePath) -> URI -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> FilePath
uriScheme