From efb64e0228c19ef7936446d3ca14a7d7a6e2540b Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Sun, 28 Nov 2021 22:24:30 +0100
Subject: [PATCH] various fixes to bugs
Among them
- always set correct exit codes
- refuse to write out files if the out path already exists
- calculate the overall severity correctly
- slightly changed the json output schema
- also output the text output format in json
- make the default config.json suitable for a production environment
---
config.json | 6 ++---
lib/CheckDir.hs | 34 +++++++++++++++---------
lib/CheckMap.hs | 11 ++++----
lib/Properties.hs | 68 +++++++++++++++++++++++------------------------
lib/Types.hs | 7 +++--
lib/WriteRepo.hs | 59 ++++++++++++++++++++--------------------
src/Main.hs | 8 +++---
7 files changed, 104 insertions(+), 89 deletions(-)
diff --git a/config.json b/config.json
index b955e01..e81bf03 100644
--- a/config.json
+++ b/config.json
@@ -1,9 +1,9 @@
{
"AssemblyTag":"assemblyname",
"ScriptInject":null,
- "AllowScripts":true,
- "MaxLintLevel":"Fatal",
- "DontCopyAssets":true,
+ "AllowScripts":false,
+ "MaxLintLevel":"Warning",
+ "DontCopyAssets":false,
"UriSchemas": {
"https" : {
"scope" : ["website"],
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index 3901336..d5ea440 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -64,25 +64,35 @@ newtype MissingAsset = MissingAsset MissingDep
-- | given this config, should the result be considered to have failed?
resultIsFatal :: LintConfig' -> DirResult -> Bool
-resultIsFatal config res =
- not (null (dirresultMissingAssets res))
- && configMaxLintLevel config <= maximumLintLevel res
+resultIsFatal config res = maximumLintLevel res > configMaxLintLevel config
-- | maximum lint level that was observed anywhere in any map.
-- note that it really does go through all lints, so don't
-- call it too often
maximumLintLevel :: DirResult -> Level
-maximumLintLevel = (\t -> if null t then Info else maximum t)
- . map hintLevel
- . concatMap (keys . mapresultLayer)
- . elems
- . dirresultMaps
+maximumLintLevel res
+ | not (null (dirresultMissingAssets res)) = Fatal
+ | otherwise =
+ (\t -> if null t then Info else maximum t)
+ . map hintLevel
+ . concatMap (\map -> keys (mapresultLayer map)
+ <> keys (mapresultTileset map)
+ <> mapresultGeneral map
+ )
+ . elems
+ . dirresultMaps
+ $ res
+
+
instance ToJSON DirResult where
- toJSON res = A.object
- [ "missingDeps" .= dirresultDeps res
- , "missingAssets" .= dirresultMissingAssets res
- , "mapLints" .= dirresultMaps res
+ toJSON res = A.object [
+ "result" .= A.object
+ [ "missingDeps" .= dirresultDeps res
+ , "missingAssets" .= dirresultMissingAssets res
+ , "mapLints" .= dirresultMaps res
+ ]
+ , "resultText" .= prettyprint (Suggestion, res)
, "severity" .= maximumLintLevel res
]
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 5d50f3f..8a2ad7e 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -32,8 +32,8 @@ import Tiled2 (HasName (getName),
LoadResult (..),
Tiledmap (tiledmapLayers, tiledmapTilesets),
Tileset, loadTiledmap)
-import Types (Dep, Hint (hintLevel, hintMsg), Level (..),
- Lint (..), hint)
+import Types (Dep, Hint (Hint, hintLevel, hintMsg),
+ Level (..), Lint (..), hint, lintsToHints)
import Util (PrettyPrint (prettyprint), prettyprint)
@@ -50,7 +50,7 @@ data MapResult = MapResult
-- ^ entrypoints provided by this map (needed for dependency checking)
, mapresultAdjusted :: Maybe Tiledmap
-- ^ the loaded map, with adjustments by the linter
- , mapresultGeneral :: [Lint]
+ , mapresultGeneral :: [Hint]
-- ^ general-purpose lints that didn't fit anywhere else
} deriving (Generic)
@@ -78,7 +78,7 @@ instance ToJSON CollectedLints where
loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe MapResult)
loadAndLintMap config path depth = loadTiledmap path <&> (\case
DecodeErr err -> Just (MapResult mempty mempty mempty mempty Nothing
- [ hint Fatal . T.pack $
+ [ Hint Fatal . T.pack $
path <> ": Fatal: " <> err
])
IOErr _ -> Nothing
@@ -90,7 +90,7 @@ runLinter :: LintConfig' -> Tiledmap -> Int -> MapResult
runLinter config tiledmap depth = MapResult
{ mapresultLayer = invertThing layer
, mapresultTileset = invertThing tileset
- , mapresultGeneral = resultToLints generalResult
+ , mapresultGeneral = lintsToHints $ resultToLints generalResult
, mapresultDepends = mapMaybe lintToDep (resultToLints generalResult)
<> concatMap resultToDeps layer
<> concatMap resultToDeps tileset
@@ -187,5 +187,4 @@ instance PrettyPrint (Level, MapResult) where
prettyGeneral :: [Text]
prettyGeneral = map
((<> "\n") . prettyprint)
- . filterLintLevel level
$ mapresultGeneral mapResult
diff --git a/lib/Properties.hs b/lib/Properties.hs
index ea9f1ac..85ef7c0 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -43,17 +43,17 @@ checkMap = do
-- some layers should exist
hasLayerNamed "start" (const True)
- "The map must have one layer named \"start\""
+ "The map must have one layer named \"start\"."
hasLayerNamed "floorLayer" ((==) "objectgroup" . layerType)
- "The map must have one layer named \"floorLayer\" of type \"objectgroup\""
+ "The map must have one layer named \"floorLayer\" of type \"objectgroup\"."
hasLayer (flip containsProperty "exitUrl" . getProperties)
- "The map must contain at least one layer with the property \"exitUrl\" set"
+ "The map must contain at least one layer with the property \"exitUrl\" set."
-- reject maps not suitable for workadventure
unless (tiledmapOrientation tiledmap == "orthogonal")
- $ complain "The map's orientation must be set to \"orthogonal\""
+ $ complain "The map's orientation must be set to \"orthogonal\"."
unless (tiledmapTileheight tiledmap == 32 && tiledmapTilewidth tiledmap == 32)
- $ complain "The map's tile size must be 32 by 32 pixels"
+ $ complain "The map's tile size must be 32 by 32 pixels."
where
hasLayerNamed name p = hasLayer (\l -> layerName l == name && p l)
hasLayer p err = do
@@ -79,6 +79,11 @@ checkMapProperty (Property name _value) = case name of
lintConfig configScriptInject >>= \case
Nothing -> pure ()
Just url -> setProperty "script" url
+ "mapName" -> pure ()
+ "mapLink" -> pure ()
+ "mapImage" -> pure ()
+ "mapDescription" -> pure ()
+ "mapCopyright" -> pure ()
_ -> complain $ "unknown map property " <> prettyprint name
where
@@ -97,15 +102,18 @@ checkTileset = do
-- reject tilesets unsuitable for workadventure
unless (tilesetTilewidth tileset == 32 && tilesetTileheight tileset == 32)
- $ complain "Tilesets must have tile size 32×32"
+ $ complain "Tilesets must have tile size 32×32."
unless (tilesetImageheight tileset < 4096 && tilesetImagewidth tileset < 4096)
- $ warn "Tilesets should not be larger than 4096×4096 pixels in total"
+ $ warn "Tilesets should not be larger than 4096×4096 pixels in total."
when (isJust (tilesetSource tileset))
$ complain "Tilesets must be embedded and cannot be loaded from external files."
-- TODO: check copyright!
- requireProperty "copyright"
+ unlessHasProperty "copyright"
+ $ forbid "property \"copyright\" is required for tilesets."
+
+
mapM_ checkTilesetProperty (fromMaybe [] $ tilesetProperties tileset)
checkTilesetProperty :: Property -> LintWriter Tileset
@@ -125,7 +133,7 @@ checkLayer = do
"tilelayer" -> mapM_ checkLayerProperty (getProperties layer)
"group" -> pure ()
ty -> unless (layerName layer == "floorLayer" && ty == "objectgroup")
- $ complain "only tilelayer are supported."
+ $ complain "only group and tilelayer are supported."
if layerType layer == "group"
then when (null (layerLayers layer))
@@ -149,7 +157,7 @@ checkLayerProperty p@(Property name _value) = case name of
"jitsiTrigger" -> do
isString p
unlessHasProperty "jitsiTriggerMessage"
- $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\""
+ $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\"."
requireProperty "jitsiRoom"
"jitsiTriggerMessage" -> do
isString p
@@ -183,7 +191,7 @@ checkLayerProperty p@(Property name _value) = case name of
"openWebsiteTrigger" -> do
isString p
unlessHasProperty "openWebsiteTriggerMessage"
- $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the default \"press SPACE to open Website\""
+ $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the default \"press SPACE to open Website\"."
requireProperty "openWebsite"
"openWebsiteTriggerMessage" -> do
isString p
@@ -212,7 +220,7 @@ checkLayerProperty p@(Property name _value) = case name of
offersEntrypoint $ layerName layer
unwrapBool p $ \case
True -> pure ()
- False -> complain "property \"startLayer\" must be set to true"
+ False -> complain "property \"startLayer\" must be set to true."
"silent" -> do
isBool p
uselessEmptyLayer
@@ -229,7 +237,7 @@ checkLayerProperty p@(Property name _value) = case name of
, "jsonSchema"
, "zone" ] ->
do
- forbid "the workadventure scripting API and variables are not (?) supported."
+ warn "the workadventure scripting API and variables are not (yet?) supported."
removeProperty name
| otherwise ->
complain $ "unknown property type " <> prettyprint name
@@ -245,12 +253,12 @@ checkLayerProperty p@(Property name _value) = case name of
forbidEmptyLayer = do
layer <- askContext
when (layerIsEmpty layer)
- $ complain ("property " <> prettyprint name <> " should not be set on an empty layer")
+ $ complain ("property " <> prettyprint name <> " should not be set on an empty layer.")
-- | this layer is allowed, but also useless on a layer that contains no tiles
uselessEmptyLayer = do
layer <- askContext
when (layerIsEmpty layer)
- $ warn ("property " <> prettyprint name <> " set on an empty layer is useless")
+ $ warn ("property " <> prettyprint name <> " set on an empty layer is useless.")
@@ -268,27 +276,19 @@ unlessHasProperty name andthen = do
-- | this property is forbidden and should not be used
forbidProperty :: Text -> LintWriter Layer
forbidProperty name = do
- forbid $ "property " <> prettyprint name <> " should not be used"
-
-
-
--- | require some property
-requireProperty :: HasProperties a => Text -> LintWriter a
-requireProperty name =
- unlessHasProperty name
- $ complain $ "property "<>prettyprint name<>" is required"
+ forbid $ "property " <> prettyprint name <> " should not be used."
propertyRequiredBy :: HasProperties a => Text -> Text -> LintWriter a
propertyRequiredBy req by =
unlessHasProperty req
- $ complain $ "property "<>prettyprint req<>" is required by property "<> prettyprint by
+ $ complain $ "property "<>prettyprint req<>" is required by property "<> prettyprint by<>"."
-- | suggest some value for another property if that property does not
-- also already exist
suggestProperty :: Property -> LintWriter Layer
suggestProperty (Property name value) =
unlessHasProperty name
- $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value
+ $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value<>"."
-- | set a property, overwriting whatever value it had previously
setProperty :: (IsProperty prop, HasProperties ctxt)
@@ -314,7 +314,7 @@ containsProperty props name = any
unwrapString :: Property -> (Text -> LintWriter a) -> LintWriter a
unwrapString (Property name value) f = case value of
StrProp str -> f str
- _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string"
+ _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string."
unwrapString' :: Property -> LintWriter a -> LintWriter a
unwrapString' prop f = unwrapString prop (const f)
@@ -325,18 +325,18 @@ unwrapLink (Property name value) f = case value of
StrProp str -> if "http://" `isPrefixOf` str
then complain "cannot access content via http; either use https or include it locally instead."
else f str
- _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string and contain a valid uri"
+ _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string and contain a valid uri."
-- | asserts that this property is a boolean, and unwraps it
unwrapBool :: Property -> (Bool -> LintWriter a) -> LintWriter a
unwrapBool (Property name value) f = case value of
BoolProp b -> f b
- _ -> complain $ "type error: property " <> prettyprint name <> " should be of type bool"
+ _ -> complain $ "type error: property " <> prettyprint name <> " should be of type bool."
unwrapInt :: Property -> (Int -> LintWriter a) -> LintWriter a
unwrapInt (Property name value) f = case value of
IntProp float -> f float
- _ -> complain $ "type error: property " <> prettyprint name <> " should be of type int"
+ _ -> complain $ "type error: property " <> prettyprint name <> " should be of type int."
unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a
unwrapPath str f = case parsePath str of
@@ -344,8 +344,8 @@ unwrapPath str f = case parsePath str of
depth <- askFileDepth
if up <= depth
then f p
- else complain $ "cannot acess paths \"" <> str <> "\" which is outside your repository"
- NotAPath -> complain $ "path \"" <> str <> "\" is invalid"
+ else complain $ "cannot acess paths \"" <> str <> "\" which is outside your repository."
+ 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."
@@ -361,7 +361,7 @@ isBool = flip unwrapBool (const $ pure ())
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
+ else complain $ "Property " <> prettyprint name <> " should be between" <> showText l <> " and " <> showText r<>"."
unwrapURI :: (KnownSymbol s, HasProperties a)
@@ -379,4 +379,4 @@ unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do
SchemaDoesNotExist schema ->
"the URI schema " <> schema <> ":// does not exist."
WrongScope schema ->
- "the URI schema " <> schema <> ":// cannot be used on \""<>name<>"\""
+ "the URI schema " <> schema <> ":// cannot be used on \""<>name<>"\"."
diff --git a/lib/Types.hs b/lib/Types.hs
index 0d35432..1099630 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -84,8 +84,7 @@ instance PrettyPrint Hint where
prettyprint (Hint level msg) = " " <> (showText level) <> ": " <> msg
instance ToJSON Lint where
- toJSON (Lint (Hint l m)) = A.object
- [ "msg" .= m, "level" .= l ]
+ toJSON (Lint h) = toJSON h
toJSON (Depends dep) = A.object
[ "msg" .= prettyprint dep
, "level" .= A.String "Dependency Info" ]
@@ -93,6 +92,10 @@ instance ToJSON Lint where
[ "msg" .= prettyprint l
, "level" .= A.String "Entrypoint Info" ]
+instance ToJSON Hint where
+ toJSON (Hint l m) = A.object
+ [ "msg" .= m, "level" .= l ]
+
instance ToJSON Dep where
toJSON = \case
Local text -> json "local" $ prettyprint text
diff --git a/lib/WriteRepo.hs b/lib/WriteRepo.hs
index fbe139b..7e3e5f2 100644
--- a/lib/WriteRepo.hs
+++ b/lib/WriteRepo.hs
@@ -8,6 +8,7 @@ module WriteRepo where
import CheckDir (DirResult (..), resultIsFatal)
import CheckMap (MapResult (..))
import Control.Monad (forM_, unless)
+import Control.Monad.Extra (ifM)
import Data.Aeson (encodeFile)
import Data.Map.Strict (toList)
import Data.Maybe (mapMaybe)
@@ -16,7 +17,8 @@ import qualified Data.Set as S
import LintConfig (LintConfig (configDontCopyAssets),
LintConfig')
import Paths (normalise)
-import System.Directory.Extra (copyFile, createDirectoryIfMissing)
+import System.Directory.Extra (copyFile, createDirectoryIfMissing,
+ doesDirectoryExist)
import System.Exit (ExitCode (..))
import System.FilePath (takeDirectory)
import qualified System.FilePath as FP
@@ -29,36 +31,35 @@ writeAdjustedRepository :: LintConfig' -> FilePath -> FilePath -> DirResult -> I
writeAdjustedRepository config inPath outPath result
| resultIsFatal config result =
pure (ExitFailure 1)
- | not (configDontCopyAssets config) =
- pure (ExitSuccess)
| otherwise = do
- createDirectoryIfMissing True outPath
+ ifM (doesDirectoryExist outPath) (pure (ExitFailure 2)) $ do
+ createDirectoryIfMissing True outPath
- -- write out all maps
- mapM_
- (\(path,out) -> encodeFile (outPath </> path) $ mapresultAdjusted out)
- (toList $ dirresultMaps result)
+ -- write out all maps
+ mapM_
+ (\(path,out) -> encodeFile (outPath </> path) $ mapresultAdjusted out)
+ (toList $ dirresultMaps result)
- unless (configDontCopyAssets config) $ do
- -- collect asset dependencies of maps
- -- TODO: its kinda weird doing that here, tbh
- let localdeps :: Set FilePath =
- S.fromList . concatMap
- (\(mappath,mapresult) ->
- let mapdir = takeDirectory mappath in
- mapMaybe (\case
- Local path -> Just . normalise mapdir $ path
- _ -> Nothing)
- $ mapresultDepends mapresult)
- . toList $ dirresultMaps result
+ unless (configDontCopyAssets config) $ do
+ -- collect asset dependencies of maps
+ -- TODO: its kinda weird doing that here, tbh
+ let localdeps :: Set FilePath =
+ S.fromList . concatMap
+ (\(mappath,mapresult) ->
+ let mapdir = takeDirectory mappath in
+ mapMaybe (\case
+ Local path -> Just . normalise mapdir $ path
+ _ -> Nothing)
+ $ mapresultDepends mapresult)
+ . toList $ dirresultMaps result
- -- copy all assets
- forM_ localdeps $ \path ->
- let
- assetPath = FP.normalise $ inPath </> path
- newPath = FP.normalise $ outPath </> path
- in do
- -- putStrLn $ "copying " <> assetPath <> " → " <> newPath
- copyFile assetPath newPath
+ -- copy all assets
+ forM_ localdeps $ \path ->
+ let
+ assetPath = FP.normalise $ inPath </> path
+ newPath = FP.normalise $ outPath </> path
+ in do
+ createDirectoryIfMissing True (takeDirectory newPath)
+ copyFile assetPath newPath
- pure ExitSuccess
+ pure ExitSuccess
diff --git a/src/Main.hs b/src/Main.hs
index d115660..572dc76 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -13,10 +13,10 @@ import Data.Aeson.KeyMap (coercionToHashMap)
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as LB
import Data.Maybe (fromMaybe)
-import System.Exit (exitWith)
+import System.Exit (exitWith, ExitCode (..))
import WithCli
-import CheckDir (recursiveCheckDir)
+import CheckDir (recursiveCheckDir, resultIsFatal)
import LintConfig (LintConfig (..), patch)
import Types (Level (..))
import Util (printPretty)
@@ -74,7 +74,9 @@ run options = do
case out options of
Just outpath -> writeAdjustedRepository lintconfig repo outpath lints
>>= exitWith
- Nothing -> pure ()
+ Nothing -> exitWith $ case resultIsFatal lintconfig lints of
+ False -> ExitSuccess
+ True -> ExitFailure 1
-- | haskell's many string types are FUN …
printLB :: LB.ByteString -> IO ()
--
GitLab