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
|
{-# 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)
import qualified Data.Text as T
import GHC.Generics (Generic)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Text.Regex.TDFA ((=~))
import Witherable (mapMaybe)
import 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 =
let (_,_,_,matches) = url =~ "^https://([^/]+)/?.*$" :: (Text,Text,Text,[Text])
in case matches of
[domain] -> Just domain
_ -> Nothing
parseUri :: Text -> Maybe (Text, Text, Text)
parseUri uri =
let (_,_,_,matches) = uri =~ "^([a-zA-Z0-9]+)://([^/]+)(/?.*)$" :: (Text,Text,Text,[Text])
in case matches of
[schema, domain, rest] -> Just (schema, domain, rest)
_ -> Nothing
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 -> Right uri
| otherwise -> Right (prefix <> URI.encodeText uri)
Allowed _ domains -> if domain `elem` domains
then Right uri
else Left (DomainIsBlocked domains)
|
