URI.hs

{- SPDX-FileCopyrightText: 2023 Serokell <https://serokell.io>
 -
 - SPDX-License-Identifier: MPL-2.0
 -}

{-# LANGUAGE ExistentialQuantification #-}

module Xrefcheck.Data.URI
  ( UriParseError (..)
  , parseUri
  ) where

import Universum

import Control.Exception.Safe (handleJust)
import Control.Monad.Except (throwError)
import Text.URI (ParseExceptionBs, URI, mkURIBs)
import URI.ByteString qualified as URIBS

data UriParseError
  = UPEInvalid URIBS.URIParseError
  | UPEConversion ParseExceptionBs
  deriving stock (Show, Eq)

data AnyURIRef = forall a. AnyURIRef (URIBS.URIRef a)

serializeAnyURIRef :: AnyURIRef -> ByteString
serializeAnyURIRef (AnyURIRef uri) = URIBS.serializeURIRef' uri

-- | Parse URI according to RFC 3986 extended by allowing non-encoded
-- `[` and `]` in query string.
--
-- The first parameter indicates whether the parsing should admit relative
-- URIs or not.
parseUri :: Bool -> Text -> ExceptT UriParseError IO URI
parseUri canBeRelative link = do
  -- There exist two main standards of URL parsing: RFC 3986 and the Web
  -- Hypertext Application Technology Working Group's URL standard. Ideally,
  -- we want to be able to parse the URLs in accordance with the latter
  -- standard, because it provides a much less ambiguous set of rules for
  -- percent-encoding special characters, and is essentially a living
  -- standard that gets updated constantly.
  --
  -- We have chosen the 'uri-bytestring' library for URI parsing because
  -- of the 'laxURIParseOptions' parsing configuration. 'mkURI' from
  -- the 'modern-uri' library parses URIs in accordance with RFC 3986 and does
  -- not provide a means of parsing customization, which contrasts with
  -- 'parseURI' that accepts a 'URIParserOptions'. One of the predefined
  -- configurations of this type is 'strictURIParserOptions', which follows
  -- RFC 3986, and the other -- 'laxURIParseOptions' -- allows brackets
  -- in the queries, which draws us closer to the WHATWG URL standard.
  --
  -- The 'modern-uri' package can parse an URI deciding if it is absolute or
  -- relative depending on the success or failure of the scheme parsing. By
  -- contrast, in 'uri-bytestring' it has to be decided beforehand, resulting in
  -- different URI types.
  uri <- case URIBS.parseURI URIBS.laxURIParserOptions (encodeUtf8 link) of
    Left (URIBS.MalformedScheme _) | canBeRelative ->
      URIBS.parseRelativeRef URIBS.laxURIParserOptions (encodeUtf8 link)
        & either (throwError . UPEInvalid) (pure . AnyURIRef)
    Left err -> throwError $ UPEInvalid err
    Right uri -> pure $ AnyURIRef uri

  -- We stick to our infrastructure by continuing to operate on the datatypes
  -- from 'modern-uri', which are used in the 'req' library. First we
  -- serialize our URI parsed with 'parseURI' so it becomes a 'ByteString'
  -- with all the necessary special characters *percent-encoded*, and then
  -- call 'mkURIBs'.
  mkURIBs (serializeAnyURIRef uri)
    -- Ideally, this exception should never be thrown, as the URI
    -- already *percent-encoded* with 'parseURI' from 'uri-bytestring'
    -- and 'mkURIBs' is only used to convert to 'URI' type from
    -- 'modern-uri' package.
    & handleJust fromException (throwError . UPEConversion)