From c9c472a36b0db933771a6feb24709e78cae1822b Mon Sep 17 00:00:00 2001
From: jonny
Date: Wed, 29 Dec 2021 00:32:52 +0100
Subject: use url package for parsing of urls

---
 lib/Properties.hs | 12 +++++++++---
 lib/Uris.hs       | 30 +++++++++++++++++++++---------
 2 files changed, 30 insertions(+), 12 deletions(-)

(limited to 'lib')

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
-- 
cgit v1.2.3