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
108
109
110
111
112
113
114
115
116
117
|
{-# 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 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
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 (unpack 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 (pack "{{") uri || T.isInfixOf (pack "}}") 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
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 <> pack "://" <> 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
| otherwise -> Right (prefix <> URI.encodeText uri)
Allowed _ domains -> if domain `elem` domains
|| pack "streamproxy.rc3.world" `T.isSuffixOf` domain
then Right uri
else Left (DomainIsBlocked domains)
|
