summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorstuebinm2021-11-20 03:11:31 +0100
committerstuebinm2021-11-20 03:11:31 +0100
commita0b1472a7b348a50b9ef155fa2a457ab3f316383 (patch)
treebf70e4b09444d0288090e8e0ee969ab86fcbfa6f /lib
parentaa383a2a3ab1c07167c3503a342630b632b3b8b2 (diff)
whoops, forgot to add a file
Diffstat (limited to 'lib')
-rw-r--r--lib/Uris.hs80
1 files changed, 80 insertions, 0 deletions
diff --git a/lib/Uris.hs b/lib/Uris.hs
new file mode 100644
index 0000000..dfbd454
--- /dev/null
+++ b/lib/Uris.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- | Functions to deal with uris and custom uri schemes
+module Uris where
+
+
+
+import Control.Monad (unless)
+import Data.Aeson (FromJSON (..), Options (..),
+ SumEncoding (UntaggedValue),
+ defaultOptions, genericParseJSON)
+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 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] }
+ | Allowed { scope :: [String] }
+ deriving (Generic, Show)
+
+
+instance FromJSON Substitution where
+ parseJSON = genericParseJSON defaultOptions
+ { sumEncoding = UntaggedValue
+ , rejectUnknownFields = True
+ }
+
+type SchemaSet = Map Text Substitution
+
+
+extractDomain :: Text -> Maybe Text
+extractDomain url =
+ let (_,_,_,matches) = url =~ "^https://([^/]+)/?.*$" :: (Text,Text,Text,[Text])
+ in case matches of
+ [domain] -> Just domain
+ _ -> Nothing
+
+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
+
+data SubstError =
+ SchemaDoesNotExist Text
+ | NotALink
+ | IsBlocked
+ | InvalidLink
+ | WrongScope Text
+
+
+applySubst :: KnownSymbol s => Proxy s -> SchemaSet -> Text -> Either SubstError Text
+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)
+ 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
+
+