{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Text.URI
(
URI (..),
mkURI,
mkURIBs,
emptyURI,
makeAbsolute,
isPathAbsolute,
relativeTo,
Authority (..),
UserInfo (..),
QueryParam (..),
ParseException (..),
ParseExceptionBs (..),
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 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
emptyURI :: URI
emptyURI :: URI
emptyURI =
URI
{ uriScheme :: Maybe (RText 'Scheme)
uriScheme = forall a. Maybe a
Nothing,
uriAuthority :: Either Bool Authority
uriAuthority = forall a b. a -> Either a b
Left Bool
False,
uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath = forall a. Maybe a
Nothing,
uriQuery :: [QueryParam]
uriQuery = [],
uriFragment :: Maybe (RText 'Fragment)
uriFragment = forall a. Maybe a
Nothing
}
relativeTo ::
URI ->
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 -> forall a. Maybe a
Nothing
Just RText 'Scheme
bscheme ->
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
if 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 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 = 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 -> 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 -> forall a b. b -> Either a b
Right Authority
auth
Left Bool
babs -> forall a b. a -> Either a b
Left (Bool
babs Bool -> Bool -> Bool
|| Bool
rabs),
uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath =
(forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
removeDotSegments) 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) -> forall a. Maybe a
Nothing
(Just (Bool, NonEmpty (RText 'PathPiece))
b', Maybe (Bool, NonEmpty (RText 'PathPiece))
Nothing) -> forall a. a -> Maybe a
Just (Bool, NonEmpty (RText 'PathPiece))
b'
(Maybe (Bool, NonEmpty (RText 'PathPiece))
Nothing, Just (Bool, NonEmpty (RText 'PathPiece))
r') -> 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)) ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool
rt,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty forall a b. (a -> b) -> a -> b
$
(if Bool
bt then forall a. NonEmpty a -> [a]
NE.toList NonEmpty (RText 'PathPiece)
bps else forall a. NonEmpty a -> [a]
NE.init NonEmpty (RText 'PathPiece)
bps)
forall a. Semigroup a => a -> a -> a
<> forall a. NonEmpty a -> [a]
NE.toList NonEmpty (RText 'PathPiece)
rps,
uriQuery :: [QueryParam]
uriQuery =
if forall a b. Either a b -> Bool
isLeft (URI -> Either Bool Authority
uriAuthority URI
r)
Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing (URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath URI
r)
Bool -> Bool -> 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 (Bool
trailSlash, NonEmpty (RText 'PathPiece)
path) = forall {l :: RTextLabel}.
[RText l] -> [RText l] -> Bool -> Maybe (Bool, NonEmpty (RText l))
go [] (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 = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool
ts,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse) [RText l]
out
go [RText l]
out (RText l
x : [RText l]
xs) Bool
ts
| forall (l :: RTextLabel). RText l -> Text
unRText RText l
x 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RText l]
xs Bool -> Bool -> Bool
|| Bool
ts)
| forall (l :: RTextLabel). RText l -> Text
unRText RText l
x forall a. Eq a => a -> a -> Bool
== Text
".." = [RText l] -> [RText l] -> Bool -> Maybe (Bool, NonEmpty (RText l))
go (forall a. Int -> [a] -> [a]
drop Int
1 [RText l]
out) [RText l]
xs (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 forall a. a -> [a] -> [a]
: [RText l]
out) [RText l]
xs Bool
ts