Uris.hs

{-# 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           Universum

import           Data.Aeson         (FromJSON (..), Options (..),
                                     SumEncoding (UntaggedValue),
                                     defaultOptions, genericParseJSON)
import qualified Data.Map.Strict    as M
import qualified Data.Text          as T
import           GHC.TypeLits       (KnownSymbol, symbolVal)
import           Network.URI        (URI (..), URIAuth (..), parseURI)
import qualified 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 =
  case parseUri url of
    Nothing           -> Nothing
    Just (_,domain,_) -> Just domain




parseUri :: Text -> Maybe (Text, Text, Text)
parseUri uri =
  case parseURI (toString 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 (toText "{{") uri || T.isInfixOf (toText "}}") uri)
   $ Left VarsDisallowed
  parts@(schema, _, _) <- note NotALink $ parseUri uri

  let rules = filter ((==) schema . fst) substs

  case nonEmpty (map (applySubst parts . snd) rules) of
    Nothing  -> Left (SchemaDoesNotExist schema)
    Just results -> case rights (toList 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 <> toText "://" <> domain))
                       $ M.lookup domain table
          pure (prefix <> rest)
        Prefixed {..}
          | domain `elem` blocked -> Left IsBlocked
          | domain `elem` allowed || toText "streamproxy.rc3.world" `T.isSuffixOf` domain -> Right uri
          | otherwise -> Right (prefix <> URI.encodeText uri)
        Allowed _ domains -> if domain `elem` domains
                    || toText "streamproxy.rc3.world" `T.isSuffixOf` domain
          then Right uri
          else Left (DomainIsBlocked domains)