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
|
{-# 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)
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)
import GHC.Generics (Generic)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Text.Regex.TDFA ((=~))
data Substitution =
Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] }
| Explicit { 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
| InvalidLink
| WrongScope Text
applySubst :: KnownSymbol s => Proxy s -> SchemaSet -> Text -> Either SubstError Text
applySubst s substs uri = do
(schema, domain, rest) <- note NotALink $ parseUri uri
rules <- note (SchemaDoesNotExist schema) ( M.lookup schema substs)
unless (symbolVal s `elem` scope rules)
$ Left (WrongScope schema)
case rules of
Explicit table _ -> do
prefix <- note InvalidLink $ 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
|
