diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/CheckMap.hs | 15 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 20 | ||||
| -rw-r--r-- | lib/Properties.hs | 30 | ||||
| -rw-r--r-- | 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 <> "]" |