1 files changed, 45 insertions, 45 deletions

diff --git a/lib/Uris.hs b/lib/Uris.hs
index 596c272..40ea43e 100644
--- a/lib/Uris.hs
+++ b/lib/Uris.hs
@@ -1,9 +1,10 @@
-{-# LANGUAGE DataKinds        #-}
-{-# LANGUAGE DeriveAnyClass   #-}
-{-# LANGUAGE DeriveGeneric    #-}
-{-# LANGUAGE LambdaCase       #-}
-{-# LANGUAGE RecordWildCards  #-}
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TypeApplications  #-}
 
 -- | Functions to deal with uris and custom uri schemes
 module Uris where
@@ -16,7 +17,8 @@ import           Data.Aeson         (FromJSON (..), Options (..),
 import qualified Data.Map.Strict    as M
 import qualified Data.Text          as T
 import           GHC.TypeLits       (KnownSymbol, symbolVal)
-import           Network.URI        (URI (..), URIAuth (..), parseURI)
+import           Network.URI        (URI (..), URIAuth (..), parseURI,
+                                     uriToString)
 import qualified Network.URI.Encode as URI
 
 data Substitution =
@@ -24,7 +26,7 @@ data Substitution =
   | DomainSubstitution { substs :: Map Text Text, scope :: [String] }
   | Allowed  { scope :: [String], allowed :: [Text] }
   | Unrestricted { scope :: [String] }
-  deriving (Generic, Show)
+  deriving (Generic, Show, NFData)
 
 
 instance FromJSON Substitution where
@@ -33,30 +35,23 @@ instance FromJSON Substitution where
     , rejectUnknownFields = True
     }
 
-type SchemaSet = Map Text Substitution
+type SchemaSet = Map Text [Substitution]
 
 
-extractDomain :: Text -> Maybe Text
-extractDomain url =
-  case parseUri url of
-    Nothing           -> Nothing
-    Just (_,domain,_) -> Just domain
-
-
-
-
-parseUri :: Text -> Maybe (Text, Text, Text)
-parseUri uri =
-  case parseURI (toString uri) of
+-- | deconstruct a URI into a triple of [schema:]//[domain]/[tail...],
+-- and a normalised version of the same URI
+parseUri :: Text -> Maybe (Text, Text, Text, Text)
+parseUri raw =
+  case parseURI (toString raw) of
     Nothing -> Nothing
-    Just parsedUri -> case uriAuthority parsedUri of
+    Just uri@URI{..} -> case uriAuthority 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))
+        Just URIAuth {..} -> Just
+          ( fromString uriScheme
+          , fromString $ uriUserInfo <> uriRegName <> uriPort
+          , fromString $ uriPath <> uriQuery <> uriFragment
+          , fromString $ uriToString id uri ""
+          )
 
 
 data SubstError =
@@ -66,41 +61,46 @@ data SubstError =
   | IsBlocked
   | DomainIsBlocked [Text]
   | VarsDisallowed
+  | WrongScope Text [Text]
   -- ^ This link's schema exists, but cannot be used in this scope.
   -- The second field contains a list of schemas that may be used instead.
-  | WrongScope Text [Text]
   deriving (Eq, Ord) -- errors are ordered so we can show more specific ones
 
 
 applySubsts :: KnownSymbol s
   => Proxy s -> SchemaSet -> Text -> Either SubstError Text
 applySubsts s substs uri =  do
-  when (T.isInfixOf (toText "{{") uri || T.isInfixOf (toText "}}") uri)
+  when (T.isInfixOf "{{" uri || T.isInfixOf "}}" uri)
    $ Left VarsDisallowed
-  parts@(schema, _, _) <- note NotALink $ parseUri uri
+  parts@(schema, _, _, _) <- maybeToRight NotALink $ parseUri uri
 
-  let rule = M.lookup schema substs
+  let rules = filter (elem thisScope . scope) . concat $ M.lookup schema substs
 
-  case map (applySubst parts) rule of
-    Nothing  -> Left (SchemaDoesNotExist schema)
-    Just result -> result
+  case nonEmpty $ map (applySubst parts) rules of
+    Nothing     -> Left (SchemaDoesNotExist schema)
+    Just result -> minimum result
   where
-    note = maybeToRight
-    applySubst (schema, domain, rest) rule = do
+    thisScope = symbolVal s
+    applySubst (schema, domain, rest, uri) rule = do
+
+      -- is this scope applicable?
       unless (symbolVal s `elem` scope rule)
         $ Left (WrongScope schema
-         (map fst . filter (elem (symbolVal s) . scope . snd) $ toPairs substs))
+                 $ map fst -- make list of available uri schemes
+                 . filter (any (elem thisScope . scope) . snd)
+                 $ toPairs substs)
+
       case rule of
         DomainSubstitution table _  -> do
-          prefix <- note (DomainDoesNotExist (schema <> toText "://" <> domain))
-                       $ M.lookup domain table
+          prefix <- case M.lookup domain table of
+            Nothing -> Left (DomainDoesNotExist (schema <> "//" <> domain))
+            Just a  -> Right a
           pure (prefix <> rest)
         Prefixed {..}
           | domain `elem` blocked -> Left IsBlocked
-          | domain `elem` allowed || toText "streamproxy.rc3.world" `T.isSuffixOf` domain -> Right uri
+          | domain `elem` allowed -> Right uri
           | otherwise -> Right (prefix <> URI.encodeText uri)
-        Allowed _ domains -> if domain `elem` domains
-                    || toText "streamproxy.rc3.world" `T.isSuffixOf` domain
-          then Right uri
-          else Left (DomainIsBlocked domains)
+        Allowed _ allowlist
+          | domain `elem` allowlist -> Right uri
+          | otherwise -> Left (DomainIsBlocked allowlist)
         Unrestricted _ -> Right uri