diff options
author | stuebinm | 2021-11-20 03:11:31 +0100 |
---|---|---|
committer | stuebinm | 2021-11-20 03:11:31 +0100 |
commit | a0b1472a7b348a50b9ef155fa2a457ab3f316383 (patch) | |
tree | bf70e4b09444d0288090e8e0ee969ab86fcbfa6f /lib | |
parent | aa383a2a3ab1c07167c3503a342630b632b3b8b2 (diff) |
whoops, forgot to add a file
Diffstat (limited to '')
-rw-r--r-- | lib/Uris.hs | 80 |
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 + + |