{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE LambdaCase #-}

module Dormouse.Uri.Parser
  ( pUri
  , pUriRef
  , pRelativeUri
  , pScheme
  , pUserInfo
  , pIPv4
  , pRegName
  , pHost
  , pPort
  , pAuthority
  , pPathAbsAuth
  , pPathAbsNoAuth
  , pPathRel
  , pQuery
  , pFragment
  , percentDecode
  ) where

import Data.Word ( Word8 ) 
import Control.Applicative ((<|>))
import Data.Attoparsec.ByteString.Char8 as A
import qualified Data.Attoparsec.ByteString as AB
import qualified Data.ByteString.Internal as BS (c2w, w2c)
import Data.Bits (shiftL, (.|.))
import Data.Maybe (isJust)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Dormouse.Uri.Types
import Dormouse.Uri.RFC3986
import qualified Data.ByteString as B

pMaybe :: Parser a -> Parser (Maybe a)
pMaybe :: Parser a -> Parser (Maybe a)
pMaybe Parser a
p = Maybe a -> Parser (Maybe a) -> Parser (Maybe a)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Maybe a
forall a. Maybe a
Nothing (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Parser a -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p)

pAsciiAlpha :: Parser Char
pAsciiAlpha :: Parser Char
pAsciiAlpha = (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isAsciiAlpha

data PDState = Percent | Hex1 Word8 | Other | PDError

percentDecode :: B.ByteString -> Maybe B.ByteString
percentDecode :: ByteString -> Maybe ByteString
percentDecode ByteString
xs =
  if Word8 -> ByteString -> Bool
B.elem Word8
37 ByteString
xs then
    case ((ByteString, PDState) -> Word8 -> (ByteString, PDState))
-> (ByteString, PDState) -> ByteString -> (ByteString, PDState)
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
B.foldl' (ByteString, PDState) -> Word8 -> (ByteString, PDState)
f (ByteString
B.empty, PDState
Other) ByteString
xs of
      (ByteString
_, PDState
PDError)  -> Maybe ByteString
forall a. Maybe a
Nothing 
      (ByteString
bs, PDState
_)       -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs
  else 
    ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
xs
  where
    f :: (ByteString, PDState) -> Word8 -> (ByteString, PDState)
f (ByteString
es, PDState
Percent) Word8
e                                     = (ByteString
es, Word8 -> PDState
Hex1 Word8
e)
    f (ByteString
es, Hex1 Word8
e1) Word8
e2 | Word8 -> Bool
forall a. (Ord a, Num a) => a -> Bool
isHexDigit' Word8
e1 Bool -> Bool -> Bool
&& Word8 -> Bool
forall a. (Ord a, Num a) => a -> Bool
isHexDigit' Word8
e2 = (ByteString -> Word8 -> ByteString
B.snoc ByteString
es (Word8 -> Word8
forall a p. (Integral a, Num p) => a -> p
hexToWord8 Word8
e1 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
4 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8 -> Word8
forall a p. (Integral a, Num p) => a -> p
hexToWord8 Word8
e2), PDState
Other)
    f (ByteString
es, Hex1 Word8
_)  Word8
_                                     = (ByteString
es, PDState
PDError)
    f (ByteString
es, PDState
Other)   Word8
37                                    = (ByteString
es, PDState
Percent)
    f (ByteString
es, PDState
Other)   Word8
e                                     = (ByteString -> Word8 -> ByteString
B.snoc ByteString
es Word8
e, PDState
Other)
    f (ByteString
es, PDState
PDError) Word8
_                                     = (ByteString
es, PDState
PDError)
    hexToWord8 :: a -> p
hexToWord8 a
w | a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
48 Bool -> Bool -> Bool
&& a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
57 = a -> p
forall a p. (Integral a, Num p) => a -> p
fromIntegral (a
w a -> a -> a
forall a. Num a => a -> a -> a
- a
48)
                 | a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
97            = a -> p
forall a p. (Integral a, Num p) => a -> p
fromIntegral (a
w a -> a -> a
forall a. Num a => a -> a -> a
- a
87)
                 | Bool
otherwise          = a -> p
forall a p. (Integral a, Num p) => a -> p
fromIntegral (a
w a -> a -> a
forall a. Num a => a -> a -> a
- a
55)
    isHexDigit' :: a -> Bool
isHexDigit' a
w = (a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
48 Bool -> Bool -> Bool
&& a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
57) Bool -> Bool -> Bool
||  (a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
97 Bool -> Bool -> Bool
&& a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
102) Bool -> Bool -> Bool
||(a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
65 Bool -> Bool -> Bool
&& a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
70)

takeWhileW8 :: (Char -> Bool) -> Parser B.ByteString 
takeWhileW8 :: (Char -> Bool) -> Parser ByteString
takeWhileW8 Char -> Bool
f = (Word8 -> Bool) -> Parser ByteString
AB.takeWhile (Char -> Bool
f (Char -> Bool) -> (Word8 -> Char) -> Word8 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
BS.w2c)

takeWhile1W8 :: (Char -> Bool) -> Parser B.ByteString 
takeWhile1W8 :: (Char -> Bool) -> Parser ByteString
takeWhile1W8 Char -> Bool
f = (Word8 -> Bool) -> Parser ByteString
AB.takeWhile1 (Char -> Bool
f (Char -> Bool) -> (Word8 -> Char) -> Word8 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
BS.w2c)

pUserInfo :: Parser UserInfo
pUserInfo :: Parser UserInfo
pUserInfo = do
  ByteString
xs <- (Char -> Bool) -> Parser ByteString
takeWhileW8 (\Char
x -> Char -> Bool
isUserInfoChar Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%')
  ByteString
xs' <- Parser ByteString
-> (ByteString -> Parser ByteString)
-> Maybe ByteString
-> Parser ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to percent-decode") ByteString -> Parser ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> Parser ByteString)
-> Maybe ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
percentDecode ByteString
xs
  Char
_ <- Char -> Parser Char
char Char
'@'
  UserInfo -> Parser UserInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (UserInfo -> Parser UserInfo) -> UserInfo -> Parser UserInfo
forall a b. (a -> b) -> a -> b
$ Text -> UserInfo
UserInfo (ByteString -> Text
TE.decodeUtf8 ByteString
xs')

pRegName :: Parser T.Text
pRegName :: Parser Text
pRegName = do
  ByteString
xs <- (Char -> Bool) -> Parser ByteString
takeWhileW8 (\Char
x -> Char -> Bool
isRegNameChar Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%')
  ByteString
xs' <- Parser ByteString
-> (ByteString -> Parser ByteString)
-> Maybe ByteString
-> Parser ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to percent-decode") ByteString -> Parser ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> Parser ByteString)
-> Maybe ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
percentDecode ByteString
xs
  Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text)
-> (ByteString -> Text) -> ByteString -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 (ByteString -> Parser Text) -> ByteString -> Parser Text
forall a b. (a -> b) -> a -> b
$ ByteString
xs'

pIPv4 :: Parser T.Text
pIPv4 :: Parser Text
pIPv4 = do
  Int
oct1 <- Parser Int
pOctet
  Char
_ <- Char -> Parser Char
char Char
'.'
  Int
oct2 <- Parser Int
pOctet
  Char
_ <- Char -> Parser Char
char Char
'.'
  Int
oct3 <- Parser Int
pOctet
  Char
_ <- Char -> Parser Char
char Char
'.'
  Int
oct4 <- Parser Int
pOctet
  Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> (String -> Text) -> String -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Parser Text) -> String -> Parser Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
oct1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
oct2 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
oct3 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
oct4
  where
    pOctet :: Parser Int
    pOctet :: Parser Int
pOctet = Parser Int
forall a. Integral a => Parser a
decimal Parser Int -> (Int -> Parser Int) -> Parser Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
255 -> String -> Parser Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"IPv4 Octects must be in range 0-255"
      Int
i           -> Int -> Parser Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i

pHost :: Parser Host
pHost :: Parser Host
pHost = do
  Text
hostText <- Parser Text
pRegName Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pIPv4
  Host -> Parser Host
forall (m :: * -> *) a. Monad m => a -> m a
return (Host -> Parser Host) -> (Text -> Host) -> Text -> Parser Host
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Host
Host  (Text -> Parser Host) -> Text -> Parser Host
forall a b. (a -> b) -> a -> b
$ Text
hostText

pPort :: Parser Int
pPort :: Parser Int
pPort = 
  (Char -> Parser Char
char Char
':' Parser Char -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
forall a. Integral a => Parser a
decimal) Parser Int -> (Int -> Parser Int) -> Parser Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
65535 -> String -> Parser Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Port must be in the range 0-65535"
    Int
i             -> Int -> Parser Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i

pAuthority :: Parser Authority
pAuthority :: Parser Authority
pAuthority = do
  ByteString
_ <- ByteString -> Parser ByteString
string ByteString
"//"
  Maybe UserInfo
authUserInfo <- Parser UserInfo -> Parser (Maybe UserInfo)
forall a. Parser a -> Parser (Maybe a)
pMaybe Parser UserInfo
pUserInfo
  Host
authHost <- Parser Host
pHost
  Maybe Int
authPort <- Parser Int -> Parser (Maybe Int)
forall a. Parser a -> Parser (Maybe a)
pMaybe Parser Int
pPort
  ()
_ <- Parser (Maybe Char)
peekChar Parser (Maybe Char)
-> (Maybe Char -> Parser ByteString ()) -> Parser ByteString ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Char
Nothing                                   -> () -> Parser ByteString ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Char
c | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#' -> () -> Parser ByteString ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe Char
_                                         -> String -> Parser ByteString ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid authority termination character, must be /, ?, # or end of input"
  Authority -> Parser Authority
forall (m :: * -> *) a. Monad m => a -> m a
return Authority :: Maybe UserInfo -> Host -> Maybe Int -> Authority
Authority { $sel:authorityUserInfo:Authority :: Maybe UserInfo
authorityUserInfo = Maybe UserInfo
authUserInfo, $sel:authorityHost:Authority :: Host
authorityHost = Host
authHost, $sel:authorityPort:Authority :: Maybe Int
authorityPort = Maybe Int
authPort}

pPathAbsAuth :: Parser (Path rt)
pPathAbsAuth :: Parser (Path rt)
pPathAbsAuth = do
  ByteString
p <- (Char -> Bool) -> Parser ByteString
takeWhileW8 (\Char
x -> Char -> Bool
isPathChar Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')
  ByteString
p' <- Parser ByteString
-> (ByteString -> Parser ByteString)
-> Maybe ByteString
-> Parser ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to percent-decode") ByteString -> Parser ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> Parser ByteString)
-> Maybe ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
percentDecode ByteString
p
  let ps :: [PathSegment]
ps = Text -> PathSegment
PathSegment (Text -> PathSegment) -> [Text] -> [PathSegment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (ByteString -> Text
TE.decodeUtf8 ByteString
p')
  case [PathSegment]
ps of -- begins with "/" is empty
    (PathSegment Text
x):[PathSegment]
xs | Text -> Bool
T.null Text
x -> Path rt -> Parser (Path rt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path rt -> Parser (Path rt)) -> Path rt -> Parser (Path rt)
forall a b. (a -> b) -> a -> b
$ [PathSegment] -> Path rt
forall (ref :: UriReferenceType). [PathSegment] -> Path ref
Path [PathSegment]
xs
    (PathSegment Text
_):[PathSegment]
_             -> String -> Parser (Path rt)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"must begin with /"
    [PathSegment]
xs                            -> Path rt -> Parser (Path rt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path rt -> Parser (Path rt)) -> Path rt -> Parser (Path rt)
forall a b. (a -> b) -> a -> b
$ [PathSegment] -> Path rt
forall (ref :: UriReferenceType). [PathSegment] -> Path ref
Path [PathSegment]
xs

pPathAbsNoAuth :: Parser (Path 'Absolute)
pPathAbsNoAuth :: Parser (Path 'Absolute)
pPathAbsNoAuth = do
  ByteString
p <- (Char -> Bool) -> Parser ByteString
takeWhileW8 (\Char
x -> Char -> Bool
isPathChar Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')
  ByteString
p' <- Parser ByteString
-> (ByteString -> Parser ByteString)
-> Maybe ByteString
-> Parser ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to percent-decode") ByteString -> Parser ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> Parser ByteString)
-> Maybe ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
percentDecode ByteString
p
  let ps :: [PathSegment]
ps = Text -> PathSegment
PathSegment (Text -> PathSegment) -> [Text] -> [PathSegment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (ByteString -> Text
TE.decodeUtf8 ByteString
p')
  case [PathSegment]
ps of -- begins with "/" but not "//" OR begins with segment OR empty
    (PathSegment Text
x1):(PathSegment Text
x2):[PathSegment]
_ | Text -> Bool
T.null Text
x1 Bool -> Bool -> Bool
&& Text -> Bool
T.null Text
x2 -> String -> Parser (Path 'Absolute)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"cannot begin with //"
    (PathSegment Text
x):[PathSegment]
xs                  | Text -> Bool
T.null Text
x               -> Path 'Absolute -> Parser (Path 'Absolute)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path 'Absolute -> Parser (Path 'Absolute))
-> Path 'Absolute -> Parser (Path 'Absolute)
forall a b. (a -> b) -> a -> b
$ [PathSegment] -> Path 'Absolute
forall (ref :: UriReferenceType). [PathSegment] -> Path ref
Path [PathSegment]
xs
    [PathSegment]
xs                                                           -> Path 'Absolute -> Parser (Path 'Absolute)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path 'Absolute -> Parser (Path 'Absolute))
-> Path 'Absolute -> Parser (Path 'Absolute)
forall a b. (a -> b) -> a -> b
$ [PathSegment] -> Path 'Absolute
forall (ref :: UriReferenceType). [PathSegment] -> Path ref
Path [PathSegment]
xs

pPathRel :: Parser (Path 'Relative)
pPathRel :: Parser (Path 'Relative)
pPathRel = do
  ByteString
p <- (Char -> Bool) -> Parser ByteString
takeWhileW8 (\Char
x -> Char -> Bool
isPathChar Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')
  ByteString
p' <- Parser ByteString
-> (ByteString -> Parser ByteString)
-> Maybe ByteString
-> Parser ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to percent-decode") ByteString -> Parser ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> Parser ByteString)
-> Maybe ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
percentDecode ByteString
p
  let ps :: [PathSegment]
ps = Text -> PathSegment
PathSegment (Text -> PathSegment) -> [Text] -> [PathSegment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (ByteString -> Text
TE.decodeUtf8 ByteString
p')
  case [PathSegment]
ps of
    (PathSegment Text
x1):(PathSegment Text
x2):[PathSegment]
_ | Text -> Bool
T.null Text
x1 Bool -> Bool -> Bool
&& Text -> Bool
T.null Text
x2 -> String -> Parser (Path 'Relative)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"cannot begin with //"
    (PathSegment Text
x):[PathSegment]
_                   | Text -> Text -> Bool
T.isPrefixOf Text
":" Text
x     -> String -> Parser (Path 'Relative)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"first character of a relative path cannot be :"
    (PathSegment Text
x):[PathSegment]
xs                  | Text -> Bool
T.null Text
x               -> Path 'Relative -> Parser (Path 'Relative)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path 'Relative -> Parser (Path 'Relative))
-> Path 'Relative -> Parser (Path 'Relative)
forall a b. (a -> b) -> a -> b
$ [PathSegment] -> Path 'Relative
forall (ref :: UriReferenceType). [PathSegment] -> Path ref
Path [PathSegment]
xs
    [PathSegment]
xs                                                           -> Path 'Relative -> Parser (Path 'Relative)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path 'Relative -> Parser (Path 'Relative))
-> Path 'Relative -> Parser (Path 'Relative)
forall a b. (a -> b) -> a -> b
$ [PathSegment] -> Path 'Relative
forall (ref :: UriReferenceType). [PathSegment] -> Path ref
Path [PathSegment]
xs

pQuery :: Parser Query
pQuery :: Parser Query
pQuery = do
  ByteString
qt <- Char -> Parser Char
char Char
'?' Parser Char -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString
takeWhile1W8 (\Char
x -> Char -> Bool
isQueryChar Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%')
  ByteString
queryText <- Parser ByteString
-> (ByteString -> Parser ByteString)
-> Maybe ByteString
-> Parser ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to percent-decode") ByteString -> Parser ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> Parser ByteString)
-> Maybe ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
percentDecode ByteString
qt
  ()
_ <- Parser (Maybe Char)
peekChar Parser (Maybe Char)
-> (Maybe Char -> Parser ByteString ()) -> Parser ByteString ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Char
Nothing           -> () -> Parser ByteString ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Char
c | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#' -> () -> Parser ByteString ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe Char
c                 -> String -> Parser ByteString ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString ()) -> String -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid query termination character: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Char -> String
forall a. Show a => a -> String
show Maybe Char
c String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", must be # or end of input"
  Query -> Parser Query
forall (m :: * -> *) a. Monad m => a -> m a
return (Query -> Parser Query)
-> (ByteString -> Query) -> ByteString -> Parser Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Query
Query (Text -> Query) -> (ByteString -> Text) -> ByteString -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 (ByteString -> Parser Query) -> ByteString -> Parser Query
forall a b. (a -> b) -> a -> b
$ ByteString
queryText

pFragment :: Parser Fragment
pFragment :: Parser Fragment
pFragment = do
  ByteString
ft <- Char -> Parser Char
char Char
'#' Parser Char -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser ByteString
takeWhile1W8 (\Char
x -> Char -> Bool
isFragmentChar Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%')
  ByteString
fragmentText <- Parser ByteString
-> (ByteString -> Parser ByteString)
-> Maybe ByteString
-> Parser ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to percent-decode") ByteString -> Parser ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> Parser ByteString)
-> Maybe ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
percentDecode ByteString
ft
  ()
_ <- Parser (Maybe Char)
peekChar Parser (Maybe Char)
-> (Maybe Char -> Parser ByteString ()) -> Parser ByteString ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Char
Nothing           -> () -> Parser ByteString ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe Char
c                 -> String -> Parser ByteString ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString ()) -> String -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid fragment termination character: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Char -> String
forall a. Show a => a -> String
show Maybe Char
c String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", must be end of input"
  Fragment -> Parser Fragment
forall (m :: * -> *) a. Monad m => a -> m a
return (Fragment -> Parser Fragment)
-> (ByteString -> Fragment) -> ByteString -> Parser Fragment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Fragment
Fragment (Text -> Fragment)
-> (ByteString -> Text) -> ByteString -> Fragment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 (ByteString -> Parser Fragment) -> ByteString -> Parser Fragment
forall a b. (a -> b) -> a -> b
$ ByteString
fragmentText

pScheme :: Parser Scheme
pScheme :: Parser Scheme
pScheme = do
  Char
x <- Parser Char
pAsciiAlpha
  ByteString
xs <- (Char -> Bool) -> Parser ByteString
A.takeWhile Char -> Bool
isSchemeChar
  Char
_ <- Char -> Parser Char
char Char
':'
  Scheme -> Parser Scheme
forall (m :: * -> *) a. Monad m => a -> m a
return (Scheme -> Parser Scheme) -> Scheme -> Parser Scheme
forall a b. (a -> b) -> a -> b
$ Text -> Scheme
Scheme (Text -> Text
T.toLower (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString -> ByteString
B.cons (Char -> Word8
BS.c2w Char
x) ByteString
xs)

pAbsolutePart :: Parser (Scheme, Maybe Authority)
pAbsolutePart :: Parser (Scheme, Maybe Authority)
pAbsolutePart = do
  Scheme
scheme <- Parser Scheme
pScheme
  Maybe Authority
authority <- Parser Authority -> Parser (Maybe Authority)
forall a. Parser a -> Parser (Maybe a)
pMaybe Parser Authority
pAuthority
  (Scheme, Maybe Authority) -> Parser (Scheme, Maybe Authority)
forall (m :: * -> *) a. Monad m => a -> m a
return (Scheme
scheme, Maybe Authority
authority)

pRelativeUri :: Parser RelRef
pRelativeUri :: Parser RelRef
pRelativeUri = do
  Maybe Authority
authority <- Parser Authority -> Parser (Maybe Authority)
forall a. Parser a -> Parser (Maybe a)
pMaybe Parser Authority
pAuthority
  Path 'Relative
path <- if Maybe Authority -> Bool
forall a. Maybe a -> Bool
isJust Maybe Authority
authority then Parser (Path 'Relative)
forall (rt :: UriReferenceType). Parser (Path rt)
pPathAbsAuth else Parser (Path 'Relative)
pPathRel
  Maybe Query
query <- Parser Query -> Parser (Maybe Query)
forall a. Parser a -> Parser (Maybe a)
pMaybe Parser Query
pQuery
  Maybe Fragment
fragment <- Parser Fragment -> Parser (Maybe Fragment)
forall a. Parser a -> Parser (Maybe a)
pMaybe Parser Fragment
pFragment
  ()
_ <- Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput
  RelRef -> Parser RelRef
forall (m :: * -> *) a. Monad m => a -> m a
return  (RelRef -> Parser RelRef) -> RelRef -> Parser RelRef
forall a b. (a -> b) -> a -> b
$ RelRef :: Maybe Authority
-> Path 'Relative -> Maybe Query -> Maybe Fragment -> RelRef
RelRef { $sel:relRefAuthority:RelRef :: Maybe Authority
relRefAuthority = Maybe Authority
authority, $sel:relRefPath:RelRef :: Path 'Relative
relRefPath = Path 'Relative
path, $sel:relRefQuery:RelRef :: Maybe Query
relRefQuery = Maybe Query
query, $sel:relRefFragment:RelRef :: Maybe Fragment
relRefFragment = Maybe Fragment
fragment }

pUri :: Parser Uri
pUri :: Parser Uri
pUri = do
  (Scheme
scheme, Maybe Authority
authority) <- Parser (Scheme, Maybe Authority)
pAbsolutePart
  Path 'Absolute
path <- if Maybe Authority -> Bool
forall a. Maybe a -> Bool
isJust Maybe Authority
authority then Parser (Path 'Absolute)
forall (rt :: UriReferenceType). Parser (Path rt)
pPathAbsAuth else Parser (Path 'Absolute)
pPathAbsNoAuth
  Maybe Query
query <- Parser Query -> Parser (Maybe Query)
forall a. Parser a -> Parser (Maybe a)
pMaybe Parser Query
pQuery
  Maybe Fragment
fragment <- Parser Fragment -> Parser (Maybe Fragment)
forall a. Parser a -> Parser (Maybe a)
pMaybe Parser Fragment
pFragment
  ()
_ <- Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput
  Uri -> Parser Uri
forall (m :: * -> *) a. Monad m => a -> m a
return (Uri -> Parser Uri) -> Uri -> Parser Uri
forall a b. (a -> b) -> a -> b
$ Uri :: Scheme
-> Maybe Authority
-> Path 'Absolute
-> Maybe Query
-> Maybe Fragment
-> Uri
Uri {$sel:uriScheme:Uri :: Scheme
uriScheme = Scheme
scheme, $sel:uriAuthority:Uri :: Maybe Authority
uriAuthority = Maybe Authority
authority, $sel:uriPath:Uri :: Path 'Absolute
uriPath = Path 'Absolute
path, $sel:uriQuery:Uri :: Maybe Query
uriQuery = Maybe Query
query, $sel:uriFragment:Uri :: Maybe Fragment
uriFragment = Maybe Fragment
fragment }

pUriRef :: Parser UriReference
pUriRef :: Parser UriReference
pUriRef = (Uri -> UriReference
AbsoluteUri (Uri -> UriReference) -> Parser Uri -> Parser UriReference
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Uri
pUri) Parser UriReference -> Parser UriReference -> Parser UriReference
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (RelRef -> UriReference
RelativeRef (RelRef -> UriReference) -> Parser RelRef -> Parser UriReference
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser RelRef
pRelativeUri)