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

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

import Control.Applicative ((<|>))
import Data.Attoparsec.ByteString.Char8 as A
import Data.Char as C
import Data.Bits (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
import qualified Data.ByteString.Char8 as B8

repack :: String -> T.Text
repack :: String -> Text
repack = ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> (String -> ByteString) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B8.pack

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

pAsciiAlphaNumeric :: Parser Char
pAsciiAlphaNumeric :: Parser Char
pAsciiAlphaNumeric = (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isAsciiAlphaNumeric

pSubDelim :: Parser Char
pSubDelim :: Parser Char
pSubDelim = (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isSubDelim

pUnreserved :: Parser Char
pUnreserved :: Parser Char
pUnreserved = (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isUnreserved

pSizedHexadecimal :: (Integral a, Bits a) => Int -> Parser a
pSizedHexadecimal :: Int -> Parser a
pSizedHexadecimal Int
n = do
    ByteString
bytes <- Int -> Parser ByteString
A.take Int
n
    if (Word8 -> Bool) -> ByteString -> Bool
B.all Word8 -> Bool
forall a. (Ord a, Num a) => a -> Bool
isHexDigit' ByteString
bytes then a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Parser a) -> a -> Parser a
forall a b. (a -> b) -> a -> b
$ (a -> Word8 -> a) -> a -> ByteString -> a
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
B.foldl' a -> Word8 -> a
forall a a. (Bits a, Integral a, Num a) => a -> a -> a
step a
0 (ByteString -> a) -> ByteString -> a
forall a b. (a -> b) -> a -> b
$ ByteString
bytes else String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"pSizedHexadecimal"
  where 
    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)
    step :: a -> a -> a
step a
a 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
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
4) a -> a -> a
forall a. Bits a => a -> a -> a
.|. a -> a
forall a b. (Integral a, Num b) => a -> b
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
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
4) a -> a -> a
forall a. Bits a => a -> a -> a
.|. a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
w a -> a -> a
forall a. Num a => a -> a -> a
- a
87)
             | Bool
otherwise           = (a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
4) a -> a -> a
forall a. Bits a => a -> a -> a
.|. a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
w a -> a -> a
forall a. Num a => a -> a -> a
- a
55)

pPercentEnc :: Parser Char
pPercentEnc :: Parser Char
pPercentEnc = do
  Char
_ <- Char -> Parser Char
char Char
'%'
  Int
hexdig1 <- Int -> Parser Int
forall a. (Integral a, Bits a) => Int -> Parser a
pSizedHexadecimal Int
1
  Int
hexdig2 <- Int -> Parser Int
forall a. (Integral a, Bits a) => Int -> Parser a
pSizedHexadecimal Int
1
  Char -> Parser Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Parser Char) -> (Int -> Char) -> Int -> Parser Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
chr (Int -> Parser Char) -> Int -> Parser Char
forall a b. (a -> b) -> a -> b
$ Int
hexdig1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hexdig2

pUsername :: Parser Username
pUsername :: Parser Username
pUsername = do
  String
xs <- Parser Char -> Parser ByteString String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many1' ((Char -> Bool) -> Parser Char
satisfy Char -> Bool
isUsernameChar Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char
pPercentEnc)
  Username -> Parser Username
forall (m :: * -> *) a. Monad m => a -> m a
return (Username -> Parser Username) -> Username -> Parser Username
forall a b. (a -> b) -> a -> b
$ Text -> Username
Username (String -> Text
repack String
xs)

pPassword :: Parser Password
pPassword :: Parser Password
pPassword = do
  String
xs <- Parser Char -> Parser ByteString String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many1' ((Char -> Bool) -> Parser Char
satisfy Char -> Bool
isPasswordChar Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char
pPercentEnc)
  Password -> Parser Password
forall (m :: * -> *) a. Monad m => a -> m a
return (Password -> Parser Password) -> Password -> Parser Password
forall a b. (a -> b) -> a -> b
$ Text -> Password
Password (String -> Text
repack String
xs)

pRegName :: Parser T.Text
pRegName :: Parser Text
pRegName = do
  String
xs <- Parser Char -> Parser ByteString String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many1' ((Char -> Bool) -> Parser Char
satisfy Char -> Bool
isRegNameChar Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char
pPercentEnc)
  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
repack (String -> Parser Text) -> String -> Parser Text
forall a b. (a -> b) -> a -> b
$ String
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
pIPv4 Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pRegName
  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

pUserInfo :: Parser UserInfo
pUserInfo :: Parser UserInfo
pUserInfo = do
  Username
username <- Parser Username
pUsername
  Maybe Password
password <- Parser Password -> Parser (Maybe Password)
forall a. Parser a -> Parser (Maybe a)
pMaybe (Char -> Parser Char
char Char
':' Parser Char -> Parser Password -> Parser Password
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Password
pPassword)
  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
$ UserInfo :: Username -> Maybe Password -> UserInfo
UserInfo { $sel:userInfoUsername:UserInfo :: Username
userInfoUsername = Username
username, $sel:userInfoPassword:UserInfo :: Maybe Password
userInfoPassword = Maybe Password
password }

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}

