From 2511c52d9452f60c533871ac111ba9473065310c Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 20 Nov 2021 02:30:20 +0100
Subject: 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.
---
 lib/Properties.hs | 59 +++++++++++++++++++++++++++++++++----------------------
 1 file changed, 35 insertions(+), 24 deletions(-)

(limited to 'lib/Properties.hs')

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<>"\""
-- 
cgit v1.2.3