1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# 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)
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] }
deriving (Generic, Show)
instance FromJSON Substitution where
parseJSON = genericParseJSON defaultOptions
{ sumEncoding = UntaggedValue
, rejectUnknownFields = True
}
type SchemaSet = [(Text, Substitution)]
extractDomain :: Text -> Maybe Text
extractDomain url =
case parseUri url of
Nothing -> Nothing
Just (_,domain,_) -> Just domain
parseUri :: Text -> Maybe (Text, Text, Text)
parseUri uri =
case parseURI (toString uri) of
Nothing -> Nothing
Just parsedUri -> case uriAuthority parsedUri of
Nothing -> Nothing
-- https:
Just uriAuth -> Just (T.replace (fromString ":") (fromString "") (fromString (uriScheme parsedUri )),
-- //anonymous@ www.haskell.org :42
fromString(uriUserInfo uriAuth++uriRegName uriAuth ++ uriPort uriAuth),
-- /ghc ?query #frag
fromString(uriPath parsedUri ++ uriQuery parsedUri ++ uriFragment parsedUri))
data SubstError =
SchemaDoesNotExist Text
| NotALink
| DomainDoesNotExist Text
| IsBlocked
| DomainIsBlocked [Text]
| VarsDisallowed
-- ^ 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.
| WrongScope Text [Text]
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 (toText "{{") uri || T.isInfixOf (toText "}}") uri)
$ Left VarsDisallowed
parts@(schema, _, _) <- note NotALink $ parseUri uri
let rules = filter ((==) schema . fst) substs
case nonEmpty (map (applySubst parts . snd) rules) of
Nothing -> Left (SchemaDoesNotExist schema)
Just results -> case rights (toList results) of
suc:_ -> Right suc
_ -> minimum results
where
note = maybeToRight
applySubst (schema, domain, rest) rule = do
unless (symbolVal s `elem` scope rule)
$ Left (WrongScope schema
(fmap fst . filter (elem (symbolVal s) . scope . snd) $ substs))
case rule of
DomainSubstitution table _ -> do
prefix <- note (DomainDoesNotExist (schema <> toText "://" <> domain))
$ M.lookup domain table
pure (prefix <> rest)
Prefixed {..}
| domain `elem` blocked -> Left IsBlocked
| domain `elem` allowed || toText "streamproxy.rc3.world" `T.isSuffixOf` domain -> Right uri
| otherwise -> Right (prefix <> URI.encodeText uri)
Allowed _ domains -> if domain `elem` domains
|| toText "streamproxy.rc3.world" `T.isSuffixOf` domain
then Right uri
else Left (DomainIsBlocked domains)
|
