collecting map dependencies

4 files changed, 70 insertions, 20 deletions

diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 9402170..9908fdd 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -16,12 +16,13 @@ import qualified Data.Text                  as T
 import qualified Data.Vector                as V
 import           GHC.Generics               (Generic)
 
-import           LintWriter                 (LintResult (..), LintWriter)
+import           LintWriter                 (LintResult (..), LintWriter,
+                                             lintsToDeps)
 import           Properties                 (checkProperty)
 import           Tiled2                     (Layer (layerName, layerProperties),
                                              Tiledmap (tiledmapLayers),
                                              loadTiledmap)
-import           Types                      (Level (..), Lint (..), hint,
+import           Types                      (Dep, Level (..), Lint (..), hint,
                                              lintLevel)
 import           Util                       (PrettyPrint (prettyprint),
                                              prettyprint)
@@ -31,6 +32,7 @@ import           Util                       (PrettyPrint (prettyprint),
 data MapResult a = MapResult
   { mapresultLayer   :: Maybe (Map Text (LintResult a))
   , mapresultGeneral :: [Lint]
+  , mapresultDepends :: [Dep]
   } deriving (Generic, ToJSON)
 
 
@@ -40,6 +42,7 @@ loadAndLintMap :: FilePath -> IO (MapResult ())
 loadAndLintMap path = loadTiledmap path >>= pure . \case
     Left err -> MapResult
       { mapresultLayer = Nothing
+      , mapresultDepends = []
       , mapresultGeneral =
         [ hint Fatal . T.pack $
           path <> ": parse error (probably invalid json/not a tiled map): " <> err
@@ -51,12 +54,14 @@ loadAndLintMap path = loadTiledmap path >>= pure . \case
 -- | lint a loaded map
 runLinter :: Tiledmap -> MapResult ()
 runLinter tiledmap = MapResult
-  { mapresultLayer = Just layer
+  { mapresultLayer = Just layerMap
   , mapresultGeneral = [] -- no general lints for now
+  , mapresultDepends = concatMap (lintsToDeps . snd) layer
   }
   where
-    layer :: Map Text (LintResult ())
-    layer = fromList . V.toList . V.map runCheck $ tiledmapLayers tiledmap
+    layerMap :: Map Text (LintResult ())
+    layerMap = fromList layer
+    layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap
       where runCheck l = (layerName l, LintResult $ runWriterT (checkLayer l))
 
 -- | collect lints on a single map layer
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 66f16f1..055e2d4 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveAnyClass    #-}
 {-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -12,6 +13,7 @@ import           Control.Monad.Writer      (MonadTrans (lift),
 import           Data.Aeson                (ToJSON (toJSON))
 import           Data.Text                 (Text)
 
+import           Data.Maybe                (mapMaybe)
 import           Types
 
 -- | a monad to collect hints. If it yields Left, then the
@@ -32,14 +34,24 @@ instance ToJSON a => ToJSON (LintResult a) where
     where toJson' (Left hint)        = toJSON [hint]
           toJson' (Right (_, hints)) = toJSON hints
 
+lintToDep :: Lint -> Maybe Dep
+lintToDep = \case
+  Depends dep -> Just dep
+  _           -> Nothing
+
+lintsToDeps :: LintResult a -> [Dep]
+lintsToDeps (LintResult a) = case a of
+  Left (Depends dep) -> [dep]
+  Left _             -> []
+  Right (_, lints)   -> mapMaybe lintToDep lints
 
 
 -- | write a hint into the LintWriter monad
 lint :: Level -> Text -> LintWriter ()
 lint level = tell . (: []) . hint level
 
-require :: Text -> LintWriter ()
-require dep = tell . (: []) $ Depends (Dep dep)
+dependsOn :: Dep -> LintWriter ()
+dependsOn dep = tell . (: []) $ Depends dep
 
 warn = lint Warning
 info = lint Info
@@ -47,6 +59,10 @@ forbid = lint Forbidden
 suggest = lint Suggestion
 complain = lint Error
 
+dependsLocal = dependsOn . Local
+dependsLink = dependsOn . Link
+dependsMapService = dependsOn . MapLink
+
 
 -- TODO: all these functions should probably also just operate on LintWriter
 
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 7d6fc4a..ebd34bb 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -6,14 +6,14 @@ module Properties (checkProperty) where
 
 
 import           Control.Monad (unless)
-import           Data.Text     (Text)
+import           Data.Text     (Text, isPrefixOf)
 import           Tiled2        (Layer (layerProperties), Property, propertyName,
                                 propertyValue)
 import           Util          (prettyprint)
 
-import           LintWriter    (LintWriter, complain, forbid, info, require,
+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
@@ -37,27 +37,37 @@ checkProperty layer prop = case propName of
     "jitsiConfig" -> isForbidden
     "jitsiClientConfig" -> isForbidden
     "jitsiRoomAdminTag" -> isForbidden
-    "playAudio" -> do
-      -- TODO: check for url validity?
-      pure ()
+    "playAudio" ->
+      forbidHTTPAndThen $ dependsOn $ if "https://" `isPrefixOf` propValue
+        then Link propValue
+        else Local propValue
     "audioLoop" ->
       requireProperty "playAudio"
     "audioVolume" ->
       requireProperty "playAudio"
     "openWebsite" -> do
       suggestPropertyValue "openWebsiteTrigger" "onaction"
-      require $ propertyValue prop
+      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" ->
       requireProperty "openWebsite"
     "openWebsitePolicy" ->
       requireProperty "openWebsite"
-    "exitUrl" -> pure ()
+    "exitUrl" ->
+      forbidHTTPAndThen $ dependsOn $ if "https://" `isPrefixOf` propValue
+        then MapLink propValue
+        else LocalMap propValue
     "startLayer" -> 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
     where
       propName = propertyName prop
+      propValue = propertyValue prop
       -- | require some property in this layer
       requireProperty name = unless (hasProperty name layer)
         $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint propName
@@ -67,6 +77,10 @@ checkProperty layer prop = case propName of
       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
 
 
 
diff --git a/lib/Types.hs b/lib/Types.hs
index 79bbfab..2e683c0 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveAnyClass    #-}
 {-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -27,8 +28,8 @@ data Level = Warning | Suggestion | Info | Forbidden | Error | Fatal
 data Lint = Depends Dep | Lint Hint
 
 -- | TODO: add a reasonable representation of possible urls
-newtype Dep = Dep Text
-  deriving (Generic, ToJSON)
+data Dep = Local Text | Link Text | MapLink Text | LocalMap Text
+  deriving (Generic)
 
 data Hint = Hint
   { hintLevel :: Level
@@ -42,8 +43,8 @@ hint level msg = Lint Hint { hintLevel = level, hintMsg = msg }
 
 -- | dependencies just have level Info
 lintLevel :: Lint -> Level
-lintLevel (Lint h)      = hintLevel h
-lintLevel (Depends dep) = Info
+lintLevel (Lint h)    = hintLevel h
+lintLevel (Depends _) = Info
 
 instance PrettyPrint Lint where
   prettyprint (Lint  Hint { hintMsg, hintLevel } ) =
@@ -57,5 +58,19 @@ instance ToJSON Lint where
     [ "hintMsg" .= prettyprint dep
     , "hintLevel" .= A.String "Dependency Info" ]
 
+instance ToJSON Dep where
+  toJSON  = \case
+    Local text    -> json "local" text
+    Link text     -> json "link" text
+    MapLink text  -> json "mapservice" text
+    LocalMap text -> json "map" text
+    where
+      json :: A.Value -> Text -> A.Value
+      json kind text = A.object [ "kind" .= kind, "dep" .= text ]
+
 instance PrettyPrint Dep where
-  prettyprint (Dep txt) = txt
+  prettyprint = \case
+    Local dep    -> "[local dep: " <> dep <> "]"
+    Link dep     -> "[link dep: " <> dep <> "]"
+    MapLink dep  -> "[map service dep: " <> dep <> "]"
+    LocalMap dep -> "[local map dep: " <> dep <> "]"