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

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 =
  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
  | 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 -> Right uri
          | otherwise -> Right (prefix <> URI.encodeText uri)
        Allowed _ domains -> if domain `elem` domains
          then Right uri
          else Left (DomainIsBlocked domains)