Skip to content
Snippets Groups Projects
Select Git revision
  • d452935986aa9209677d8d461078857fbb680d9d
  • master default protected
  • jwt_encode_inconsistencies
  • recovery-code-pwhash
  • incremental-sync
  • redis-rate-limits
  • typehints
  • v1.2.x
  • v1.x.x
  • v1.1.x
  • feature_invite_validuntil_minmax
  • Dockerfile
  • v1.0.x
  • roles-recursive-cte
  • v2.3.1
  • v2.3.0
  • v2.2.0
  • v2.1.0
  • v2.0.1
  • v2.0.0
  • v1.2.0
  • v1.1.2
  • v1.1.1
  • v1.0.2
  • v1.1.0
  • v1.0.1
  • v1.0.0
  • v0.3.0
  • v0.2.0
  • v0.1.5
  • v0.1.4
  • v0.1.2
32 results

setup.py

Blame
  • Forked from uffd / uffd
    Source project has a limited visibility.
    Uris.hs 4.17 KiB
    {-# 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, unpack)
    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
    
    import Network.URI as NativeUri
    import Data.String
    
    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 =
      case parseUri url of
        Nothing  -> Nothing 
        Just (_,domain,_) -> Just domain
    
    
    
    
    parseUri :: Text -> Maybe (Text, Text, Text)
    parseUri uri =
      case parseURI (unpack uri) of
        Nothing -> Nothing
        Just parsedUri -> case uriAuthority parsedUri of
            Nothing -> Nothing
            --                                             https:                                         
            Just uriAuth -> Just (T.replace (fromString ":") (fromString "") (fromString (uriScheme parsedUri )),
            --             //anonymous@        www.haskell.org         :42 
              fromString(uriUserInfo uriAuth++uriRegName uriAuth ++ uriPort uriAuth),
            --  /ghc          ?query                 #frag
              fromString(uriPath parsedUri ++ uriQuery parsedUri ++ uriFragment parsedUri))
     
    
    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 || pack "streamproxy.rc3.world" `T.isSuffixOf` domain -> Right uri
              | otherwise -> Right (prefix <> URI.encodeText uri)
            Allowed _ domains -> if domain `elem` domains
                        || pack "streamproxy.rc3.world" `T.isSuffixOf` domain
              then Right uri
              else Left (DomainIsBlocked domains)