Skip to content
Snippets Groups Projects
Select Git revision
1 result Searching

Uris.hs

Blame
  • Uris.hs 3.06 KiB
    {-# 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)