pPathChar :: Parser Char 
pPathChar :: Parser Char
pPathChar = (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isPathChar Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char
pPercentEnc

pPathCharNc :: Parser Char 
pPathCharNc :: Parser Char
pPathCharNc = (Char -> Bool) -> Parser Char
satisfy Char -> Bool
isPathCharNoColon Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char
pPercentEnc

pSegmentNz :: Parser PathSegment 
pSegmentNz :: Parser PathSegment
pSegmentNz = Text -> PathSegment
PathSegment (Text -> PathSegment) -> (String -> Text) -> String -> PathSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
repack (String -> PathSegment)
-> Parser ByteString String -> Parser PathSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char -> Parser ByteString String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many1' Parser Char
pPathChar

pSegmentNzNc :: Parser PathSegment 
pSegmentNzNc :: Parser PathSegment
pSegmentNzNc = Text -> PathSegment
PathSegment (Text -> PathSegment) -> (String -> Text) -> String -> PathSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
repack (String -> PathSegment)
-> Parser ByteString String -> Parser PathSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char -> Parser ByteString String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many1' Parser Char
pPathCharNc

pSegment :: Parser PathSegment
pSegment :: Parser PathSegment
pSegment = Text -> PathSegment
PathSegment (Text -> PathSegment) -> (String -> Text) -> String -> PathSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
repack (String -> PathSegment)
-> Parser ByteString String -> Parser PathSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char -> Parser ByteString String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser Char
pPathChar

pPathsAbEmpty :: Parser [PathSegment]
pPathsAbEmpty :: Parser [PathSegment]
pPathsAbEmpty = Parser PathSegment -> Parser [PathSegment]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many1' (Char -> Parser Char
char Char
'/' Parser Char -> Parser PathSegment -> Parser PathSegment
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser PathSegment
pSegment)

pPathsAbsolute :: Parser [PathSegment]
pPathsAbsolute :: Parser [PathSegment]
pPathsAbsolute = do
  Char
_ <- Char -> Parser Char
char Char
'/'
  PathSegment
seg <- Parser PathSegment
pSegmentNz
  [PathSegment]
comps <- Parser PathSegment -> Parser [PathSegment]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Char -> Parser Char
char Char
'/' Parser Char -> Parser PathSegment -> Parser PathSegment
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser PathSegment
pSegment)
  [PathSegment] -> Parser [PathSegment]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PathSegment] -> Parser [PathSegment])
-> [PathSegment] -> Parser [PathSegment]
forall a b. (a -> b) -> a -> b
$ PathSegment
seg PathSegment -> [PathSegment] -> [PathSegment]
forall a. a -> [a] -> [a]
: [PathSegment]
comps

pPathsNoScheme :: Parser [PathSegment]
pPathsNoScheme :: Parser [PathSegment]
pPathsNoScheme = do
  PathSegment
seg <- Parser PathSegment
pSegmentNzNc
  [PathSegment]
comps <- Parser PathSegment -> Parser [PathSegment]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Char -> Parser Char
char Char
'/' Parser Char -> Parser PathSegment -> Parser PathSegment
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser PathSegment
pSegment)
  [PathSegment] -> Parser [PathSegment]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PathSegment] -> Parser [PathSegment])
-> [PathSegment] -> Parser [PathSegment]
forall a b. (a -> b) -> a -> b
$ PathSegment
seg PathSegment -> [PathSegment] -> [PathSegment]
forall a. a -> [a] -> [a]
: [PathSegment]
comps

pPathsRootless :: Parser [PathSegment]
pPathsRootless :: Parser [PathSegment]
pPathsRootless = do
  PathSegment
seg <- Parser PathSegment
pSegmentNz
  [PathSegment]
comps <- Parser PathSegment -> Parser [PathSegment]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Char -> Parser Char
char Char
'/' Parser Char -> Parser PathSegment -> Parser PathSegment
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser PathSegment
pSegment)
  [PathSegment] -> Parser [PathSegment]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PathSegment] -> Parser [PathSegment])
-> [PathSegment] -> Parser [PathSegment]
forall a b. (a -> b) -> a -> b
$ PathSegment
seg PathSegment -> [PathSegment] -> [PathSegment]
forall a. a -> [a] -> [a]
: [PathSegment]
comps

pPathsEmpty :: Parser [PathSegment]
pPathsEmpty :: Parser [PathSegment]
pPathsEmpty = [PathSegment] -> Parser [PathSegment]
forall (m :: * -> *) a. Monad m => a -> m a
return []

