{-# 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 = 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 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 = uriPath r >>= removeDotSegments}
else
URI
r
{ uriScheme = Just bscheme,
uriAuthority = case uriAuthority 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 =
(>>= removeDotSegments) $
if isPathAbsolute r
then uriPath r
else case (uriPath base, uriPath 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 a b. (a -> b) -> Maybe a -> Maybe b
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 =
if isLeft (uriAuthority r)
&& isNothing (uriPath r)
&& null (uriQuery r)
then uriQuery base
else uriQuery 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) = [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 a b. (a -> b) -> Maybe a -> Maybe b
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 a. [a] -> 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 a. [a] -> 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