Uris.hs

{-# 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, when)
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, pack)
import           GHC.Generics            (Generic)
import           GHC.TypeLits            (KnownSymbol, symbolVal)
import           Text.Regex.TDFA         ((=~))

data Substitution =
    Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] }
  | DomainSubstitution { 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
  | DomainDoesNotExist Text
  | WrongScope Text [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.


applySubst :: KnownSymbol s
  => Proxy s -> SchemaSet -> Text -> Either SubstError Text
applySubst s substs uri =  do
  when (uri =~ "{{{.*}}}")
   $ Left VarsDisallowed
  (schema, domain, rest) <- note NotALink $ parseUri uri

  rules <- note (SchemaDoesNotExist schema) ( M.lookup schema substs)
  unless (symbolVal s `elem` scope rules)
        $ Left (WrongScope schema
         (M.keys . M.filter (elem (symbolVal s) . scope) $ substs))
  case rules 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 <> domain <> rest)
        Allowed _ -> Right uri
    where
      note = maybeToRight