{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE DeriveAnyClass   #-}
{-# LANGUAGE DeriveGeneric    #-}
{-# LANGUAGE RecordWildCards  #-}
{-# LANGUAGE TypeApplications #-}

-- | Functions to deal with uris and custom uri schemes
module Uris where



import           Control.Monad           (unless)
import           Data.Aeson              (FromJSON (..), Options (..),
                                          SumEncoding (UntaggedValue),
                                          defaultOptions, genericParseJSON)
import           Data.Data               (Proxy)
import           Data.Either.Combinators (maybeToRight)
import           Data.Map.Strict         (Map)
import qualified Data.Map.Strict         as M
import           Data.Text               (Text)
import           GHC.Generics            (Generic)
import           GHC.TypeLits            (KnownSymbol, symbolVal)
import           Text.Regex.TDFA         ((=~))

data Substitution =
    Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] }
  | Explicit { substs :: Map Text Text, scope :: [String] }
  | Allowed  { scope :: [String] }
  deriving (Generic, Show)


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

type SchemaSet = Map 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
  | IsBlocked
  | InvalidLink
  | WrongScope Text


applySubst :: KnownSymbol s => Proxy s -> SchemaSet -> Text -> Either SubstError Text
applySubst s substs uri =  do
  (schema, domain, rest) <- note NotALink $ parseUri uri
  rules <- note (SchemaDoesNotExist schema) ( M.lookup schema substs)
  unless (symbolVal s `elem` scope rules)
    $ Left (WrongScope schema)
  case rules of
    Explicit table _  -> do
      prefix <- note InvalidLink $ M.lookup domain table
      pure (prefix <> rest)
    Prefixed {..}
      | domain `elem` blocked -> Left IsBlocked
      | domain `elem` allowed -> Right uri
      | otherwise -> Right (prefix <> domain <> rest)
    Allowed _ -> Right uri
  where note = maybeToRight