{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module      :  Text.URI
-- Copyright   :  © 2017–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- This is a modern library for working with URIs as per RFC 3986:
--
-- <https://tools.ietf.org/html/rfc3986>
--
-- This module is intended to be imported qualified, e.g.:
--
-- > import Text.URI (URI)
-- > import qualified Text.URI as URI
--
-- See also "Text.URI.Lens" for lens, prisms, and traversals; see
-- "Text.URI.QQ" for quasi-quoters for compile-time validation of URIs and
-- refined text components.
module Text.URI
  ( -- * Data types
    URI (..),
    mkURI,
    mkURIBs,
    emptyURI,
    makeAbsolute,
    isPathAbsolute,
    relativeTo,
    Authority (..),
    UserInfo (..),
    QueryParam (..),
    ParseException (..),
    ParseExceptionBs (..),

    -- * Refined text
    -- $rtext
    RText,
    RTextLabel (..),
    mkScheme,
    mkHost,
    mkUsername,
    mkPassword,
    mkPathPiece,
    mkQueryKey,
    mkQueryValue,
    mkFragment,
    unRText,
    RTextException (..),

    -- * Parsing
    -- $parsing
    parser,
    parserBs,

    -- * Rendering
    -- $rendering
    render,
    render',
    renderBs,
    renderBs',
    renderStr,
    renderStr',
  )
where

import Data.Either (isLeft)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust, isNothing)
import Text.URI.Parser.ByteString
import Text.URI.Parser.Text
import Text.URI.Render
import Text.URI.Types

