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

5 files changed, 96 insertions, 83 deletions

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