{-# 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           Network.URI.Encode      as URI
import           Text.Regex.TDFA         ((=~))
import           Witherable              (mapMaybe)

import           Data.String
import           Network.URI             as NativeUri

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)