diff options
Diffstat (limited to '')
-rw-r--r-- | lib/Uris.hs | 32 |
1 files changed, 16 insertions, 16 deletions
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 |