diff options
author | stuebinm | 2023-10-23 23:18:34 +0200 |
---|---|---|
committer | stuebinm | 2023-10-24 01:21:52 +0200 |
commit | 9110064fe62f98dd3ecc5fb4c3915a843492b8fb (patch) | |
tree | 6a8e3d54bef365bf1c6c4f72a7a75dd5d1f05d40 /lib/Uris.hs | |
parent | a4461ce5d73a617e614e259bfe30b4e895c38a19 (diff) |
This does many meta-things, but changes no functionality:
- get rid of stack, and use just cabal with a stackage snapshot instead
(why did I ever think stack was a good idea?)
- update the stackage snapshot to something halfway recent
- thus making builds work on nixpkgs-23.05 (current stable)
- separating out packages into their own cabal files
- use the GHC2021 set of extensions as default
- very slight code changes to make things build again
- update readme accordingly
- stylish-haskell run
Diffstat (limited to 'lib/Uris.hs')
-rw-r--r-- | lib/Uris.hs | 106 |
1 files changed, 0 insertions, 106 deletions
diff --git a/lib/Uris.hs b/lib/Uris.hs deleted file mode 100644 index 127b7f1..0000000 --- a/lib/Uris.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} - --- | 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 |