make link adjustments configurable

this allows for creating custom URI "schemas" in the linter's config,
which may be either allowed, prefixed, or translated according to
some (domain-based) substitution.

3 files changed, 48 insertions, 43 deletions

diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs
index d976352..f540ae1 100644
--- a/lib/LintConfig.hs
+++ b/lib/LintConfig.hs
@@ -21,10 +21,10 @@ import           Data.Text              (Text)
 import           GHC.Generics           (Generic (Rep, from, to), K1 (..),
                                          M1 (..), (:*:) (..))
 import           Types                  (Level)
+import           Uris                   (SchemaSet)
 import           WithCli                (Proxy (..))
 import           WithCli.Pure           (Argument (argumentType, parseArgument))
 
-
 type family HKD f a where
   HKD Identity a = a
   HKD f a = f a
@@ -40,12 +40,7 @@ data LintConfig f = LintConfig
   -- ^ Don't copy map assets (mostly useful for development)
   , configAllowScripts   :: HKD f Bool
   -- ^ Allow defining custom scripts in maps
-  , configLinkPrefix     :: HKD f Text
-  -- ^ prefix that will be added to all outgoing weblinks
-  , configAllowedDomains :: HKD f [Text]
-  -- ^ domains that are allowed in weblinks and will not be modified
-  , configBlockedDomains :: HKD f [Text]
-  -- ^ domains that are blocked; weblinks to these is an error
+  , configUriSchemas     :: HKD f SchemaSet
   } deriving (Generic)
 
 type LintConfig' = LintConfig Identity
@@ -57,6 +52,7 @@ deriving instance
   , Show (HKD a Level)
   , Show (HKD a [Text])
   , Show (HKD a Bool)
+  , Show (HKD a SchemaSet)
   )
   => Show (LintConfig a)
 
@@ -73,6 +69,7 @@ instance
     , FromJSON (HKD a Text)
     , FromJSON (HKD a Level)
     , FromJSON (HKD a Bool)
+    , FromJSON (HKD a SchemaSet)
     )
     => FromJSON (LintConfig a)
   where