-- | The empty 'URI'.
--
-- @since 0.2.1.0
emptyURI :: URI
emptyURI :: URI
emptyURI =
  URI :: Maybe (RText 'Scheme)
-> Either Bool Authority
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
-> [QueryParam]
-> Maybe (RText 'Fragment)
-> URI
URI
    { uriScheme :: Maybe (RText 'Scheme)
uriScheme = Maybe (RText 'Scheme)
forall a. Maybe a
Nothing,
      uriAuthority :: Either Bool Authority
uriAuthority = Bool -> Either Bool Authority
forall a b. a -> Either a b
Left Bool
False,
      uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath = Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a. Maybe a
Nothing,
      uriQuery :: [QueryParam]
uriQuery = [],
      uriFragment :: Maybe (RText 'Fragment)
uriFragment = Maybe (RText 'Fragment)
forall a. Maybe a
Nothing
    }

-- $rtext
--
-- Refined text values can only be created by using the smart constructors
-- listed below, such as 'mkScheme'. This eliminates the possibility of
-- having an invalid component in 'URI' which could invalidate the whole
-- 'URI'.
--
-- Note that the refined text 'RText' type is labelled at the type level
-- with 'RTextLabel's, which see.
--
-- When an invalid 'Data.Text.Text' value is passed to a smart constructor,
-- it rejects it by throwing the 'RTextException'. Remember that the 'Maybe'
-- datatype is also an instance of 'Control.Monad.Catch.MonadThrow', and so
-- one could as well use the smart constructors in the 'Maybe' monad.

-- $parsing
--
-- The input you feed into the parsers must be a valid URI as per RFC 3986,
-- that is, its components should be percent-encoded where necessary.

-- $rendering
--
-- Rendering functions take care of constructing correct 'URI'
-- representation as per RFC 3986, that is, percent-encoding will be applied
-- when necessary automatically.

-- | @'relativeTo' reference base@ makes the @reference@ 'URI' absolute
-- resolving it against the @base@ 'URI'.
--
-- If the base 'URI' is not absolute itself (that is, it has no scheme),
-- this function returns 'Nothing'.
--
-- See also: <https://tools.ietf.org/html/rfc3986#section-5.2>.
--
-- @since 0.2.0.0
relativeTo ::
  -- | Reference 'URI' to make absolute
  URI ->
  -- | Base 'URI'
  URI ->
  -- | The target 'URI'
  Maybe URI
relativeTo :: URI -> URI -> Maybe URI
relativeTo URI
r URI
base =
  case URI -> Maybe (RText 'Scheme)
uriScheme URI
base of
    Maybe (RText 'Scheme)
Nothing -> Maybe URI
forall a. Maybe a
Nothing
    Just RText 'Scheme
bscheme ->
      URI -> Maybe URI
forall a. a -> Maybe a
Just (URI -> Maybe URI) -> URI -> Maybe URI
forall a b. (a -> b) -> a -> b
$
        if Maybe (RText 'Scheme) -> Bool
forall a. Maybe a -> Bool
isJust (URI -> Maybe (RText 'Scheme)
uriScheme URI
r)
          then URI
r {uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath = URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath URI
r Maybe (Bool, NonEmpty (RText 'PathPiece))
-> ((Bool, NonEmpty (RText 'PathPiece))
    -> Maybe (Bool, NonEmpty (RText 'PathPiece)))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
removeDotSegments}
          else
            URI
r
              { uriScheme :: Maybe (RText 'Scheme)
uriScheme = RText 'Scheme -> Maybe (RText 'Scheme)
forall a. a -> Maybe a
Just RText 'Scheme
bscheme,
                uriAuthority :: Either Bool Authority
uriAuthority = case URI -> Either Bool Authority
uriAuthority URI
r of
                  Right Authority
auth -> Authority -> Either Bool Authority
forall a b. b -> Either a b
Right Authority
auth
                  Left Bool
rabs ->
                    case URI -> Either Bool Authority
uriAuthority URI
base of
                      Right Authority
auth -> Authority -> Either Bool Authority
forall a b. b -> Either a b
Right Authority
auth
                      Left Bool
babs -> Bool -> Either Bool Authority
forall a b. a -> Either a b
Left (Bool
babs Bool -> Bool -> Bool
|| Bool
rabs),
                uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath =
                  (Maybe (Bool, NonEmpty (RText 'PathPiece))
-> ((Bool, NonEmpty (RText 'PathPiece))
    -> Maybe (Bool, NonEmpty (RText 'PathPiece)))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
removeDotSegments) (Maybe (Bool, NonEmpty (RText 'PathPiece))
 -> Maybe (Bool, NonEmpty (RText 'PathPiece)))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a b. (a -> b) -> a -> b
$
                    if URI -> Bool
isPathAbsolute URI
r
                      then URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath URI
r
                      else case (URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath URI
base, URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath URI
r) of
                        (Maybe (Bool, NonEmpty (RText 'PathPiece))
Nothing, Maybe (Bool, NonEmpty (RText 'PathPiece))
Nothing) -> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a. Maybe a
Nothing
                        (Just (Bool, NonEmpty (RText 'PathPiece))
b', Maybe (Bool, NonEmpty (RText 'PathPiece))
Nothing) -> (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a. a -> Maybe a
Just (Bool, NonEmpty (RText 'PathPiece))
b'
                        (Maybe (Bool, NonEmpty (RText 'PathPiece))
Nothing, Just (Bool, NonEmpty (RText 'PathPiece))
r') -> (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a. a -> Maybe a
Just (Bool, NonEmpty (RText 'PathPiece))
r'
                        (Just (Bool
bt, NonEmpty (RText 'PathPiece)
bps), Just (Bool
rt, NonEmpty (RText 'PathPiece)
rps)) ->
                          (NonEmpty (RText 'PathPiece)
 -> (Bool, NonEmpty (RText 'PathPiece)))
-> Maybe (NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool
rt,) (Maybe (NonEmpty (RText 'PathPiece))
 -> Maybe (Bool, NonEmpty (RText 'PathPiece)))
-> ([RText 'PathPiece] -> Maybe (NonEmpty (RText 'PathPiece)))
-> [RText 'PathPiece]
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RText 'PathPiece] -> Maybe (NonEmpty (RText 'PathPiece))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([RText 'PathPiece] -> Maybe (Bool, NonEmpty (RText 'PathPiece)))
-> [RText 'PathPiece] -> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a b. (a -> b) -> a -> b
$
                            (if Bool
bt then NonEmpty (RText 'PathPiece) -> [RText 'PathPiece]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (RText 'PathPiece)
bps else NonEmpty (RText 'PathPiece) -> [RText 'PathPiece]
forall a. NonEmpty a -> [a]
NE.init NonEmpty (RText 'PathPiece)
bps)
                              [RText 'PathPiece] -> [RText 'PathPiece] -> [RText 'PathPiece]
forall a. Semigroup a => a -> a -> a
<> NonEmpty (RText 'PathPiece) -> [RText 'PathPiece]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (RText 'PathPiece)
rps,
                uriQuery :: [QueryParam]
uriQuery =
                  if Either Bool Authority -> Bool
forall a b. Either a b -> Bool
isLeft (URI -> Either Bool Authority
uriAuthority URI
r)
                    Bool -> Bool -> Bool
&& Maybe (Bool, NonEmpty (RText 'PathPiece)) -> Bool
forall a. Maybe a -> Bool
isNothing (URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath URI
r)
                    Bool -> Bool -> Bool
&& [QueryParam] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> [QueryParam]
uriQuery URI
r)
                    then URI -> [QueryParam]
uriQuery URI
base
                    else URI -> [QueryParam]
uriQuery URI
r
              }

----------------------------------------------------------------------------
-- Helpers

-- | Remove dot segments from a path.
removeDotSegments ::
  (Bool, NonEmpty (RText 'PathPiece)) ->
  Maybe (Bool, NonEmpty (RText 'PathPiece))
removeDotSegments :: (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
removeDotSegments (Bool
trailSlash, NonEmpty (RText 'PathPiece)
path) = [RText 'PathPiece]
-> [RText 'PathPiece]
-> Bool
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall (l :: RTextLabel).
[RText l] -> [RText l] -> Bool -> Maybe (Bool, NonEmpty (RText l))
go [] (NonEmpty (RText 'PathPiece) -> [RText 'PathPiece]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (RText 'PathPiece)
path) Bool
trailSlash
  where
    go :: [RText l] -> [RText l] -> Bool -> Maybe (Bool, NonEmpty (RText l))
go [RText l]
out [] Bool
ts = ((NonEmpty (RText l) -> (Bool, NonEmpty (RText l)))
-> Maybe (NonEmpty (RText l)) -> Maybe (Bool, NonEmpty (RText l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool
ts,) (Maybe (NonEmpty (RText l)) -> Maybe (Bool, NonEmpty (RText l)))
-> ([RText l] -> Maybe (NonEmpty (RText l)))
-> [RText l]
-> Maybe (Bool, NonEmpty (RText l))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RText l] -> Maybe (NonEmpty (RText l))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([RText l] -> Maybe (NonEmpty (RText l)))
-> ([RText l] -> [RText l])
-> [RText l]
-> Maybe (NonEmpty (RText l))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RText l] -> [RText l]
forall a. [a] -> [a]
reverse) [RText l]
out
    go [RText l]
out (RText l
x : [RText l]
xs) Bool
ts
      | RText l -> Text
forall (l :: RTextLabel). RText l -> Text
unRText RText l
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"." = [RText l] -> [RText l] -> Bool -> Maybe (Bool, NonEmpty (RText l))
go [RText l]
out [RText l]
xs ([RText l] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RText l]
xs Bool -> Bool -> Bool
|| Bool
ts)
      | RText l -> Text
forall (l :: RTextLabel). RText l -> Text
unRText RText l
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
".." = [RText l] -> [RText l] -> Bool -> Maybe (Bool, NonEmpty (RText l))
go (Int -> [RText l] -> [RText l]
forall a. Int -> [a] -> [a]
drop Int
1 [RText l]
out) [RText l]
xs ([RText l] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RText l]
xs Bool -> Bool -> Bool
|| Bool
ts)
      | Bool
otherwise = [RText l] -> [RText l] -> Bool -> Maybe (Bool, NonEmpty (RText l))
go (RText l
x RText l -> [RText l] -> [RText l]
forall a. a -> [a] -> [a]
: [RText l]
out) [RText l]
xs Bool
ts