1 files changed, 103 insertions, 0 deletions
diff --git a/walint/Uris.hs b/walint/Uris.hs
new file mode 100644
index 0000000..cb15b47
--- /dev/null
+++ b/walint/Uris.hs
@@ -0,0 +1,103 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+-- | Functions to deal with uris and custom uri schemes
+module Uris where
+
+import           Universum
+
+import           Data.Aeson         (FromJSON (..), Options (..),
+                                     SumEncoding (UntaggedValue),
+                                     defaultOptions, genericParseJSON)
+import qualified Data.Map.Strict    as M
+import qualified Data.Text          as T
+import           GHC.TypeLits       (KnownSymbol, symbolVal)
+import           Network.URI        (URI (..), URIAuth (..), parseURI,
+                                     uriToString)
+import qualified Network.URI.Encode as URI
+
+data Substitution =
+    Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] }
+  | DomainSubstitution { substs :: Map Text Text, scope :: [String] }
+  | Allowed  { scope :: [String], allowed :: [Text] }
+  | Unrestricted { scope :: [String] }
+  deriving (Generic, Show, NFData)
+
+
+instance FromJSON Substitution where
+  parseJSON = genericParseJSON defaultOptions
+    { sumEncoding = UntaggedValue
+    , rejectUnknownFields = True
+    }
+
+type SchemaSet = Map Text [Substitution]
+
+
+-- | 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 (T.strip raw)) of
+    Nothing -> Nothing
+    Just uri@URI{..} -> case uriAuthority of
+        Nothing -> Nothing
+        Just URIAuth {..} -> Just
+          ( fromString uriScheme
+          , fromString $ uriUserInfo <> uriRegName <> uriPort
+          , fromString $ uriPath <> uriQuery <> uriFragment
+          , fromString $ uriToString id uri ""
+          )
+
+
+data SubstError =
+    SchemaDoesNotExist Text
+  | NotALink
+  | DomainDoesNotExist Text
+  | 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.
+  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 "{{" uri || T.isInfixOf "}}" uri)
+   $ Left VarsDisallowed
+  parts@(schema, _, _, _) <- maybeToRight NotALink $ parseUri uri
+
+  let rules = filter (elem thisScope . scope) . concat $ M.lookup schema substs
+
+  case nonEmpty $ map (applySubst parts) rules of
+    Nothing     -> Left (SchemaDoesNotExist schema)
+    Just result -> minimum result
+  where
+    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 -- make list of available uri schemes
+                 . filter (any (elem thisScope . scope) . snd)
+                 $ toPairs substs)
+
+      case rule of
+        DomainSubstitution table _  -> do
+          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 -> Right uri
+          | otherwise -> Right (prefix <> URI.encodeText uri)
+        Allowed _ allowlist
+          | domain `elem` allowlist -> Right uri
+          | otherwise -> Left (DomainIsBlocked allowlist)
+        Unrestricted _ -> Right uri