From c9c472a36b0db933771a6feb24709e78cae1822b Mon Sep 17 00:00:00 2001
From: jonny <ga86lad@mytum.de>
Date: Wed, 29 Dec 2021 00:32:52 +0100
Subject: [PATCH] use url package for parsing of urls
---
lib/Properties.hs | 12 +++++++++---
lib/Uris.hs | 30 +++++++++++++++++++++---------
walint.cabal | 3 ++-
3 files changed, 32 insertions(+), 13 deletions(-)
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 31823e6..f346f7f 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -45,7 +45,7 @@ import LintWriter (LintWriter, adjust, askContext,
import Paths (PathResult (..), RelPath (..), getExtension,
isOldStyle, parsePath)
import Types (Dep (Link, Local, LocalMap, MapLink))
-import Uris (SubstError (..), applySubsts, parseUri)
+import Uris (SubstError (..), applySubsts, parseUri, extractDomain)
@@ -143,7 +143,7 @@ checkMapProperty p@(Property name _) = case name of
-- scripts can be used by one map
_ | T.toLower name == "script" ->
unwrapString p $ \str ->
- unless (("https://static.rc3.world/scripts" `isPrefixOf` str) &&
+ unless ((checkIsRc3Url str) &&
(not $ "/../" `isInfixOf` str) &&
(not $ "%" `isInfixOf` str) &&
(not $ "@" `isInfixOf` str))
@@ -344,6 +344,12 @@ checkObjectGroupProperty (Property name _) = case name of
\not the object layer."
_ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers"
+checkIsRc3Url :: Text -> Bool
+checkIsRc3Url text= case extractDomain text of
+ Nothing -> False
+ Just domain -> do
+ domain == "https://static.rc3.world"
+
-- | Checks a single (custom) property of a "normal" tile layer
checkTileThing :: (HasProperties a, HasName a, HasData a) => Bool -> Property -> LintWriter a
@@ -500,7 +506,7 @@ checkTileThing removeExits p@(Property name _value) = case name of
-> do
properties <- askContext <&> getProperties
unless (all (\(Property name value) -> case value of
- StrProp str -> name /= "openWebsite" || "https://static.rc3.world/" `isPrefixOf` str
+ StrProp str -> name /= "openWebsite" || checkIsRc3Url str
_ -> True
) properties)
$ complain "\"openWebsiteAllowApi\" can only be used with websites hosted \
diff --git a/lib/Uris.hs b/lib/Uris.hs
index 6436ac6..80ee014 100644
--- a/lib/Uris.hs
+++ b/lib/Uris.hs
@@ -18,7 +18,7 @@ import Data.Data (Proxy)
import Data.Either.Combinators (maybeToRight, rightToMaybe)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
-import Data.Text (Text, pack)
+import Data.Text (Text, pack, unpack)
import qualified Data.Text as T
import GHC.Generics (Generic)
import GHC.TypeLits (KnownSymbol, symbolVal)
@@ -26,6 +26,9 @@ import Network.URI.Encode as URI
import Text.Regex.TDFA ((=~))
import Witherable (mapMaybe)
+import Network.URI as NativeUri
+import Data.String
+
data Substitution =
Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] }
| DomainSubstitution { substs :: Map Text Text, scope :: [String] }
@@ -44,17 +47,26 @@ type SchemaSet = [(Text, Substitution)]
extractDomain :: Text -> Maybe Text
extractDomain url =
- let (_,_,_,matches) = url =~ "^https://([^/]+)/?.*$" :: (Text,Text,Text,[Text])
- in case matches of
- [domain] -> Just domain
- _ -> Nothing
+ case parseUri url of
+ Nothing -> Nothing
+ Just (_,domain,_) -> Just domain
+
+
+
parseUri :: Text -> Maybe (Text, Text, Text)
parseUri uri =
- let (_,_,_,matches) = uri =~ "^([a-zA-Z0-9]+)://([^/]+)(/?.*)$" :: (Text,Text,Text,[Text])
- in case matches of
- [schema, domain, rest] -> Just (schema, domain, rest)
- _ -> Nothing
+ case parseURI (unpack uri) of
+ Nothing -> Nothing
+ Just parsedUri -> case uriAuthority parsedUri of
+ Nothing -> Nothing
+ -- https:
+ Just uriAuth -> Just (T.replace (fromString ":") (fromString "") (fromString (uriScheme parsedUri )),
+ -- //anonymous@ www.haskell.org :42
+ fromString(uriUserInfo uriAuth++uriRegName uriAuth ++ uriPort uriAuth),
+ -- /ghc ?query #frag
+ fromString(uriPath parsedUri ++ uriQuery parsedUri ++ uriFragment parsedUri))
+
data SubstError =
SchemaDoesNotExist Text
diff --git a/walint.cabal b/walint.cabal
index 00b772b..414f9e2 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -57,7 +57,8 @@ library
witherable,
dotgen,
text-metrics,
- uri-encode
+ uri-encode,
+ network-uri
-- TODO: move more stuff into lib, these dependencies are silly
executable walint
--
GitLab