From 70d37dcb8b381ba1b0b0d1f97d2fe99522f387a6 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sun, 19 Sep 2021 22:39:01 +0200 Subject: 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(-) (limited to 'lib') 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" -- cgit v1.2.3