From 70d37dcb8b381ba1b0b0d1f97d2fe99522f387a6 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Sun, 19 Sep 2021 22:39:01 +0200
Subject: [PATCH] support for properties that aren't strings
apparently i couldn't read or something?
---
lib/Properties.hs | 88 ++++++++++++++++++++++++++++-------------------
lib/Tiled2.hs | 42 +++++++++++++++-------
lib/Types.hs | 1 +
lib/Util.hs | 6 ++++
4 files changed, 88 insertions(+), 49 deletions(-)
diff --git a/lib/Properties.hs b/lib/Properties.hs
index ebd34bb..fe00857 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -5,15 +5,16 @@
module Properties (checkProperty) where
-import Control.Monad (unless)
+import Control.Monad (unless, when)
import Data.Text (Text, isPrefixOf)
-import Tiled2 (Layer (layerProperties), Property, propertyName,
- propertyValue)
+import Tiled2 (Layer (layerProperties), Property(..), PropertyValue(..))
import Util (prettyprint)
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
@@ -27,60 +28,75 @@ import Types
-- that should make this readable even to non-Haskellers
-- TODO: also pass the value of this property directly
checkProperty :: Layer -> Property -> LintWriter ()
-checkProperty layer prop = case propName of
- "jitsiRoom" -> do
- info $ "found jitsi room: " <> prettyprint (propertyValue prop)
+checkProperty layer (Property name value) = case name of
+ "jitsiRoom" -> strProp $ do
+ info $ "found jitsi room: " <> prettyprint value
suggestPropertyValue "jitsiTrigger" "onaction"
- "jitsiTrigger" ->
+ "jitsiTrigger" -> strProp $ do
+ unless (hasProperty "jitsiTriggerMessage" layer)
+ $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\""
requireProperty "jitsiRoom"
+ "jitsiTriggerMessage" -> strProp
+ $ requireProperty "jitsiTrigger"
"jitsiUrl" -> isForbidden
"jitsiConfig" -> isForbidden
"jitsiClientConfig" -> isForbidden
"jitsiRoomAdminTag" -> isForbidden
- "playAudio" ->
- forbidHTTPAndThen $ dependsOn $ if "https://" `isPrefixOf` propValue
- then Link propValue
- else Local propValue
+ "playAudio" -> linkProp $ \link -> dependsOn $ if "https://" `isPrefixOf` link
+ then Link link
+ else Local link
"audioLoop" ->
- requireProperty "playAudio"
+ boolProp $ requireProperty "playAudio"
"audioVolume" ->
- requireProperty "playAudio"
+ boolProp $ requireProperty "playAudio"
"openWebsite" -> do
suggestPropertyValue "openWebsiteTrigger" "onaction"
- 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" ->
+ linkProp $ \link -> dependsOn $ if "https://" `isPrefixOf` link
+ then Link link
+ else Local link
+ "openWebsiteTrigger" -> strProp $ do
+ unless (hasProperty "openWebsiteTriggerMessage" layer)
+ $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the generic \"press SPACE to open Website\""
requireProperty "openWebsite"
+ "openWebsiteTriggerMessage" ->
+ strProp $ requireProperty "openWebsiteTrigger"
"openWebsitePolicy" ->
- requireProperty "openWebsite"
- "exitUrl" ->
- forbidHTTPAndThen $ dependsOn $ if "https://" `isPrefixOf` propValue
- then MapLink propValue
- else LocalMap propValue
- "startLayer" -> pure ()
+ strProp $ requireProperty "openWebsite"
+ "openTab" ->
+ strProp $ requireProperty "openWebsite"
+ "url" -> isForbidden
+ "allowApi" -> isForbidden
+ "exitUrl" -> linkProp $ \link -> dependsOn $ if "https://" `isPrefixOf` link
+ then MapLink link
+ else LocalMap link
+ "startLayer" ->
+ isForbidden
+ "silent" -> boolProp $ 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
+ _ -> warn $ "unknown property type " <> prettyprint name
where
- propName = propertyName prop
- propValue = propertyValue prop
+ strProp :: LintWriter () -> LintWriter ()
+ strProp andthen = case value of
+ StrProp _ -> andthen
+ _ -> complain $ "type mismatch in property " <> name <> "; should be of type string"
+ linkProp 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 mismatch in property " <> name <> "; should be of typ string"
+ boolProp f = case value of
+ BoolProp _ -> f
+ _ -> complain $ "type mismatch in property " <> name <> "; should be of type bool"
-- | require some property in this layer
requireProperty name = unless (hasProperty name layer)
- $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint propName
+ $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint name
-- | This property is forbidden and should not be used
- isForbidden = forbid $ "property " <> prettyprint propName <> " should not be used"
+ isForbidden = forbid $ "property " <> prettyprint name <> " should not be used"
-- TODO: check if the property has the correct value
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
@@ -88,5 +104,5 @@ checkProperty layer prop = case propName of
-- | does this layer have the given property?
hasProperty :: Text -> Layer -> Bool
hasProperty name = any
- (\prop -> propertyName prop == name)
+ (\(Property name' _) -> name' == name)
. layerProperties
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index c751cdc..c3bf401 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -24,6 +25,7 @@ import Data.Text (Text)
import Data.Vector (Vector)
import GHC.Exts (fromList, toList)
import GHC.Generics (Generic)
+import Data.Functor ((<&>))
-- | A globally indexed identifier.
@@ -67,28 +69,42 @@ parseDefault :: FromJSON a => A.Object -> Text -> a -> Parser a
parseDefault o s d = fromMaybe d <$> o .:? s
--- | workadventure custom property
+{-- | workadventure custom property
data Property = Property { propertyName :: Text
--, propertyType :: Text (unnecessary since always string)
, propertyValue :: Text
} deriving (Eq, Generic, Show)
+-}
+
+data PropertyValue = StrProp Text | BoolProp Bool
+ deriving (Eq, Generic, Show)
+data Property = Property Text PropertyValue
+ deriving (Eq, Generic, Show)
+
instance FromJSON Property where
parseJSON (A.Object o) = do
- propertyType <- o .: "type"
- if propertyType /= A.String "string"
- then typeMismatch "type" "string"
- else do
- propertyName <- o .: "name"
- propertyValue <- o .: "value"
- pure $ Property { propertyName, propertyValue }
+ name <- o .: "name"
+ o .: "type" >>= \case
+ A.String "string" -> do
+ val <- o .: "value"
+ pure $ Property name (StrProp val)
+ A.String "bool" -> do
+ val <- o .: "value"
+ pure $ Property name (BoolProp val)
+ ty -> fail $ "properties can only have type string or bool, but encountered " <> show ty
parseJSON invalid = typeMismatch "Property" invalid
instance ToJSON Property where
- toJSON prop = object [ "type" .= A.String "string"
- , "name" .= propertyName prop
- , "value" .= propertyName prop
- ]
+ toJSON (Property name val) = case val of
+ StrProp str -> object [ "type" .= A.String "string"
+ , "name" .= name
+ , "value" .= str
+ ]
+ BoolProp bool -> object [ "type" .= A.String "bool"
+ , "name" .= name
+ , "value" .= bool
+ ]
data Object = Object { objectId :: Int
-- ^ Incremental id - unique across all objects
@@ -196,7 +212,7 @@ instance FromJSON Layer where
<*> o .: "y"
<*> (o .: "data" <|> pure Nothing)
<*> o .:? "objects"
- <*> (o .: "properties" <|> pure mempty)
+ <*> (o .:? "properties" <&> fromMaybe [])
<*> o .: "opacity"
<*> (o .: "draworder" <|> pure "topdown")
parseJSON invalid = typeMismatch "Layer" invalid
diff --git a/lib/Types.hs b/lib/Types.hs
index 2e683c0..d9c82b4 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -16,6 +16,7 @@ import GHC.Generics (Generic)
import qualified Data.Aeson as A
import Util (PrettyPrint (..), showText)
+import Tiled2 (Property(Property), PropertyValue (BoolProp, StrProp))
-- | Levels of errors and warnings, collectively called
diff --git a/lib/Util.hs b/lib/Util.hs
index 42ba960..82d326f 100644
--- a/lib/Util.hs
+++ b/lib/Util.hs
@@ -9,6 +9,7 @@ module Util where
import Data.Aeson as Aeson
import Data.Text (Text)
import qualified Data.Text as T
+import Tiled2 (PropertyValue(..))
-- | haskell's many string types are FUN …
showText :: Show a => a -> Text
@@ -29,6 +30,11 @@ instance PrettyPrint Aeson.Value where
Aeson.String s -> prettyprint s
v -> (T.pack . show) v
+instance PrettyPrint PropertyValue where
+ prettyprint = \case
+ StrProp str -> str
+ BoolProp bool -> if bool then "true" else "false"
+
-- | here since Unit is sometimes used as dummy type
instance PrettyPrint () where
prettyprint _ = error "shouldn't pretty-print Unit"
--
GitLab