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
|
{-# 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 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
|
