From a318f848178cade371abfa01a36bf15bab6ec58f Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 16 Dec 2021 22:21:39 +0100
Subject: special handling of world:// and assembly names

these now have their own top-level config attribute which is essentially a
shorthand for setting one that's deeper nested.
---
 lib/Uris.hs | 32 ++++++++++++++++----------------
 1 file changed, 16 insertions(+), 16 deletions(-)

(limited to 'lib/Uris.hs')

diff --git a/lib/Uris.hs b/lib/Uris.hs
index b674d37..5ad9180 100644
--- a/lib/Uris.hs
+++ b/lib/Uris.hs
@@ -17,14 +17,14 @@ import           Data.Data               (Proxy)
 import           Data.Either.Combinators (maybeToRight)
 import           Data.Map.Strict         (Map)
 import qualified Data.Map.Strict         as M
-import           Data.Text               (Text)
+import           Data.Text               (Text, pack)
 import           GHC.Generics            (Generic)
 import           GHC.TypeLits            (KnownSymbol, symbolVal)
 import           Text.Regex.TDFA         ((=~))
 
 data Substitution =
     Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] }
-  | Explicit { substs :: Map Text Text, scope :: [String] }
+  | DomainSubstitution { substs :: Map Text Text, scope :: [String] }
   | Allowed  { scope :: [String] }
   deriving (Generic, Show)
 
@@ -56,7 +56,7 @@ data SubstError =
     SchemaDoesNotExist Text
   | NotALink
   | IsBlocked
-  | InvalidLink
+  | DomainDoesNotExist Text
   | 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.
@@ -68,17 +68,17 @@ applySubst s substs uri =  do
   (schema, domain, rest) <- note NotALink $ parseUri uri
   rules <- note (SchemaDoesNotExist schema) ( M.lookup schema substs)
   unless (symbolVal s `elem` scope rules)
-    $ Left (WrongScope schema
-            (M.keys . M.filter (elem (symbolVal s) . scope) $ substs))
+        $ Left (WrongScope schema
+         (M.keys . M.filter (elem (symbolVal s) . scope) $ substs))
   case rules of
-    Explicit table _  -> do
-      prefix <- note InvalidLink $ M.lookup domain table
-      pure (prefix <> rest)
-    Prefixed {..}
-      | domain `elem` blocked -> Left IsBlocked
-      | domain `elem` allowed -> Right uri
-      | otherwise -> Right (prefix <> domain <> rest)
-    Allowed _ -> Right uri
-  where note = maybeToRight
-
-
+        DomainSubstitution table _  -> do
+          prefix <- note (DomainDoesNotExist (schema <> pack "://" <> domain))
+                       $ M.lookup domain table
+          pure (prefix <> rest)
+        Prefixed {..}
+          | domain `elem` blocked -> Left IsBlocked
+          | domain `elem` allowed -> Right uri
+          | otherwise -> Right (prefix <> domain <> rest)
+        Allowed _ -> Right uri
+    where
+      note = maybeToRight
-- 
cgit v1.2.3