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