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
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# 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)
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 ((=~))
data Substitution =
Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] }
| DomainSubstitution { substs :: Map Text Text, scope :: [String] }
| Allowed { scope :: [String] }
deriving (Generic, Show)
instance FromJSON Substitution where
parseJSON = genericParseJSON defaultOptions
{ sumEncoding = UntaggedValue
, rejectUnknownFields = True
}
type SchemaSet = Map 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
| IsBlocked
| DomainDoesNotExist Text
| WrongScope Text [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.
applySubst :: KnownSymbol s
=> Proxy s -> SchemaSet -> Text -> Either SubstError Text
applySubst s substs uri = do
when (T.isInfixOf (pack "{{") uri || T.isInfixOf (pack "}}") uri)
$ Left VarsDisallowed
(schema, domain, rest) <- note NotALink $ parseUri uri
rules <- note (SchemaDoesNotExist schema) ( M.lookup schema substs)
unless (symbolVal s `elem` scope rules)
$ Left (WrongScope schema
(M.keys . M.filter (elem (symbolVal s) . scope) $ substs))
case rules 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 <> domain <> rest)
Allowed _ -> Right uri
where
note = maybeToRight
|