diff --git a/lib/Paths.hs b/lib/Paths.hs
index 4082268..b628ee8 100644
--- a/lib/Paths.hs
+++ b/lib/Paths.hs
@@ -1,10 +1,11 @@
+{-# LANGUAGE MultiWayIf        #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | Paths are horrible, so they have their own module now.
 -- I just hope you are running this on some kind of Unix
 module Paths where
 
-import           Data.Text             (Text)
+import           Data.Text             (Text, isPrefixOf)
 import qualified Data.Text             as T
 import           System.FilePath       (splitPath)
 import           System.FilePath.Posix ((</>))
@@ -18,21 +19,17 @@ data RelPath = Path Int Text (Maybe Text)
   deriving (Show, Eq, Ord)
 
 
-extractDomain :: Text -> Maybe Text
-extractDomain url =
-  let (_,_,_,matches) = url =~ ("^https://([^/]+)/?.*$" :: Text) :: (Text,Text,Text,[Text])
-  in case matches of
-      [domain] -> Just domain
-      _ -> Nothing
-
 
+data PathResult = OkRelPath RelPath | AbsolutePath | NotAPath | UnderscoreMapLink | AtMapLink
 
 -- | horrible regex parsing for filepaths that is hopefully kinda safe
-parsePath :: Text -> Maybe RelPath
+parsePath :: Text -> PathResult
 parsePath text =
-  if rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) :: Bool
-  then Just $ Path up path fragment
-  else Nothing
+  if | rest =~ ("^([^/]*[^\\./]/)*[^/]*[^\\./]$" :: Text) -> OkRelPath (Path up path fragment)
+     | "/_/" `isPrefixOf` text ->  UnderscoreMapLink
+     | "/@/" `isPrefixOf` text ->  AtMapLink
+     | "/" `isPrefixOf` text ->  AbsolutePath
+     | otherwise ->  NotAPath
   where
     (_, prefix, rest, _) =
       text =~ ("^((\\.|\\.\\.)/)*" :: Text) :: (Text, Text, Text, [Text])
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 3169e4d..ea9f1ac 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -2,8 +2,10 @@
 {-# LANGUAGE MultiWayIf        #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications  #-}
 
 -- | Contains checks for custom ties of the map json
+{-# LANGUAGE DataKinds         #-}
 module Properties (checkMap, checkTileset, checkLayer) where
 
 
@@ -15,13 +17,16 @@ import           Tiled2        (HasProperties (adjustProperties, getProperties),
                                 Tiledmap (..), Tileset (..))
 import           Util          (layerIsEmpty, prettyprint, showText)
 
+import           Data.Data     (Proxy (Proxy))
 import           Data.Maybe    (fromMaybe, isJust)
+import           GHC.TypeLits  (KnownSymbol)
 import           LintConfig    (LintConfig (..))
 import           LintWriter    (LintWriter, adjust, askContext, askFileDepth,
                                 complain, dependsOn, forbid, lintConfig,
                                 offersEntrypoint, suggest, warn)
-import           Paths         (RelPath (..), parsePath, extractDomain)
+import           Paths         (PathResult (..), RelPath (..), parsePath)
 import           Types         (Dep (Link, Local, LocalMap, MapLink))
+import           Uris          (SubstError (..), applySubst)
 
 
 -- | Checks an entire map for "general" lints.
@@ -172,22 +177,9 @@ checkLayerProperty p@(Property name _value) = case name of
     "openWebsite" -> do
       uselessEmptyLayer
       suggestProperty $ Property "openWebsiteTrigger" (StrProp "onaction")
-      unwrapLink p $ \link -> if "https://" `isPrefixOf` link
-        then do
-          config <- lintConfig id
-          case extractDomain link of
-            Just domain
-              | domain `elem` configBlockedDomains config
-                -> complain $ "domain " <> domain <> " is blocked."
-              | domain `elem` configAllowedDomains config
-                -> dependsOn $ Link link
-              | otherwise
-                -> do
-                  dependsOn $ Link link
-                  prefix <- lintConfig configLinkPrefix
-                  setProperty "openWebsite" (prefix <> link)
-            Nothing -> complain "invalid link?"
-        else unwrapPath link (dependsOn . Local)
+      unwrapURI (Proxy @"website") p
+        (dependsOn . Link)
+        (dependsOn . Local)
     "openWebsiteTrigger" -> do
       isString p
       unlessHasProperty "openWebsiteTriggerMessage"
@@ -207,11 +199,9 @@ checkLayerProperty p@(Property name _value) = case name of
     "allowApi" -> isForbidden
     "exitUrl" -> do
       forbidEmptyLayer
-      unwrapLink p $ \link -> if
-        | "/_/" `isPrefixOf` link ->
-          complain "absolute map links (i.e. links starting with '/_/') are disallowed."
-        | "/@/" `isPrefixOf` link -> dependsOn $ MapLink link -- TODO
-        | otherwise -> unwrapPath link (dependsOn . LocalMap)
+      unwrapURI (Proxy @"map") p
+        (dependsOn . MapLink)
+        (dependsOn . LocalMap)
     "exitSceneUrl" ->
       deprecatedUseInstead "exitUrl"
     "exitInstance" ->
@@ -350,12 +340,15 @@ unwrapInt (Property name value) f = case value of
 
 unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a
 unwrapPath str f = case parsePath str of
-  Just p@(Path up _ _) -> do
+  OkRelPath p@(Path up _ _) -> do
     depth <- askFileDepth
     if up <= depth
       then f p
       else complain $ "cannot acess paths \"" <> str <> "\" which is outside your repository"
-  Nothing   -> complain $ "path \"" <> str <> "\" is invalid"
+  NotAPath -> complain $ "path \"" <> str <> "\" is invalid"
+  AbsolutePath -> complain "absolute paths are disallowed. Use world:// instead."
+  UnderscoreMapLink -> complain "map links using /_/ are disallowed. Use world:// instead."
+  AtMapLink -> complain "map links using /@/ are disallowed. Use world:// instead."
 
 -- | just asserts that this is a string
 isString :: Property -> LintWriter a
@@ -369,3 +362,21 @@ isIntInRange :: Int -> Int -> Property -> LintWriter a
 isIntInRange l r p@(Property name _) = unwrapInt p $ \int ->
   if l < int && int < r then pure ()
   else complain $ "Property " <> prettyprint name <> " should be between" <> showText l <> " and " <> showText r
+
+
+unwrapURI :: (KnownSymbol s, HasProperties a)
+  => Proxy s -> Property -> (Text -> LintWriter a) -> (RelPath -> LintWriter a) -> LintWriter a
+unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do
+  subst <- lintConfig configUriSchemas
+  case applySubst sym subst link of
+    Right uri -> do
+      setProperty name uri
+      f uri
+    Left NotALink -> unwrapPath link g
+    Left err -> complain $ case err of
+      IsBlocked -> link <> " is a blocked site."
+      InvalidLink -> link <> " is invalid."
+      SchemaDoesNotExist schema ->
+        "the URI schema " <> schema <> ":// does not exist."
+      WrongScope schema ->
+        "the URI schema " <> schema <> ":// cannot be used on \""<>name<>"\""