From ccb57f9a16b47aab55f786b976b0b8e89ff49f36 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Sat, 18 Sep 2021 23:21:15 +0200
Subject: [PATCH] collecting map dependencies
---
lib/CheckMap.hs | 15 ++++++++++-----
lib/LintWriter.hs | 20 ++++++++++++++++++--
lib/Properties.hs | 30 ++++++++++++++++++++++--------
lib/Types.hs | 25 ++++++++++++++++++++-----
4 files changed, 70 insertions(+), 20 deletions(-)
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 9402170..9908fdd 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -16,12 +16,13 @@ import qualified Data.Text as T
import qualified Data.Vector as V
import GHC.Generics (Generic)
-import LintWriter (LintResult (..), LintWriter)
+import LintWriter (LintResult (..), LintWriter,
+ lintsToDeps)
import Properties (checkProperty)
import Tiled2 (Layer (layerName, layerProperties),
Tiledmap (tiledmapLayers),
loadTiledmap)
-import Types (Level (..), Lint (..), hint,
+import Types (Dep, Level (..), Lint (..), hint,
lintLevel)
import Util (PrettyPrint (prettyprint),
prettyprint)
@@ -31,6 +32,7 @@ import Util (PrettyPrint (prettyprint),
data MapResult a = MapResult
{ mapresultLayer :: Maybe (Map Text (LintResult a))
, mapresultGeneral :: [Lint]
+ , mapresultDepends :: [Dep]
} deriving (Generic, ToJSON)
@@ -40,6 +42,7 @@ loadAndLintMap :: FilePath -> IO (MapResult ())
loadAndLintMap path = loadTiledmap path >>= pure . \case
Left err -> MapResult
{ mapresultLayer = Nothing
+ , mapresultDepends = []
, mapresultGeneral =
[ hint Fatal . T.pack $
path <> ": parse error (probably invalid json/not a tiled map): " <> err
@@ -51,12 +54,14 @@ loadAndLintMap path = loadTiledmap path >>= pure . \case
-- | lint a loaded map
runLinter :: Tiledmap -> MapResult ()
runLinter tiledmap = MapResult
- { mapresultLayer = Just layer
+ { mapresultLayer = Just layerMap
, mapresultGeneral = [] -- no general lints for now
+ , mapresultDepends = concatMap (lintsToDeps . snd) layer
}
where
- layer :: Map Text (LintResult ())
- layer = fromList . V.toList . V.map runCheck $ tiledmapLayers tiledmap
+ layerMap :: Map Text (LintResult ())
+ layerMap = fromList layer
+ layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap
where runCheck l = (layerName l, LintResult $ runWriterT (checkLayer l))
-- | collect lints on a single map layer
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 66f16f1..055e2d4 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -12,6 +13,7 @@ import Control.Monad.Writer (MonadTrans (lift),
import Data.Aeson (ToJSON (toJSON))
import Data.Text (Text)
+import Data.Maybe (mapMaybe)
import Types
-- | a monad to collect hints. If it yields Left, then the
@@ -32,14 +34,24 @@ instance ToJSON a => ToJSON (LintResult a) where
where toJson' (Left hint) = toJSON [hint]
toJson' (Right (_, hints)) = toJSON hints
+lintToDep :: Lint -> Maybe Dep
+lintToDep = \case
+ Depends dep -> Just dep
+ _ -> Nothing
+
+lintsToDeps :: LintResult a -> [Dep]
+lintsToDeps (LintResult a) = case a of
+ Left (Depends dep) -> [dep]
+ Left _ -> []
+ Right (_, lints) -> mapMaybe lintToDep lints
-- | write a hint into the LintWriter monad
lint :: Level -> Text -> LintWriter ()
lint level = tell . (: []) . hint level
-require :: Text -> LintWriter ()
-require dep = tell . (: []) $ Depends (Dep dep)
+dependsOn :: Dep -> LintWriter ()
+dependsOn dep = tell . (: []) $ Depends dep
warn = lint Warning
info = lint Info
@@ -47,6 +59,10 @@ forbid = lint Forbidden
suggest = lint Suggestion
complain = lint Error
+dependsLocal = dependsOn . Local
+dependsLink = dependsOn . Link
+dependsMapService = dependsOn . MapLink
+
-- TODO: all these functions should probably also just operate on LintWriter
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 7d6fc4a..ebd34bb 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -6,14 +6,14 @@ module Properties (checkProperty) where
import Control.Monad (unless)
-import Data.Text (Text)
+import Data.Text (Text, isPrefixOf)
import Tiled2 (Layer (layerProperties), Property, propertyName,
propertyValue)
import Util (prettyprint)
-import LintWriter (LintWriter, complain, forbid, info, require,
+import LintWriter (LintWriter, complain, dependsOn, forbid, info,
suggest, warn)
-
+import Types
-- | the point of this module
--
-- given a property, check if it is valid. It gets a reference
@@ -37,27 +37,37 @@ checkProperty layer prop = case propName of
"jitsiConfig" -> isForbidden
"jitsiClientConfig" -> isForbidden
"jitsiRoomAdminTag" -> isForbidden
- "playAudio" -> do
- -- TODO: check for url validity?
- pure ()
+ "playAudio" ->
+ forbidHTTPAndThen $ dependsOn $ if "https://" `isPrefixOf` propValue
+ then Link propValue
+ else Local propValue
"audioLoop" ->
requireProperty "playAudio"
"audioVolume" ->
requireProperty "playAudio"
"openWebsite" -> do
suggestPropertyValue "openWebsiteTrigger" "onaction"
- require $ propertyValue prop
+ if "http://" `isPrefixOf` propValue
+ then complain "cannot load content over http into map, please use https or include your assets locally"
+ else dependsOn $
+ if "https://" `isPrefixOf` propValue
+ then Link propValue
+ else Local propValue
"openWebsiteTrigger" ->
requireProperty "openWebsite"
"openWebsitePolicy" ->
requireProperty "openWebsite"
- "exitUrl" -> pure ()
+ "exitUrl" ->
+ forbidHTTPAndThen $ dependsOn $ if "https://" `isPrefixOf` propValue
+ then MapLink propValue
+ else LocalMap propValue
"startLayer" -> pure ()
-- could also make this a "hard error" (i.e. Left), but then it
-- stops checking other properties as checkLayer short-circuits.
_ -> warn $ "unknown property type " <> prettyprint propName
where
propName = propertyName prop
+ propValue = propertyValue prop
-- | require some property in this layer
requireProperty name = unless (hasProperty name layer)
$ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint propName
@@ -67,6 +77,10 @@ checkProperty layer prop = case propName of
suggestPropertyValue :: Text -> Text -> LintWriter ()
suggestPropertyValue name value = unless (hasProperty name layer)
$ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value
+ forbidHTTPAndThen :: LintWriter () -> LintWriter ()
+ forbidHTTPAndThen andthen = if "http://" `isPrefixOf` propValue
+ then complain "cannot access content via http; either use https or include it locally instead."
+ else andthen
diff --git a/lib/Types.hs b/lib/Types.hs
index 79bbfab..2e683c0 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -27,8 +28,8 @@ data Level = Warning | Suggestion | Info | Forbidden | Error | Fatal
data Lint = Depends Dep | Lint Hint
-- | TODO: add a reasonable representation of possible urls
-newtype Dep = Dep Text
- deriving (Generic, ToJSON)
+data Dep = Local Text | Link Text | MapLink Text | LocalMap Text
+ deriving (Generic)
data Hint = Hint
{ hintLevel :: Level
@@ -42,8 +43,8 @@ hint level msg = Lint Hint { hintLevel = level, hintMsg = msg }
-- | dependencies just have level Info
lintLevel :: Lint -> Level
-lintLevel (Lint h) = hintLevel h
-lintLevel (Depends dep) = Info
+lintLevel (Lint h) = hintLevel h
+lintLevel (Depends _) = Info
instance PrettyPrint Lint where
prettyprint (Lint Hint { hintMsg, hintLevel } ) =
@@ -57,5 +58,19 @@ instance ToJSON Lint where
[ "hintMsg" .= prettyprint dep
, "hintLevel" .= A.String "Dependency Info" ]
+instance ToJSON Dep where
+ toJSON = \case
+ Local text -> json "local" text
+ Link text -> json "link" text
+ MapLink text -> json "mapservice" text
+ LocalMap text -> json "map" text
+ where
+ json :: A.Value -> Text -> A.Value
+ json kind text = A.object [ "kind" .= kind, "dep" .= text ]
+
instance PrettyPrint Dep where
- prettyprint (Dep txt) = txt
+ prettyprint = \case
+ Local dep -> "[local dep: " <> dep <> "]"
+ Link dep -> "[link dep: " <> dep <> "]"
+ MapLink dep -> "[map service dep: " <> dep <> "]"
+ LocalMap dep -> "[local map dep: " <> dep <> "]"
--
GitLab