Uris.hs

{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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,
                                     uriToString)
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] }
  | Unrestricted { scope :: [String] }
  deriving (Generic, Show, NFData)


instance FromJSON Substitution where
  parseJSON = genericParseJSON defaultOptions
    { sumEncoding = UntaggedValue
    , rejectUnknownFields = True
    }

type SchemaSet = Map Text [Substitution]


-- | deconstruct a URI into a triple of [schema:]//[domain]/[tail...],
-- and a normalised version of the same URI
parseUri :: Text -> Maybe (Text, Text, Text, Text)
parseUri raw =
  case parseURI (toString (T.strip raw)) of
    Nothing -> Nothing
    Just uri@URI{..} -> case uriAuthority of
        Nothing -> Nothing
        Just URIAuth {..} -> Just
          ( fromString uriScheme
          , fromString $ uriUserInfo <> uriRegName <> uriPort
          , fromString $ uriPath <> uriQuery <> uriFragment
          , fromString $ uriToString id uri ""
          )


data SubstError =
    SchemaDoesNotExist Text
  | NotALink
  | DomainDoesNotExist Text
  | IsBlocked
  | DomainIsBlocked [Text]
  | VarsDisallowed
  | WrongScope Text [Text]
  -- ^ 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.
  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 "{{" uri || T.isInfixOf "}}" uri)
   $ Left VarsDisallowed
  parts@(schema, _, _, _) <- maybeToRight NotALink $ parseUri uri

  let rules = filter (elem thisScope . scope) . concat $ M.lookup schema substs

  case nonEmpty $ map (applySubst parts) rules of
    Nothing     -> Left (SchemaDoesNotExist schema)
    Just result -> minimum result
  where
    thisScope = symbolVal s
    applySubst (schema, domain, rest, uri) rule = do

      -- is this scope applicable?
      unless (symbolVal s `elem` scope rule)
        $ Left (WrongScope schema
                 $ map fst -- make list of available uri schemes
                 . filter (any (elem thisScope . scope) . snd)
                 $ toPairs substs)

      case rule of
        DomainSubstitution table _  -> do
          prefix <- case M.lookup domain table of
            Nothing -> Left (DomainDoesNotExist (schema <> "//" <> domain))
            Just a  -> Right a
          pure (prefix <> rest)
        Prefixed {..}
          | domain `elem` blocked -> Left IsBlocked
          | domain `elem` allowed -> Right uri
          | otherwise -> Right (prefix <> URI.encodeText uri)
        Allowed _ allowlist
          | domain `elem` allowlist -> Right uri
          | otherwise -> Left (DomainIsBlocked allowlist)
        Unrestricted _ -> Right uri