diff options
| -rw-r--r-- | config.json | 6 | ||||
| -rw-r--r-- | lib/CheckDir.hs | 34 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 11 | ||||
| -rw-r--r-- | lib/Properties.hs | 68 | ||||
| -rw-r--r-- | lib/Types.hs | 7 | ||||
| -rw-r--r-- | lib/WriteRepo.hs | 59 | ||||
| -rw-r--r-- | 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 () |