{-# 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 :: forall (m :: * -> *) bl il.
(Monad m, IsInline il, IsBlock il bl) =>
SyntaxSpec m il bl
rebaseRelativePathsSpec =
  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
            { bracketedName :: Text
bracketedName = Text
"Image"
            , bracketedNests :: Bool
bracketedNests = Bool
True
            , bracketedPrefix :: Maybe Char
bracketedPrefix = forall a. a -> Maybe a
Just Char
'!'
            , bracketedSuffixEnd :: Maybe Char
bracketedSuffixEnd = forall a. a -> Maybe a
Just Char
')'
            , bracketedSuffix :: ReferenceMap -> Text -> Parsec [Tok] () (il -> il)
bracketedSuffix = 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 = forall a. Maybe a
Nothing
           , bracketedSuffixEnd :: Maybe Char
bracketedSuffixEnd = forall a. a -> Maybe a
Just Char
')'
           , bracketedSuffix :: ReferenceMap -> Text -> Parsec [Tok] () (il -> il)
bracketedSuffix = 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 <- forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
    LinkInfo Text
target Text
title Attributes
attrs Maybe SourcePos
mbpos <- forall s. ReferenceMap -> Text -> Parsec [Tok] s LinkInfo
pLink ReferenceMap
rm Text
key
    let pos' :: SourcePos
pos' = forall a. a -> Maybe a -> a
fromMaybe SourcePos
pos Maybe SourcePos
mbpos
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. HasAttributes a => Attributes -> a -> a
addAttributes Attributes
attrs forall b c a. (b -> c) -> (a -> b) -> a -> 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 <- forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
    LinkInfo Text
target Text
title Attributes
attrs Maybe SourcePos
mbpos <- forall s. ReferenceMap -> Text -> Parsec [Tok] s LinkInfo
pLink ReferenceMap
rm Text
key
    let pos' :: SourcePos
pos' = forall a. a -> Maybe a -> a
fromMaybe SourcePos
pos Maybe SourcePos
mbpos
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. HasAttributes a => Attributes -> a -> a
addAttributes Attributes
attrs forall b c a. (b -> c) -> (a -> b) -> a -> 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 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 forall a. Semigroup a => a -> a -> a
<> 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 = 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False URI -> Bool
hasKnownScheme forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe URI
parseURI forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack
  where
    hasKnownScheme :: URI -> Bool
hasKnownScheme = (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
schemes) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                     (Char -> Bool) -> Text -> Text
T.filter (forall a. Eq a => a -> a -> Bool
/= Char
':') forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> FilePath
uriScheme