pPathAbsAuth :: Parser (Path 'Absolute)
pPathAbsAuth :: Parser (Path 'Absolute)
pPathAbsAuth = ([PathSegment] -> Path 'Absolute)
-> Parser [PathSegment] -> Parser (Path 'Absolute)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PathSegment] -> Path 'Absolute
forall (ref :: UriReference). [PathSegment] -> Path ref
Path (Parser [PathSegment]
pPathsAbEmpty Parser [PathSegment]
-> Parser [PathSegment] -> Parser [PathSegment]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [PathSegment]
pPathsAbsolute Parser [PathSegment]
-> Parser [PathSegment] -> Parser [PathSegment]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [PathSegment]
pPathsEmpty)

pPathAbsNoAuth :: Parser (Path 'Absolute)
pPathAbsNoAuth :: Parser (Path 'Absolute)
pPathAbsNoAuth = ([PathSegment] -> Path 'Absolute)
-> Parser [PathSegment] -> Parser (Path 'Absolute)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PathSegment] -> Path 'Absolute
forall (ref :: UriReference). [PathSegment] -> Path ref
Path (Parser [PathSegment]
pPathsAbsolute Parser [PathSegment]
-> Parser [PathSegment] -> Parser [PathSegment]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [PathSegment]
pPathsRootless Parser [PathSegment]
-> Parser [PathSegment] -> Parser [PathSegment]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [PathSegment]
pPathsEmpty)

pPathRel :: Parser (Path 'Relative)
pPathRel :: Parser (Path 'Relative)
pPathRel = ([PathSegment] -> Path 'Relative)
-> Parser [PathSegment] -> Parser (Path 'Relative)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PathSegment] -> Path 'Relative
forall (ref :: UriReference). [PathSegment] -> Path ref
Path (Parser [PathSegment]
pPathsAbsolute Parser [PathSegment]
-> Parser [PathSegment] -> Parser [PathSegment]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [PathSegment]
pPathsNoScheme Parser [PathSegment]
-> Parser [PathSegment] -> Parser [PathSegment]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [PathSegment]
pPathsEmpty)

pQuery :: Parser Query
pQuery :: Parser Query
pQuery = do
  String
queryText <- (Char -> Parser Char
char Char
'?' Parser Char -> Parser ByteString String -> Parser ByteString String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser Char -> Parser ByteString String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many1' ((Char -> Bool) -> Parser Char
satisfy Char -> Bool
isQueryChar Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char
pPercentEnc)))
  ()
_ <- 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)
-> (String -> Query) -> String -> Parser Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Query
Query (Text -> Query) -> (String -> Text) -> String -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
repack (String -> Parser Query) -> String -> Parser Query
forall a b. (a -> b) -> a -> b
$ String
queryText

pFragment :: Parser Fragment
pFragment :: Parser Fragment
pFragment = do
  String
fragmentText <- (Char -> Parser Char
char Char
'#' Parser Char -> Parser ByteString String -> Parser ByteString String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser Char -> Parser ByteString String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many1' ((Char -> Bool) -> Parser Char
satisfy Char -> Bool
isFragmentChar Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char
pPercentEnc)))
  ()
_ <- 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)
-> (String -> Fragment) -> String -> Parser Fragment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Fragment
Fragment (Text -> Fragment) -> (String -> Text) -> String -> Fragment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
repack (String -> Parser Fragment) -> String -> Parser Fragment
forall a b. (a -> b) -> a -> b
$ String
fragmentText

pScheme :: Parser Scheme
pScheme :: Parser Scheme
pScheme = do
  Char
x <- Parser Char
pAsciiAlpha
  String
xs <- Parser Char -> Parser ByteString String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Parser Char
pAsciiAlphaNumeric Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
char Char
'+' Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
char Char
'.' Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
char Char
'-' )
  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) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
repack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
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 Uri
pRelativeUri :: Parser Uri
pRelativeUri = do
  Path 'Relative
path <- 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
  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
$ RelUri -> Uri
RelativeUri (RelUri -> Uri) -> RelUri -> Uri
forall a b. (a -> b) -> a -> b
$ RelUri :: Path 'Relative -> Maybe Query -> Maybe Fragment -> RelUri
RelUri { $sel:uriPath:RelUri :: Path 'Relative
uriPath = Path 'Relative
path, $sel:uriQuery:RelUri :: Maybe Query
uriQuery = Maybe Query
query, $sel:uriFragment:RelUri :: Maybe Fragment
uriFragment = Maybe Fragment
fragment }

pAbsoluteUri :: Parser Uri
pAbsoluteUri :: Parser Uri
pAbsoluteUri = 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)
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
$ AbsUri -> Uri
AbsoluteUri (AbsUri -> Uri) -> AbsUri -> Uri
forall a b. (a -> b) -> a -> b
$ AbsUri :: Scheme
-> Maybe Authority
-> Path 'Absolute
-> Maybe Query
-> Maybe Fragment
-> AbsUri
AbsUri {$sel:uriScheme:AbsUri :: Scheme
uriScheme = Scheme
scheme, $sel:uriAuthority:AbsUri :: Maybe Authority
uriAuthority = Maybe Authority
authority, $sel:uriPath:AbsUri :: Path 'Absolute
uriPath = Path 'Absolute
path, $sel:uriQuery:AbsUri :: Maybe Query
uriQuery = Maybe Query
query, $sel:uriFragment:AbsUri :: Maybe Fragment
uriFragment = Maybe Fragment
fragment }

pUri :: Parser Uri
pUri :: Parser Uri
pUri = Parser Uri
pAbsoluteUri Parser Uri -> Parser Uri -> Parser Uri
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Uri
pRelativeUri