{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Text.URI
(
URI (..)
, mkURI
, emptyURI
, makeAbsolute
, isPathAbsolute
, relativeTo
, Authority (..)
, UserInfo (..)
, QueryParam (..)
, ParseException (..)
, RText
, RTextLabel (..)
, mkScheme
, mkHost
, mkUsername
, mkPassword
, mkPathPiece
, mkQueryKey
, mkQueryValue
, mkFragment
, unRText
, RTextException (..)
, parser
, parserBs
, render
, render'
, renderBs
, renderBs'
, renderStr
, renderStr' )
where
import Data.Either (isLeft)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (isJust, isNothing)
import Text.URI.Parser.ByteString
import Text.URI.Parser.Text
import Text.URI.Render
import Text.URI.Types
import qualified Data.List.NonEmpty as NE
#if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ((<>))
#endif
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
}
relativeTo
:: URI
-> URI
-> Maybe URI
relativeTo :: URI -> URI -> Maybe URI
relativeTo r :: URI
r base :: URI
base =
case URI -> Maybe (RText 'Scheme)
uriScheme URI
base of
Nothing -> Maybe URI
forall a. Maybe a
Nothing
Just bscheme :: 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 auth :: Authority
auth -> Authority -> Either Bool Authority
forall a b. b -> Either a b
Right Authority
auth
Left rabs :: Bool
rabs ->
case URI -> Either Bool Authority
uriAuthority URI
base of
Right auth :: Authority
auth -> Authority -> Either Bool Authority
forall a b. b -> Either a b
Right Authority
auth
Left babs :: 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
(Nothing, Nothing) -> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a. Maybe a
Nothing
(Just b' :: (Bool, NonEmpty (RText 'PathPiece))
b', Nothing) -> (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall a. a -> Maybe a
Just (Bool, NonEmpty (RText 'PathPiece))
b'
(Nothing, Just r' :: (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 (bt :: Bool
bt, bps :: NonEmpty (RText 'PathPiece)
bps), Just (rt :: Bool
rt, rps :: 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
}
removeDotSegments
:: (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
removeDotSegments :: (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
removeDotSegments (trailSlash :: Bool
trailSlash, path :: 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 out :: [RText l]
out [] ts :: 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 out :: [RText l]
out (x :: RText l
x:xs :: [RText l]
xs) ts :: 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
== "." = [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
== ".." = [RText l] -> [RText l] -> Bool -> Maybe (Bool, NonEmpty (RText l))
go (Int -> [RText l] -> [RText l]
forall a. Int -> [a] -> [a]
drop 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
xRText l -> [RText l] -> [RText l]
forall a. a -> [a] -> [a]
:[RText l]
out) [RText l]
xs Bool
ts