summaryrefslogtreecommitdiff
path: root/lib/Uris.hs
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Uris.hs44
1 files changed, 17 insertions, 27 deletions
diff --git a/lib/Uris.hs b/lib/Uris.hs
index 00f86a4..a8c7068 100644
--- a/lib/Uris.hs
+++ b/lib/Uris.hs
@@ -8,26 +8,16 @@
-- | Functions to deal with uris and custom uri schemes
module Uris where
+import Universum
-
-import Control.Monad (unless, when)
-import Data.Aeson (FromJSON (..), Options (..),
- SumEncoding (UntaggedValue),
- defaultOptions, genericParseJSON)
-import Data.Data (Proxy)
-import Data.Either.Combinators (maybeToRight, rightToMaybe)
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-import Data.Text (Text, pack, unpack)
-import qualified Data.Text as T
-import GHC.Generics (Generic)
-import GHC.TypeLits (KnownSymbol, symbolVal)
-import Network.URI.Encode as URI
-import Text.Regex.TDFA ((=~))
-import Witherable (mapMaybe)
-
-import Data.String
-import Network.URI as NativeUri
+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)
+import qualified Network.URI.Encode as URI
data Substitution =
Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] }
@@ -56,7 +46,7 @@ extractDomain url =
parseUri :: Text -> Maybe (Text, Text, Text)
parseUri uri =
- case parseURI (unpack uri) of
+ case parseURI (toString uri) of
Nothing -> Nothing
Just parsedUri -> case uriAuthority parsedUri of
Nothing -> Nothing
@@ -84,15 +74,15 @@ data SubstError =
applySubsts :: KnownSymbol s
=> Proxy s -> SchemaSet -> Text -> Either SubstError Text
applySubsts s substs uri = do
- when (T.isInfixOf (pack "{{") uri || T.isInfixOf (pack "}}") uri)
+ when (T.isInfixOf (toText "{{") uri || T.isInfixOf (toText "}}") uri)
$ Left VarsDisallowed
parts@(schema, _, _) <- note NotALink $ parseUri uri
let rules = filter ((==) schema . fst) substs
- case fmap (applySubst parts . snd) rules of
- [] -> Left (SchemaDoesNotExist schema)
- results@(_:_) -> case mapMaybe rightToMaybe results of
+ case nonEmpty (map (applySubst parts . snd) rules) of
+ Nothing -> Left (SchemaDoesNotExist schema)
+ Just results -> case rights (toList results) of
suc:_ -> Right suc
_ -> minimum results
@@ -104,14 +94,14 @@ applySubsts s substs uri = do
(fmap fst . filter (elem (symbolVal s) . scope . snd) $ substs))
case rule of
DomainSubstitution table _ -> do
- prefix <- note (DomainDoesNotExist (schema <> pack "://" <> domain))
+ prefix <- note (DomainDoesNotExist (schema <> toText "://" <> domain))
$ M.lookup domain table
pure (prefix <> rest)
Prefixed {..}
| domain `elem` blocked -> Left IsBlocked
- | domain `elem` allowed || pack "streamproxy.rc3.world" `T.isSuffixOf` domain -> Right uri
+ | domain `elem` allowed || toText "streamproxy.rc3.world" `T.isSuffixOf` domain -> Right uri
| otherwise -> Right (prefix <> URI.encodeText uri)
Allowed _ domains -> if domain `elem` domains
- || pack "streamproxy.rc3.world" `T.isSuffixOf` domain
+ || toText "streamproxy.rc3.world" `T.isSuffixOf` domain
then Right uri
else Left (DomainIsBlocked domains)