#if __GLASGOW_HASKELL__ < 800
{-# LANGUAGE RecordWildCards #-}
#endif
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE DeriveLift, StandaloneDeriving #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
#if MIN_VERSION_template_haskell(2,12,0) && MIN_VERSION_parsec(3,1,13)
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif

--------------------------------------------------------------------------------
-- |
--  Module      :  Network.URI
--  Copyright   :  (c) 2004, Graham Klyne
--  License     :  BSD-style (see end of this file)
--
--  Maintainer  :  Graham Klyne <gk@ninebynine.org>
--  Stability   :  provisional
--  Portability :  portable
--
--  This module defines functions for handling URIs.  It presents
--  substantially the same interface as the older GHC Network.URI module, but
--  is implemented using Parsec rather than a Regex library that is not
--  available with Hugs.  The internal representation of URI has been changed
--  so that URI strings are more completely preserved when round-tripping to a
--  URI value and back.
--
--  In addition, four methods are provided for parsing different
--  kinds of URI string (as noted in RFC3986):
--      'parseURI',
--      'parseURIReference',
--      'parseRelativeReference' and
--      'parseAbsoluteURI'.
--
--  Further, four methods are provided for classifying different
--  kinds of URI string (as noted in RFC3986):
--      'isURI',
--      'isURIReference',
--      'isRelativeReference' and
--      'isAbsoluteURI'.
--
--  The long-standing official reference for URI handling was RFC2396 [1],
--  as updated by RFC 2732 [2], but this was replaced by a new specification,
--  RFC3986 [3] in January 2005.  This latter specification has been used
--  as the primary reference for constructing the URI parser implemented
--  here, and it is intended that there is a direct relationship between
--  the syntax definition in that document and this parser implementation.
--
--  RFC 1808 [4] contains a number of test cases for relative URI handling.
--  Dan Connolly's Python module @uripath.py@ [5] also contains useful details
--  and test cases.
--
--  Some of the code has been copied from the previous GHC implementation,
--  but the parser is replaced with one that performs more complete
--  syntax checking of the URI itself, according to RFC3986 [3].
--
--  References
--
--  (1) <http://www.ietf.org/rfc/rfc2396.txt>
--
--  (2) <http://www.ietf.org/rfc/rfc2732.txt>
--
--  (3) <http://www.ietf.org/rfc/rfc3986.txt>
--
--  (4) <http://www.ietf.org/rfc/rfc1808.txt>
--
--  (5) <http://www.w3.org/2000/10/swap/uripath.py>
--
--------------------------------------------------------------------------------

module Network.URI
    (
    -- * The URI type
      URI(..)
    , URIAuth(..)
    , nullURI
    , nullURIAuth

    , rectify, rectifyAuth

    -- * Parsing
    , parseURI
    , parseURIReference
    , parseRelativeReference
    , parseAbsoluteURI

    -- * Test for strings containing various kinds of URI
    , isURI
    , isURIReference
    , isRelativeReference
    , isAbsoluteURI
    , isIPv6address
    , isIPv4address

    -- * Predicates
    , uriIsAbsolute
    , uriIsRelative

    -- * Relative URIs
    , relativeTo
    , nonStrictRelativeTo
    , relativeFrom

    -- * Operations on URI strings
    -- | Support for putting strings into URI-friendly
    --   escaped format and getting them back again.
    --   This can't be done transparently in all cases, because certain
    --   characters have different meanings in different kinds of URI.
    --   The URI spec [3], section 2.4, indicates that all URI components
    --   should be escaped before they are assembled as a URI:
    --   \"Once produced, a URI is always in its percent-encoded form\"
    , uriToString, uriAuthToString
    , isReserved, isUnreserved
    , isAllowedInURI, isUnescapedInURI
    , isUnescapedInURIComponent
    , escapeURIChar
    , escapeURIString
    , unEscapeString
    , pathSegments

    -- * URI Normalization functions
    , normalizeCase
    , normalizeEscape
    , normalizePathSegments

    -- * Deprecated functions
    , parseabsoluteURI
    , escapeString
    , reserved, unreserved
    , scheme, authority, path, query, fragment
    ) where

import Text.ParserCombinators.Parsec
    ( GenParser, ParseError
    , parse, (<?>), try
    , option, many1, count, notFollowedBy
    , char, satisfy, oneOf, string, eof
    , unexpected
    )

import Control.Applicative
import Control.Monad (MonadPlus(..))
import Control.DeepSeq (NFData(rnf), deepseq)
import Data.Char (ord, chr, isHexDigit, toLower, toUpper, digitToInt)
import Data.Bits ((.|.),(.&.),shiftL,shiftR)
import Data.List (unfoldr, isPrefixOf, isSuffixOf)
import Numeric (showIntAtBase)

import Language.Haskell.TH.Syntax (Lift(..))

#if !MIN_VERSION_base(4,8,0)
import Data.Traversable (sequenceA)
#endif

import Data.Typeable (Typeable)
#if MIN_VERSION_base(4,0,0)
import Data.Data (Data)
#else
import Data.Generics (Data)
#endif

#if __GLASGOW_HASKELL__ >= 702
import GHC.Generics (Generic)
#endif

------------------------------------------------------------
--  The URI datatype
------------------------------------------------------------

-- |Represents a general universal resource identifier using
--  its component parts.
--
--  For example, for the URI
--
--  >   foo://anonymous@www.haskell.org:42/ghc?query#frag
--
--  the components are:
--
data URI = URI
    { URI -> [Char]
uriScheme     :: String           -- ^ @foo:@
    , URI -> Maybe URIAuth
uriAuthority  :: Maybe URIAuth    -- ^ @\/\/anonymous\@www.haskell.org:42@
    , URI -> [Char]
uriPath       :: String           -- ^ @\/ghc@
    , URI -> [Char]
uriQuery      :: String           -- ^ @?query@
    , URI -> [Char]
uriFragment   :: String           -- ^ @#frag@
#if __GLASGOW_HASKELL__ >= 702
    } deriving (URI -> URI -> Bool
(URI -> URI -> Bool) -> (URI -> URI -> Bool) -> Eq URI
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: URI -> URI -> Bool
== :: URI -> URI -> Bool
$c/= :: URI -> URI -> Bool
/= :: URI -> URI -> Bool
Eq, Eq URI
Eq URI =>
(URI -> URI -> Ordering)
-> (URI -> URI -> Bool)
-> (URI -> URI -> Bool)
-> (URI -> URI -> Bool)
-> (URI -> URI -> Bool)
-> (URI -> URI -> URI)
-> (URI -> URI -> URI)
-> Ord URI
URI -> URI -> Bool
URI -> URI -> Ordering
URI -> URI -> URI
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: URI -> URI -> Ordering
compare :: URI -> URI -> Ordering
$c< :: URI -> URI -> Bool
< :: URI -> URI -> Bool
$c<= :: URI -> URI -> Bool
<= :: URI -> URI -> Bool
$c> :: URI -> URI -> Bool
> :: URI -> URI -> Bool
$c>= :: URI -> URI -> Bool
>= :: URI -> URI -> Bool
$cmax :: URI -> URI -> URI
max :: URI -> URI -> URI
$cmin :: URI -> URI -> URI
min :: URI -> URI -> URI
Ord, Typeable, Typeable URI
Typeable URI =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> URI -> c URI)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c URI)
-> (URI -> Constr)
-> (URI -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c URI))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c URI))
-> ((forall b. Data b => b -> b) -> URI -> URI)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> URI -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> URI -> r)
-> (forall u. (forall d. Data d => d -> u) -> URI -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> URI -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> URI -> m URI)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> URI -> m URI)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> URI -> m URI)
-> Data URI
URI -> Constr
URI -> DataType
(forall b. Data b => b -> b) -> URI -> URI
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> URI -> u
forall u. (forall d. Data d => d -> u) -> URI -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> URI -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> URI -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> URI -> m URI
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> URI -> m URI
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c URI
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> URI -> c URI
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c URI)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c URI)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> URI -> c URI
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> URI -> c URI
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c URI
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c URI
$ctoConstr :: URI -> Constr
toConstr :: URI -> Constr
$cdataTypeOf :: URI -> DataType
dataTypeOf :: URI -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c URI)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c URI)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c URI)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c URI)
$cgmapT :: (forall b. Data b => b -> b) -> URI -> URI
gmapT :: (forall b. Data b => b -> b) -> URI -> URI
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> URI -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> URI -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> URI -> r
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> URI -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> URI -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> URI -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> URI -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> URI -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> URI -> m URI
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> URI -> m URI
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> URI -> m URI
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> URI -> m URI
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> URI -> m URI
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> URI -> m URI
Data, (forall x. URI -> Rep URI x)
-> (forall x. Rep URI x -> URI) -> Generic URI
forall x. Rep URI x -> URI
forall x. URI -> Rep URI x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. URI -> Rep URI x
from :: forall x. URI -> Rep URI x
$cto :: forall x. Rep URI x -> URI
to :: forall x. Rep URI x -> URI
Generic)
#else
    } deriving (Eq, Ord, Typeable, Data)
#endif

-- | Add a prefix to a string, unless it already has it.
ensurePrefix :: String -> String -> String
ensurePrefix :: [Char] -> [Char] -> [Char]
ensurePrefix [Char]
p [Char]
s = if [Char]
p [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
s then [Char]
s else [Char]
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s

-- | Add a suffix to a string, unless it already has it.
ensureSuffix :: String -> String -> String
ensureSuffix :: [Char] -> [Char] -> [Char]
ensureSuffix [Char]
p [Char]
s = if [Char]
p [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
s then [Char]
s else [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
p

-- | Given a URIAuth in "nonstandard" form (lacking required separator characters),
-- return one that is standard.
rectifyAuth :: URIAuth -> URIAuth
rectifyAuth :: URIAuth -> URIAuth
rectifyAuth URIAuth
a = URIAuth {
  uriUserInfo :: [Char]
uriUserInfo = ([Char] -> [Char]) -> [Char] -> [Char]
forall a. ([a] -> [a]) -> [a] -> [a]
unlessEmpty ([Char] -> [Char] -> [Char]
ensureSuffix [Char]
"@") (URIAuth -> [Char]
uriUserInfo URIAuth
a),
  uriRegName :: [Char]
uriRegName = URIAuth -> [Char]
uriRegName URIAuth
a,
  uriPort :: [Char]
uriPort = ([Char] -> [Char]) -> [Char] -> [Char]
forall a. ([a] -> [a]) -> [a] -> [a]
unlessEmpty ([Char] -> [Char] -> [Char]
ensurePrefix [Char]
":") (URIAuth -> [Char]
uriPort URIAuth
a)
  }

-- | Given a URI in "nonstandard" form (lacking required separator characters),
-- return one that is standard.
rectify :: URI -> URI
rectify :: URI -> URI
rectify URI
u = URI {
  uriScheme :: [Char]
uriScheme = [Char] -> [Char] -> [Char]
ensureSuffix [Char]
":" (URI -> [Char]
uriScheme URI
u),
  uriAuthority :: Maybe URIAuth
uriAuthority = (URIAuth -> URIAuth) -> Maybe URIAuth -> Maybe URIAuth
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap URIAuth -> URIAuth
rectifyAuth (URI -> Maybe URIAuth
uriAuthority URI
u),
  uriPath :: [Char]
uriPath = URI -> [Char]
uriPath URI
u,
  uriQuery :: [Char]
uriQuery = ([Char] -> [Char]) -> [Char] -> [Char]
forall a. ([a] -> [a]) -> [a] -> [a]
unlessEmpty ([Char] -> [Char] -> [Char]
ensurePrefix [Char]
"?") (URI -> [Char]
uriQuery URI
u),
  uriFragment :: [Char]
uriFragment = ([Char] -> [Char]) -> [Char] -> [Char]
forall a. ([a] -> [a]) -> [a] -> [a]
unlessEmpty ([Char] -> [Char] -> [Char]
ensurePrefix [Char]
"#") (URI -> [Char]
uriFragment URI
u)
  }

-- | Apply the function to the list, unless that list is empty, in
-- which case leave it alone.
unlessEmpty :: ([a] -> [a]) -> [a] -> [a]
unlessEmpty :: forall a. ([a] -> [a]) -> [a] -> [a]
unlessEmpty [a] -> [a]
_f [] = []
unlessEmpty  [a] -> [a]
f  [a]
x = [a] -> [a]
f [a]
x

instance NFData URI where
    rnf :: URI -> ()
rnf (URI [Char]
s Maybe URIAuth
a [Char]
p [Char]
q [Char]
f)
        = [Char]
s [Char] -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` Maybe URIAuth
a Maybe URIAuth -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` [Char]
p [Char] -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` [Char]
q [Char] -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` [Char]
f [Char] -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ()

-- |Type for authority value within a URI
data URIAuth = URIAuth
    { URIAuth -> [Char]
uriUserInfo   :: String           -- ^ @anonymous\@@
    , URIAuth -> [Char]
uriRegName    :: String           -- ^ @www.haskell.org@
    , URIAuth -> [Char]
uriPort       :: String           -- ^ @:42@
#if __GLASGOW_HASKELL__ >= 702
    } deriving (URIAuth -> URIAuth -> Bool
(URIAuth -> URIAuth -> Bool)
-> (URIAuth -> URIAuth -> Bool) -> Eq URIAuth
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: URIAuth -> URIAuth -> Bool
== :: URIAuth -> URIAuth -> Bool
$c/= :: URIAuth -> URIAuth -> Bool
/= :: URIAuth -> URIAuth -> Bool
Eq, Eq URIAuth
Eq URIAuth =>
(URIAuth -> URIAuth -> Ordering)
-> (URIAuth -> URIAuth -> Bool)
-> (URIAuth -> URIAuth -> Bool)
-> (URIAuth -> URIAuth -> Bool)
-> (URIAuth -> URIAuth -> Bool)
-> (URIAuth -> URIAuth -> URIAuth)
-> (URIAuth -> URIAuth -> URIAuth)
-> Ord URIAuth
URIAuth -> URIAuth -> Bool
URIAuth -> URIAuth -> Ordering
URIAuth -> URIAuth -> URIAuth
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: URIAuth -> URIAuth -> Ordering
compare :: URIAuth -> URIAuth -> Ordering
$c< :: URIAuth -> URIAuth -> Bool
< :: URIAuth -> URIAuth -> Bool
$c<= :: URIAuth -> URIAuth -> Bool
<= :: URIAuth -> URIAuth -> Bool
$c> :: URIAuth -> URIAuth -> Bool
> :: URIAuth -> URIAuth -> Bool
$c>= :: URIAuth -> URIAuth -> Bool
>= :: URIAuth -> URIAuth -> Bool
$cmax :: URIAuth -> URIAuth -> URIAuth
max :: URIAuth -> URIAuth -> URIAuth
$cmin :: URIAuth -> URIAuth -> URIAuth
min :: URIAuth -> URIAuth -> URIAuth
Ord, Int -> URIAuth -> [Char] -> [Char]
[URIAuth] -> [Char] -> [Char]
URIAuth -> [Char]
(Int -> URIAuth -> [Char] -> [Char])
-> (URIAuth -> [Char])
-> ([URIAuth] -> [Char] -> [Char])
-> Show URIAuth
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> URIAuth -> [Char] -> [Char]
showsPrec :: Int -> URIAuth -> [Char] -> [Char]
$cshow :: URIAuth -> [Char]
show :: URIAuth -> [Char]
$cshowList :: [URIAuth] -> [Char] -> [Char]
showList :: [URIAuth] -> [Char] -> [Char]
Show, Typeable, Typeable URIAuth
Typeable URIAuth =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> URIAuth -> c URIAuth)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c URIAuth)
-> (URIAuth -> Constr)
-> (URIAuth -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c URIAuth))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c URIAuth))
-> ((forall b. Data b => b -> b) -> URIAuth -> URIAuth)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> URIAuth -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> URIAuth -> r)
-> (forall u. (forall d. Data d => d -> u) -> URIAuth -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> URIAuth -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> URIAuth -> m URIAuth)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> URIAuth -> m URIAuth)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> URIAuth -> m URIAuth)
-> Data URIAuth
URIAuth -> Constr
URIAuth -> DataType
(forall b. Data b => b -> b) -> URIAuth -> URIAuth
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> URIAuth -> u
forall u. (forall d. Data d => d -> u) -> URIAuth -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> URIAuth -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> URIAuth -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> URIAuth -> m URIAuth
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> URIAuth -> m URIAuth
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c URIAuth
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> URIAuth -> c URIAuth
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c URIAuth)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c URIAuth)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> URIAuth -> c URIAuth
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> URIAuth -> c URIAuth
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c URIAuth
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c URIAuth
$ctoConstr :: URIAuth -> Constr
toConstr :: URIAuth -> Constr
$cdataTypeOf :: URIAuth -> DataType
dataTypeOf :: URIAuth -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c URIAuth)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c URIAuth)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c URIAuth)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c URIAuth)
$cgmapT :: (forall b. Data b => b -> b) -> URIAuth -> URIAuth
gmapT :: (forall b. Data b => b -> b) -> URIAuth -> URIAuth
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> URIAuth -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> URIAuth -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> URIAuth -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> URIAuth -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> URIAuth -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> URIAuth -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> URIAuth -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> URIAuth -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> URIAuth -> m URIAuth
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> URIAuth -> m URIAuth
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> URIAuth -> m URIAuth
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> URIAuth -> m URIAuth
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> URIAuth -> m URIAuth
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> URIAuth -> m URIAuth
Data, (forall x. URIAuth -> Rep URIAuth x)
-> (forall x. Rep URIAuth x -> URIAuth) -> Generic URIAuth
forall x. Rep URIAuth x -> URIAuth
forall x. URIAuth -> Rep URIAuth x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. URIAuth -> Rep URIAuth x
from :: forall x. URIAuth -> Rep URIAuth x
$cto :: forall x. Rep URIAuth x -> URIAuth
to :: forall x. Rep URIAuth x -> URIAuth
Generic)
#else
    } deriving (Eq, Ord, Show, Typeable, Data)
#endif

instance NFData URIAuth where
    rnf :: URIAuth -> ()
rnf (URIAuth [Char]
ui [Char]
rn [Char]
p) = [Char]
ui [Char] -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` [Char]
rn [Char] -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` [Char]
p [Char] -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ()

-- |Blank URI
nullURI :: URI
nullURI :: URI
nullURI = URI
    { uriScheme :: [Char]
uriScheme     = [Char]
""
    , uriAuthority :: Maybe URIAuth
uriAuthority  = Maybe URIAuth
forall a. Maybe a
Nothing
    , uriPath :: [Char]
uriPath       = [Char]
""
    , uriQuery :: [Char]
uriQuery      = [Char]
""
    , uriFragment :: [Char]
uriFragment   = [Char]
""
    }

-- |Blank URIAuth.
nullURIAuth :: URIAuth
nullURIAuth :: URIAuth
nullURIAuth = URIAuth
    { uriUserInfo :: [Char]
uriUserInfo   = [Char]
""
    , uriRegName :: [Char]
uriRegName    = [Char]
""
    , uriPort :: [Char]
uriPort       = [Char]
""
    }

--  URI as instance of Show.  Note that for security reasons, the default
--  behaviour is to suppress any userinfo field (see RFC3986, section 7.5).
--  This can be overridden by using uriToString directly with first
--  argument @id@ (noting that this returns a ShowS value rather than a string).
--
--  [[[Another design would be to embed the userinfo mapping function in
--  the URIAuth value, with the default value suppressing userinfo formatting,
--  but providing a function to return a new URI value with userinfo
--  data exposed by show.]]]
--
instance Show URI where
    showsPrec :: Int -> URI -> [Char] -> [Char]
showsPrec Int
_ = ([Char] -> [Char]) -> URI -> [Char] -> [Char]
uriToString [Char] -> [Char]
defaultUserInfoMap

defaultUserInfoMap :: String -> String
defaultUserInfoMap :: [Char] -> [Char]
defaultUserInfoMap [Char]
uinf = [Char]
user[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
newpass
    where
        ([Char]
user,[Char]
pass) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':') [Char]
uinf
        newpass :: [Char]
newpass     = if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
pass Bool -> Bool -> Bool
|| ([Char]
pass [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"@")
                                   Bool -> Bool -> Bool
|| ([Char]
pass [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
":@")
                        then [Char]
pass
                        else [Char]
":...@"

------------------------------------------------------------
--  Parse a URI
------------------------------------------------------------

-- |Turn a string containing a URI into a 'URI'.
--  Returns 'Nothing' if the string is not a valid URI;
--  (an absolute URI with optional fragment identifier).
--
--  NOTE: this is different from the previous network.URI,
--  whose @parseURI@ function works like 'parseURIReference'
--  in this module.
--
parseURI :: String -> Maybe URI
parseURI :: [Char] -> Maybe URI
parseURI = URIParser URI -> [Char] -> Maybe URI
parseURIAny URIParser URI
uri

-- |Parse a URI reference to a 'URI' value.
--  Returns 'Nothing' if the string is not a valid URI reference.
--  (an absolute or relative URI with optional fragment identifier).
--
parseURIReference :: String -> Maybe URI
parseURIReference :: [Char] -> Maybe URI
parseURIReference = URIParser URI -> [Char] -> Maybe URI
parseURIAny URIParser URI
uriReference

-- |Parse a relative URI to a 'URI' value.
--  Returns 'Nothing' if the string is not a valid relative URI.
--  (a relative URI with optional fragment identifier).
--
parseRelativeReference :: String -> Maybe URI
parseRelativeReference :: [Char] -> Maybe URI
parseRelativeReference = URIParser URI -> [Char] -> Maybe URI
parseURIAny URIParser URI
relativeRef

-- |Parse an absolute URI to a 'URI' value.
--  Returns 'Nothing' if the string is not a valid absolute URI.
--  (an absolute URI without a fragment identifier).
--
parseAbsoluteURI :: String -> Maybe URI
parseAbsoluteURI :: [Char] -> Maybe URI
parseAbsoluteURI = URIParser URI -> [Char] -> Maybe URI
parseURIAny URIParser URI
absoluteURI

-- |Test if string contains a valid URI
--  (an absolute URI with optional fragment identifier).
--
isURI :: String -> Bool
isURI :: [Char] -> Bool
isURI = URIParser URI -> [Char] -> Bool
forall a. URIParser a -> [Char] -> Bool
isValidParse URIParser URI
uri

-- |Test if string contains a valid URI reference
--  (an absolute or relative URI with optional fragment identifier).
--
isURIReference :: String -> Bool
isURIReference :: [Char] -> Bool
isURIReference = URIParser URI -> [Char] -> Bool
forall a. URIParser a -> [Char] -> Bool
isValidParse URIParser URI
uriReference

-- |Test if string contains a valid relative URI
--  (a relative URI with optional fragment identifier).
--
isRelativeReference :: String -> Bool
isRelativeReference :: [Char] -> Bool
isRelativeReference = URIParser URI -> [Char] -> Bool
forall a. URIParser a -> [Char] -> Bool
isValidParse URIParser URI
relativeRef

-- |Test if string contains a valid absolute URI
--  (an absolute URI without a fragment identifier).
--
isAbsoluteURI :: String -> Bool
isAbsoluteURI :: [Char] -> Bool
isAbsoluteURI = URIParser URI -> [Char] -> Bool
forall a. URIParser a -> [Char] -> Bool
isValidParse URIParser URI
absoluteURI

-- |Test if string contains a valid IPv6 address
--
isIPv6address :: String -> Bool
isIPv6address :: [Char] -> Bool
isIPv6address = URIParser [Char] -> [Char] -> Bool
forall a. URIParser a -> [Char] -> Bool
isValidParse URIParser [Char]
ipv6address

-- |Test if string contains a valid IPv4 address
--
isIPv4address :: String -> Bool
isIPv4address :: [Char] -> Bool
isIPv4address = URIParser [Char] -> [Char] -> Bool
forall a. URIParser a -> [Char] -> Bool
isValidParse URIParser [Char]
ipv4address

--  Helper function for turning a string into a URI
--
parseURIAny :: URIParser URI -> String -> Maybe URI
parseURIAny :: URIParser URI -> [Char] -> Maybe URI
parseURIAny URIParser URI
parser [Char]
uristr = case URIParser URI -> [Char] -> [Char] -> Either ParseError URI
forall a. URIParser a -> [Char] -> [Char] -> Either ParseError a
parseAll URIParser URI
parser [Char]
"" [Char]
uristr of
        Left  ParseError
_ -> Maybe URI
forall a. Maybe a
Nothing
        Right URI
u -> URI -> Maybe URI
forall a. a -> Maybe a
Just URI
u

--  Helper function to test a string match to a parser
--
isValidParse :: URIParser a -> String -> Bool
isValidParse :: forall a. URIParser a -> [Char] -> Bool
isValidParse URIParser a
parser [Char]
uristr = case URIParser a -> [Char] -> [Char] -> Either ParseError a
forall a. URIParser a -> [Char] -> [Char] -> Either ParseError a
parseAll URIParser a
parser [Char]
"" [Char]
uristr of
        -- Left  e -> error (show e)
        Left  ParseError
_ -> Bool
False
        Right a
_ -> Bool
True

parseAll :: URIParser a -> String -> String -> Either ParseError a
parseAll :: forall a. URIParser a -> [Char] -> [Char] -> Either ParseError a
parseAll URIParser a
parser [Char]
filename [Char]
uristr = URIParser a -> [Char] -> [Char] -> Either ParseError a
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse URIParser a
newparser [Char]
filename [Char]
uristr
    where
        newparser :: URIParser a
newparser =
            do  { result <- URIParser a
parser
                ; eof
                ; return result
                }


------------------------------------------------------------
--  Predicates
------------------------------------------------------------

uriIsAbsolute :: URI -> Bool
uriIsAbsolute :: URI -> Bool
uriIsAbsolute URI{uriScheme :: URI -> [Char]
uriScheme = [Char]
scheme'} = [Char]
scheme' [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
""

uriIsRelative :: URI -> Bool
uriIsRelative :: URI -> Bool
uriIsRelative = Bool -> Bool
not (Bool -> Bool) -> (URI -> Bool) -> URI -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Bool
uriIsAbsolute

------------------------------------------------------------
--  URI parser body based on Parsec elements and combinators
------------------------------------------------------------

--  Parser parser type.
--  Currently
type URIParser a = GenParser Char () a

--  RFC3986, section 2.1
--
--  Parse and return a 'pct-encoded' sequence
--
escaped :: URIParser String
escaped :: URIParser [Char]
escaped = [ParsecT [Char] () Identity Char] -> URIParser [Char]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA [Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'%', ParsecT [Char] () Identity Char
hexDigitChar, ParsecT [Char] () Identity Char
hexDigitChar]

--  RFC3986, section 2.2
--
-- |Returns 'True' if the character is a \"reserved\" character in a
--  URI.  To include a literal instance of one of these characters in a
--  component of a URI, it must be escaped.
--
isReserved :: Char -> Bool
isReserved :: Char -> Bool
isReserved Char
c = Char -> Bool
isGenDelims Char
c Bool -> Bool -> Bool
|| Char -> Bool
isSubDelims Char
c

-- As per https://github.com/haskell/network-uri/pull/46, it was found
-- that the explicit case statement was noticeably faster than a nicer
-- expression in terms of `elem`.
isGenDelims :: Char -> Bool
isGenDelims :: Char -> Bool
isGenDelims Char
c =
  case Char
c of
    Char
':' -> Bool
True
    Char
'/' -> Bool
True
    Char
'?' -> Bool
True
    Char
'#' -> Bool
True
    Char
'[' -> Bool
True
    Char
']' -> Bool
True
    Char
'@' -> Bool
True
    Char
_ -> Bool
False

-- As per https://github.com/haskell/network-uri/pull/46, it was found
-- that the explicit case statement was noticeably faster than a nicer
-- expression in terms of `elem`.
isSubDelims :: Char -> Bool
isSubDelims :: Char -> Bool
isSubDelims Char
c =
  case Char
c of
    Char
'!' -> Bool
True
    Char
'$' -> Bool
True
    Char
'&' -> Bool
True
    Char
'\'' -> Bool
True
    Char
'(' -> Bool
True
    Char
')' -> Bool
True
    Char
'*' -> Bool
True
    Char
'+' -> Bool
True
    Char
',' -> Bool
True
    Char
';' -> Bool
True
    Char
'=' -> Bool
True
    Char
_ -> Bool
False

subDelims :: URIParser String
subDelims :: URIParser [Char]
subDelims = (Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[]) (Char -> [Char])
-> ParsecT [Char] () Identity Char -> URIParser [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
"!$&'()*+,;="

--  RFC3986, section 2.3
--
-- |Returns 'True' if the character is an \"unreserved\" character in
--  a URI.  These characters do not need to be escaped in a URI.  The
--  only characters allowed in a URI are either \"reserved\",
--  \"unreserved\", or an escape sequence (@%@ followed by two hex digits).
--
isUnreserved :: Char -> Bool
isUnreserved :: Char -> Bool
isUnreserved Char
c = Char -> Bool
isAlphaNumChar Char
c Bool -> Bool -> Bool
|| (Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"-_.~")

unreservedChar :: URIParser String
unreservedChar :: URIParser [Char]
unreservedChar = (Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[]) (Char -> [Char])
-> ParsecT [Char] () Identity Char -> URIParser [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isUnreserved

--  RFC3986, section 3
--
--   URI         = scheme ":" hier-part [ "?" query ] [ "#" fragment ]
--
--   hier-part   = "//" authority path-abempty
--               / path-abs
--               / path-rootless
--               / path-empty

uri :: URIParser URI
uri :: URIParser URI
uri =
    do  { us <- URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try URIParser [Char]
uscheme
        -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } )
        -- ; up <- upath
        ; (ua,up) <- hierPart
        ; uq <- option "" ( do { _ <- char '?' ; uquery    } )
        ; uf <- option "" ( do { _ <- char '#' ; ufragment } )
        ; return $ URI
            { uriScheme    = us
            , uriAuthority = ua
            , uriPath      = up
            , uriQuery     = uq
            , uriFragment  = uf
            }
        }

hierPart :: URIParser (Maybe URIAuth, String)
hierPart :: URIParser (Maybe URIAuth, [Char])
hierPart =
        do  { _ <- URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ([Char] -> URIParser [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"//")
            ; ua <- uauthority
            ; up <- pathAbEmpty
            ; return (ua,up)
            }
    URIParser (Maybe URIAuth, [Char])
-> URIParser (Maybe URIAuth, [Char])
-> URIParser (Maybe URIAuth, [Char])
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do  { up <- URIParser [Char]
pathAbs
            ; return (Nothing,up)
            }
    URIParser (Maybe URIAuth, [Char])
-> URIParser (Maybe URIAuth, [Char])
-> URIParser (Maybe URIAuth, [Char])
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do  { up <- URIParser [Char]
pathRootLess
            ; return (Nothing,up)
            }
    URIParser (Maybe URIAuth, [Char])
-> URIParser (Maybe URIAuth, [Char])
-> URIParser (Maybe URIAuth, [Char])
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do  { (Maybe URIAuth, [Char]) -> URIParser (Maybe URIAuth, [Char])
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe URIAuth
forall a. Maybe a
Nothing,[Char]
"")
            }

--  RFC3986, section 3.1

uscheme :: URIParser String
uscheme :: URIParser [Char]
uscheme =
    do  { s <- ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity Char -> URIParser [Char]
forall t s a.
GenParser t s a -> GenParser t s a -> GenParser t s [a]
oneThenMany ParsecT [Char] () Identity Char
alphaChar ((Char -> Bool) -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isSchemeChar)
        ; _ <- char ':'
        ; return $ s++":"
        }

--  RFC3986, section 3.2

uauthority :: URIParser (Maybe URIAuth)
uauthority :: URIParser (Maybe URIAuth)
uauthority =
    do  { uu <- [Char] -> URIParser [Char] -> URIParser [Char]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [Char]
"" (URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try URIParser [Char]
userinfo)
        ; uh <- host
        ; up <- option "" port
        ; return $ Just $ URIAuth
            { uriUserInfo = uu
            , uriRegName  = uh
            , uriPort     = up
            }
        }

--  RFC3986, section 3.2.1

userinfo :: URIParser String
userinfo :: URIParser [Char]
userinfo =
    do  { uu <- URIParser [Char] -> ParsecT [Char] () Identity [[Char]]
forall a.
ParsecT [Char] () Identity a -> ParsecT [Char] () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ([Char] -> URIParser [Char]
uchar [Char]
";:&=+$,")
        ; _ <- char '@'
        ; return (concat uu ++"@")
        }

--  RFC3986, section 3.2.2
--  RFC6874, section 2

host :: URIParser String
host :: URIParser [Char]
host = URIParser [Char]
ipLiteral URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try URIParser [Char]
ipv4address URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char]
regName

ipLiteral :: URIParser String
ipLiteral :: URIParser [Char]
ipLiteral =
    do  { _ <- Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'['
        ; ua <- ipv6addrz <|> ipvFuture
        ; _ <- char ']'
        ; return $ "[" ++ ua ++ "]"
        }
    URIParser [Char] -> [Char] -> URIParser [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"IP address literal"

ipvFuture :: URIParser String
ipvFuture :: URIParser [Char]
ipvFuture =
    do  { _ <- Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'v'
        ; h <- hexDigitChar
        ; _ <- char '.'
        ; a <- many1 (satisfy isIpvFutureChar)
        ; return $ 'v':h:'.':a
        }

isIpvFutureChar :: Char -> Bool
isIpvFutureChar :: Char -> Bool
isIpvFutureChar Char
c = Char -> Bool
isUnreserved Char
c Bool -> Bool -> Bool
|| Char -> Bool
isSubDelims Char
c Bool -> Bool -> Bool
|| (Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
';')

zoneid :: URIParser String
zoneid :: URIParser [Char]
zoneid = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [Char])
-> ParsecT [Char] () Identity [[Char]] -> URIParser [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URIParser [Char] -> ParsecT [Char] () Identity [[Char]]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 (URIParser [Char]
unreservedChar URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char]
escaped)

ipv6addrz :: URIParser String
ipv6addrz :: URIParser [Char]
ipv6addrz = [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
(++) ([Char] -> [Char] -> [Char])
-> URIParser [Char]
-> ParsecT [Char] () Identity ([Char] -> [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URIParser [Char]
ipv6address ParsecT [Char] () Identity ([Char] -> [Char])
-> URIParser [Char] -> URIParser [Char]
forall a b.
ParsecT [Char] () Identity (a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> URIParser [Char] -> URIParser [Char]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [Char]
"" (URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (URIParser [Char] -> URIParser [Char])
-> URIParser [Char] -> URIParser [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
(++) ([Char] -> [Char] -> [Char])
-> URIParser [Char]
-> ParsecT [Char] () Identity ([Char] -> [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> URIParser [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"%25" ParsecT [Char] () Identity ([Char] -> [Char])
-> URIParser [Char] -> URIParser [Char]
forall a b.
ParsecT [Char] () Identity (a -> b)
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> URIParser [Char]
zoneid)

ipv6address :: URIParser String
ipv6address :: URIParser [Char]
ipv6address =
        URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ( do
                { a2 <- Int -> URIParser [Char] -> ParsecT [Char] () Identity [[Char]]
forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count Int
6 URIParser [Char]
h4c
                ; a3 <- ls32
                ; return $ concat a2 ++ a3
                } )
    URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ( do
                { _ <- [Char] -> URIParser [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"::"
                ; a2 <- count 5 h4c
                ; a3 <- ls32
                ; return $ "::" ++ concat a2 ++ a3
                } )
    URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ( do
                { a1 <- Int -> URIParser [Char]
opt_n_h4c_h4 Int
0
                ; _ <- string "::"
                ; a2 <- count 4 h4c
                ; a3 <- ls32
                ; return $ a1 ++ "::" ++ concat a2 ++ a3
                } )
    URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ( do
                { a1 <- Int -> URIParser [Char]
opt_n_h4c_h4 Int
1
                ; _ <- string "::"
                ; a2 <- count 3 h4c
                ; a3 <- ls32
                ; return $ a1 ++ "::" ++ concat a2 ++ a3
                } )
    URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ( do
                { a1 <- Int -> URIParser [Char]
opt_n_h4c_h4 Int
2
                ; _ <- string "::"
                ; a2 <- count 2 h4c
                ; a3 <- ls32
                ; return $ a1 ++ "::" ++ concat a2 ++ a3
                } )
    URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ( do
                { a1 <- Int -> URIParser [Char]
opt_n_h4c_h4 Int
3
                ; _ <- string "::"
                ; a2 <- h4c
                ; a3 <- ls32
                ; return $ a1 ++ "::" ++ a2 ++ a3
                } )
    URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ( do
                { a1 <- Int -> URIParser [Char]
opt_n_h4c_h4 Int
4
                ; _ <- string "::"
                ; a3 <- ls32
                ; return $ a1 ++ "::" ++ a3
                } )
    URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ( do
                { a1 <- Int -> URIParser [Char]
opt_n_h4c_h4 Int
5
                ; _ <- string "::"
                ; a3 <- h4
                ; return $ a1 ++ "::" ++ a3
                } )
    URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ( do
                { a1 <- Int -> URIParser [Char]
opt_n_h4c_h4 Int
6
                ; _ <- string "::"
                ; return $ a1 ++ "::"
                } )
    URIParser [Char] -> [Char] -> URIParser [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"IPv6 address"

opt_n_h4c_h4 :: Int -> URIParser String
opt_n_h4c_h4 :: Int -> URIParser [Char]
opt_n_h4c_h4 Int
n = [Char] -> URIParser [Char] -> URIParser [Char]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [Char]
"" (URIParser [Char] -> URIParser [Char])
-> URIParser [Char] -> URIParser [Char]
forall a b. (a -> b) -> a -> b
$
    do  { a1 <- Int
-> Int -> URIParser [Char] -> ParsecT [Char] () Identity [[Char]]
forall t s a. Int -> Int -> GenParser t s a -> GenParser t s [a]
countMinMax Int
0 Int
n URIParser [Char]
h4c
        ; a2 <- h4
        ; return $ concat a1 ++ a2
        }

ls32 :: URIParser String
ls32 :: URIParser [Char]
ls32 =  URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ( do
                { a1 <- URIParser [Char]
h4c
                ; a2 <- h4
                ; return (a1++a2)
                } )
    URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char]
ipv4address

h4c :: URIParser String
h4c :: URIParser [Char]
h4c = URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (URIParser [Char] -> URIParser [Char])
-> URIParser [Char] -> URIParser [Char]
forall a b. (a -> b) -> a -> b
$
    do  { a1 <- URIParser [Char]
h4
        ; _ <- char ':'
        ; _ <- notFollowedBy (char ':')
        ; return $ a1 ++ ":"
        }

h4 :: URIParser String
h4 :: URIParser [Char]
h4 = Int -> Int -> ParsecT [Char] () Identity Char -> URIParser [Char]
forall t s a. Int -> Int -> GenParser t s a -> GenParser t s [a]
countMinMax Int
1 Int
4 ParsecT [Char] () Identity Char
hexDigitChar

ipv4address :: URIParser String
ipv4address :: URIParser [Char]
ipv4address =
    do  { a1 <- URIParser [Char]
decOctet ; _ <- char '.'
        ; a2 <- decOctet ; _ <- char '.'
        ; a3 <- decOctet ; _ <- char '.'
        ; a4 <- decOctet
        ; _ <- notFollowedBy nameChar
        ; return $ a1++"."++a2++"."++a3++"."++a4
        }
    URIParser [Char] -> [Char] -> URIParser [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"IPv4 Address"

decOctet :: URIParser String
decOctet :: URIParser [Char]
decOctet =
    do  { a1 <- Int -> Int -> ParsecT [Char] () Identity Char -> URIParser [Char]
forall t s a. Int -> Int -> GenParser t s a -> GenParser t s [a]
countMinMax Int
1 Int
3 ParsecT [Char] () Identity Char
digitChar
        ; if (read a1 :: Integer) > 255 then
            fail "Decimal octet value too large"
          else
            return a1
        }

regName :: URIParser String
regName :: URIParser [Char]
regName =
    do  { ss <- Int
-> Int -> URIParser [Char] -> ParsecT [Char] () Identity [[Char]]
forall t s a. Int -> Int -> GenParser t s a -> GenParser t s [a]
countMinMax Int
0 Int
255 URIParser [Char]
nameChar
        ; return $ concat ss
        }
    URIParser [Char] -> [Char] -> URIParser [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"Registered name"


nameChar :: URIParser String
nameChar :: URIParser [Char]
nameChar = (URIParser [Char]
unreservedChar URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char]
escaped URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char]
subDelims)
    URIParser [Char] -> [Char] -> URIParser [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> [Char] -> ParsecT s u m a
<?> [Char]
"Name character"

--  RFC3986, section 3.2.3

port :: URIParser String
port :: URIParser [Char]
port =
    do  { _ <- Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
        ; p <- many digitChar
        ; return (':':p)
        }

--
--  RFC3986, section 3.3
--
--   path          = path-abempty    ; begins with "/" or is empty
--                 / path-abs        ; begins with "/" but not "//"
--                 / path-noscheme   ; begins with a non-colon segment
--                 / path-rootless   ; begins with a segment
--                 / path-empty      ; zero characters
--
--   path-abempty  = *( "/" segment )
--   path-abs      = "/" [ segment-nz *( "/" segment ) ]
--   path-noscheme = segment-nzc *( "/" segment )
--   path-rootless = segment-nz *( "/" segment )
--   path-empty    = 0<pchar>
--
--   segment       = *pchar
--   segment-nz    = 1*pchar
--   segment-nzc   = 1*( unreserved / pct-encoded / sub-delims / "@" )
--
--   pchar         = unreserved / pct-encoded / sub-delims / ":" / "@"

{-
upath :: URIParser String
upath = pathAbEmpty
    <|> pathAbs
    <|> pathNoScheme
    <|> pathRootLess
    <|> pathEmpty
-}

pathAbEmpty :: URIParser String
pathAbEmpty :: URIParser [Char]
pathAbEmpty =
    do  { ss <- URIParser [Char] -> ParsecT [Char] () Identity [[Char]]
forall a.
ParsecT [Char] () Identity a -> ParsecT [Char] () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many URIParser [Char]
slashSegment
        ; return $ concat ss
        }

pathAbs :: URIParser String
pathAbs :: URIParser [Char]
pathAbs =
    do  { _ <- Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'/'
        ; ss <- option "" pathRootLess
        ; return $ '/':ss
        }

pathNoScheme :: URIParser String
pathNoScheme :: URIParser [Char]
pathNoScheme =
    do  { s1 <- URIParser [Char]
segmentNzc
        ; ss <- many slashSegment
        ; return $ concat (s1:ss)
        }

pathRootLess :: URIParser String
pathRootLess :: URIParser [Char]
pathRootLess =
    do  { s1 <- URIParser [Char]
segmentNz
        ; ss <- many slashSegment
        ; return $ concat (s1:ss)
        }

slashSegment :: URIParser String
slashSegment :: URIParser [Char]
slashSegment =
    do  { _ <- Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'/'
        ; s <- segment
        ; return ('/':s)
        }

segment :: URIParser String
segment :: URIParser [Char]
segment =
    do  { ps <- URIParser [Char] -> ParsecT [Char] () Identity [[Char]]
forall a.
ParsecT [Char] () Identity a -> ParsecT [Char] () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many URIParser [Char]
pchar
        ; return $ concat ps
        }

segmentNz :: URIParser String
segmentNz :: URIParser [Char]
segmentNz =
    do  { ps <- URIParser [Char] -> ParsecT [Char] () Identity [[Char]]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 URIParser [Char]
pchar
        ; return $ concat ps
        }

segmentNzc :: URIParser String
segmentNzc :: URIParser [Char]
segmentNzc =
    do  { ps <- URIParser [Char] -> ParsecT [Char] () Identity [[Char]]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many1 ([Char] -> URIParser [Char]
uchar [Char]
"@")
        ; return $ concat ps
        }

pchar :: URIParser String
pchar :: URIParser [Char]
pchar = [Char] -> URIParser [Char]
uchar [Char]
":@"

-- helper function for pchar and friends
uchar :: String -> URIParser String
uchar :: [Char] -> URIParser [Char]
uchar [Char]
extras =
        URIParser [Char]
unreservedChar
    URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char]
escaped
    URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser [Char]
subDelims
    URIParser [Char] -> URIParser [Char] -> URIParser [Char]
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do { c <- [Char] -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
extras ; return [c] }

--  RFC3986, section 3.4

uquery :: URIParser String
uquery :: URIParser [Char]
uquery =
    do  { ss <- URIParser [Char] -> ParsecT [Char] () Identity [[Char]]
forall a.
ParsecT [Char] () Identity a -> ParsecT [Char] () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (URIParser [Char] -> ParsecT [Char] () Identity [[Char]])
-> URIParser [Char] -> ParsecT [Char] () Identity [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> URIParser [Char]
uchar ([Char]
":@"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"/?")
        ; return $ '?':concat ss
        }

--  RFC3986, section 3.5

ufragment :: URIParser String
ufragment :: URIParser [Char]
ufragment =
    do  { ss <- URIParser [Char] -> ParsecT [Char] () Identity [[Char]]
forall a.
ParsecT [Char] () Identity a -> ParsecT [Char] () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (URIParser [Char] -> ParsecT [Char] () Identity [[Char]])
-> URIParser [Char] -> ParsecT [Char] () Identity [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> URIParser [Char]
uchar ([Char]
":@"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"/?")
        ; return $ '#':concat ss
        }

--  Reference, Relative and Absolute URI forms
--
--  RFC3986, section 4.1

uriReference :: URIParser URI
uriReference :: URIParser URI
uriReference = URIParser URI
uri URIParser URI -> URIParser URI -> URIParser URI
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> URIParser URI
relativeRef

--  RFC3986, section 4.2
--
--   relative-URI  = relative-part [ "?" query ] [ "#" fragment ]
--
--   relative-part = "//" authority path-abempty
--                 / path-abs
--                 / path-noscheme
--                 / path-empty

relativeRef :: URIParser URI
relativeRef :: URIParser URI
relativeRef =
    do  { URIParser [Char] -> ParsecT [Char] () Identity ()
forall a tok st.
Show a =>
GenParser tok st a -> GenParser tok st ()
notMatching URIParser [Char]
uscheme
        -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } )
        -- ; up <- upath
        ; (ua,up) <- URIParser (Maybe URIAuth, [Char])
relativePart
        ; uq <- option "" ( do { _ <- char '?' ; uquery    } )
        ; uf <- option "" ( do { _ <- char '#' ; ufragment } )
        ; return $ URI
            { uriScheme    = ""
            , uriAuthority = ua
            , uriPath      = up
            , uriQuery     = uq
            , uriFragment  = uf
            }
        }

relativePart :: URIParser (Maybe URIAuth, String)
relativePart :: URIParser (Maybe URIAuth, [Char])
relativePart =
        do  { _ <- URIParser [Char] -> URIParser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ([Char] -> URIParser [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"//")
            ; ua <- uauthority
            ; up <- pathAbEmpty
            ; return (ua,up)
            }
    URIParser (Maybe URIAuth, [Char])
-> URIParser (Maybe URIAuth, [Char])
-> URIParser (Maybe URIAuth, [Char])
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do  { up <- URIParser [Char]
pathAbs
            ; return (Nothing,up)
            }
    URIParser (Maybe URIAuth, [Char])
-> URIParser (Maybe URIAuth, [Char])
-> URIParser (Maybe URIAuth, [Char])
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do  { up <- URIParser [Char]
pathNoScheme
            ; return (Nothing,up)
            }
    URIParser (Maybe URIAuth, [Char])
-> URIParser (Maybe URIAuth, [Char])
-> URIParser (Maybe URIAuth, [Char])
forall a.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity a -> ParsecT [Char] () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do  { (Maybe URIAuth, [Char]) -> URIParser (Maybe URIAuth, [Char])
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe URIAuth
forall a. Maybe a
Nothing,[Char]
"")
            }

--  RFC3986, section 4.3

absoluteURI :: URIParser URI
absoluteURI :: URIParser URI
absoluteURI =
    do  { us <- URIParser [Char]
uscheme
        -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } )
        -- ; up <- upath
        ; (ua,up) <- hierPart
        ; uq <- option "" ( do { _ <- char '?' ; uquery    } )
        ; return $ URI
            { uriScheme    = us
            , uriAuthority = ua
            , uriPath      = up
            , uriQuery     = uq
            , uriFragment  = ""
            }
        }

--  Imports from RFC 2234

    -- NOTE: can't use isAlphaNum etc. because these deal with ISO 8859
    -- (and possibly Unicode!) chars.
    -- [[[Above was a comment originally in GHC Network/URI.hs:
    --    when IRIs are introduced then most codepoints above 128(?) should
    --    be treated as unreserved, and higher codepoints for letters should
    --    certainly be allowed.
    -- ]]]

isAlphaChar :: Char -> Bool
isAlphaChar :: Char -> Bool
isAlphaChar Char
c    = (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z') Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z')

isDigitChar :: Char -> Bool
isDigitChar :: Char -> Bool
isDigitChar Char
c    = Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9'

isAlphaNumChar :: Char -> Bool
isAlphaNumChar :: Char -> Bool
isAlphaNumChar Char
c = Char -> Bool
isAlphaChar Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigitChar Char
c

isHexDigitChar :: Char -> Bool
isHexDigitChar :: Char -> Bool
isHexDigitChar Char
c = Char -> Bool
isHexDigit Char
c

isSchemeChar :: Char -> Bool
isSchemeChar :: Char -> Bool
isSchemeChar Char
c   = Char -> Bool
isAlphaNumChar Char
c Bool -> Bool -> Bool
|| (Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"+-.")

alphaChar :: URIParser Char
alphaChar :: ParsecT [Char] () Identity Char
alphaChar = (Char -> Bool) -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isAlphaChar         -- or: Parsec.letter ?

digitChar :: URIParser Char
digitChar :: ParsecT [Char] () Identity Char
digitChar = (Char -> Bool) -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isDigitChar         -- or: Parsec.digit ?

hexDigitChar :: URIParser Char
hexDigitChar :: ParsecT [Char] () Identity Char
hexDigitChar = (Char -> Bool) -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isHexDigitChar   -- or: Parsec.hexDigit ?

--  Additional parser combinators for common patterns

oneThenMany :: GenParser t s a -> GenParser t s a -> GenParser t s [a]
oneThenMany :: forall t s a.
GenParser t s a -> GenParser t s a -> GenParser t s [a]
oneThenMany GenParser t s a
p1 GenParser t s a
pr =
    do  { a1 <- GenParser t s a
p1
        ; ar <- many pr
        ; return (a1:ar)
        }

countMinMax :: Int -> Int -> GenParser t s a -> GenParser t s [a]
countMinMax :: forall t s a. Int -> Int -> GenParser t s a -> GenParser t s [a]
countMinMax Int
m Int
n GenParser t s a
p | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 =
    do  { a1 <- GenParser t s a
p
        ; ar <- countMinMax (m-1) (n-1) p
        ; return (a1:ar)
        }
countMinMax Int
_ Int
n GenParser t s a
_ | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [a] -> GenParser t s [a]
forall a. a -> ParsecT [t] s Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
countMinMax Int
_ Int
n GenParser t s a
p = [a] -> GenParser t s [a] -> GenParser t s [a]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [] (GenParser t s [a] -> GenParser t s [a])
-> GenParser t s [a] -> GenParser t s [a]
forall a b. (a -> b) -> a -> b
$
    do  { a1 <- GenParser t s a
p
        ; ar <- countMinMax 0 (n-1) p
        ; return (a1:ar)
        }

notMatching :: Show a => GenParser tok st a -> GenParser tok st ()
notMatching :: forall a tok st.
Show a =>
GenParser tok st a -> GenParser tok st ()
notMatching GenParser tok st a
p = do { a <- GenParser tok st a -> GenParser tok st a
forall tok st a. GenParser tok st a -> GenParser tok st a
try GenParser tok st a
p ; unexpected (show a) } ParsecT [tok] st Identity ()
-> ParsecT [tok] st Identity () -> ParsecT [tok] st Identity ()
forall a.
ParsecT [tok] st Identity a
-> ParsecT [tok] st Identity a -> ParsecT [tok] st Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> ParsecT [tok] st Identity ()
forall a. a -> ParsecT [tok] st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

------------------------------------------------------------
--  Reconstruct a URI string
------------------------------------------------------------
--
-- |Turn a 'URI' into a string.
--
--  Uses a supplied function to map the userinfo part of the URI.
--
--  The Show instance for URI uses a mapping that hides any password
--  that may be present in the URI.  Use this function with argument @id@
--  to preserve the password in the formatted output.
--
uriToString :: (String->String) -> URI -> ShowS
uriToString :: ([Char] -> [Char]) -> URI -> [Char] -> [Char]
uriToString [Char] -> [Char]
userinfomap URI { uriScheme :: URI -> [Char]
uriScheme=[Char]
myscheme
                            , uriAuthority :: URI -> Maybe URIAuth
uriAuthority=Maybe URIAuth
myauthority
                            , uriPath :: URI -> [Char]
uriPath=[Char]
mypath
                            , uriQuery :: URI -> [Char]
uriQuery=[Char]
myquery
                            , uriFragment :: URI -> [Char]
uriFragment=[Char]
myfragment
                            } =
    ([Char]
myscheme[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char]) -> Maybe URIAuth -> [Char] -> [Char]
uriAuthToString [Char] -> [Char]
userinfomap Maybe URIAuth
myauthority
               ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
mypath[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
myquery[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
myfragment[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)

uriAuthToString :: (String->String) -> Maybe URIAuth -> ShowS
uriAuthToString :: ([Char] -> [Char]) -> Maybe URIAuth -> [Char] -> [Char]
uriAuthToString [Char] -> [Char]
_           Maybe URIAuth
Nothing   = [Char] -> [Char]
forall a. a -> a
id          -- shows ""
uriAuthToString [Char] -> [Char]
userinfomap
        (Just URIAuth { uriUserInfo :: URIAuth -> [Char]
uriUserInfo = [Char]
myuinfo
                      , uriRegName :: URIAuth -> [Char]
uriRegName  = [Char]
myregname
                      , uriPort :: URIAuth -> [Char]
uriPort     = [Char]
myport
                      } ) =
    ([Char]
"//"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
myuinfo then [Char] -> [Char]
forall a. a -> a
id else ([Char] -> [Char]
userinfomap [Char]
myuinfo [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++))
             ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
myregname[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
             ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
myport[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)

------------------------------------------------------------
--  Character classes
------------------------------------------------------------

-- | Returns 'True' if the character is allowed in a URI.
--
isAllowedInURI :: Char -> Bool
isAllowedInURI :: Char -> Bool
isAllowedInURI Char
c = Char -> Bool
isReserved Char
c Bool -> Bool -> Bool
|| Char -> Bool
isUnreserved Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%' -- escape char

-- | Returns 'True' if the character is allowed unescaped in a URI.
--
-- >>> escapeURIString isUnescapedInURI "http://haskell.org:80?some_param=true&other_param=їґ"
-- "http://haskell.org:80?some_param=true&other_param=%D1%97%D2%91"
isUnescapedInURI :: Char -> Bool
isUnescapedInURI :: Char -> Bool
isUnescapedInURI Char
c = Char -> Bool
isReserved Char
c Bool -> Bool -> Bool
|| Char -> Bool
isUnreserved Char
c

-- | Returns 'True' if the character is allowed unescaped in a URI component.
--
-- >>> escapeURIString isUnescapedInURIComponent "http://haskell.org:80?some_param=true&other_param=їґ"
-- "http%3A%2F%2Fhaskell.org%3A80%3Fsome_param%3Dtrue%26other_param%3D%D1%97%D2%91"
isUnescapedInURIComponent :: Char -> Bool
isUnescapedInURIComponent :: Char -> Bool
isUnescapedInURIComponent Char
c = Bool -> Bool
not (Char -> Bool
isReserved Char
c Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
isUnescapedInURI Char
c))

------------------------------------------------------------
--  Escape sequence handling
------------------------------------------------------------

-- |Escape character if supplied predicate is not satisfied,
--  otherwise return character as singleton string.
--
escapeURIChar :: (Char->Bool) -> Char -> String
escapeURIChar :: (Char -> Bool) -> Char -> [Char]
escapeURIChar Char -> Bool
p Char
c
    | Char -> Bool
p Char
c       = [Char
c]
    | Bool
otherwise = (Int -> [Char]) -> [Int] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Int
i -> Char
'%' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Int -> [Char] -> [Char]
myShowHex Int
i [Char]
"") (Char -> [Int]
utf8EncodeChar Char
c)
    where
        myShowHex :: Int -> ShowS
        myShowHex :: Int -> [Char] -> [Char]
myShowHex Int
n [Char]
r =  case Int -> (Int -> Char) -> Int -> [Char] -> [Char]
forall a. Integral a => a -> (Int -> Char) -> a -> [Char] -> [Char]
showIntAtBase Int
16 Int -> Char
forall {a}. Integral a => a -> Char
toChrHex Int
n [Char]
r of
            []  -> [Char]
"00"
            [Char
x] -> [Char
'0',Char
x]
            [Char]
cs  -> [Char]
cs
        toChrHex :: a -> Char
toChrHex a
d
            | a
d a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
10    = Int -> Char
chr (Char -> Int
ord Char
'0' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
d)
            | Bool
otherwise = Int -> Char
chr (Char -> Int
ord Char
'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
d a -> a -> a
forall a. Num a => a -> a -> a
- a
10))

-- From http://hackage.haskell.org/package/utf8-string
-- by Eric Mertens, BSD3
-- Returns [Int] for use with showIntAtBase
utf8EncodeChar :: Char -> [Int]
utf8EncodeChar :: Char -> [Int]
utf8EncodeChar = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> [Int]) -> (Char -> [Int]) -> Char -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int]
forall {a}. (Ord a, Num a, Bits a) => a -> [a]
go (Int -> [Int]) -> (Char -> Int) -> Char -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
 where
  go :: a -> [a]
go a
oc
   | a
oc a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0x7f       = [a
oc]

   | a
oc a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0x7ff      = [ a
0xc0 a -> a -> a
forall a. Num a => a -> a -> a
+ (a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
6)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ a
oc a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f
                        ]

   | a
oc a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0xffff     = [ a
0xe0 a -> a -> a
forall a. Num a => a -> a -> a
+ (a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
12)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
6) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ a
oc a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f
                        ]
   | Bool
otherwise        = [ a
0xf0 a -> a -> a
forall a. Num a => a -> a -> a
+ (a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
18)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
12) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
oc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
6) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f)
                        , a
0x80 a -> a -> a
forall a. Num a => a -> a -> a
+ a
oc a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x3f
                        ]

-- |Can be used to make a string valid for use in a URI.
--
escapeURIString
    :: (Char->Bool)     -- ^ a predicate which returns 'False'
                        --   if the character should be escaped
    -> String           -- ^ the string to process
    -> String           -- ^ the resulting URI string
escapeURIString :: (Char -> Bool) -> [Char] -> [Char]
escapeURIString Char -> Bool
p [Char]
s = (Char -> [Char]) -> [Char] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Char -> Bool) -> Char -> [Char]
escapeURIChar Char -> Bool
p) [Char]
s

-- |Turns all instances of escaped characters in the string back
--  into literal characters.
--
unEscapeString :: String -> String
unEscapeString :: [Char] -> [Char]
unEscapeString [] = [Char]
""
unEscapeString s :: [Char]
s@(Char
c:[Char]
cs) = case [Char] -> Maybe (Int, [Char])
unEscapeByte [Char]
s of
    Just (Int
byte, [Char]
rest) -> Int -> [Char] -> [Char]
unEscapeUtf8 Int
byte [Char]
rest
    Maybe (Int, [Char])
Nothing -> Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
unEscapeString [Char]
cs

unEscapeByte :: String -> Maybe (Int, String)
unEscapeByte :: [Char] -> Maybe (Int, [Char])
unEscapeByte (Char
'%':Char
x1:Char
x2:[Char]
s) | Char -> Bool
isHexDigit Char
x1 Bool -> Bool -> Bool
&& Char -> Bool
isHexDigit Char
x2 =
    (Int, [Char]) -> Maybe (Int, [Char])
forall a. a -> Maybe a
Just (Char -> Int
digitToInt Char
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
x2, [Char]
s)
unEscapeByte [Char]
_ = Maybe (Int, [Char])
forall a. Maybe a
Nothing

-- Adapted from http://hackage.haskell.org/package/utf8-string
-- by Eric Mertens, BSD3
unEscapeUtf8 :: Int -> String -> String
unEscapeUtf8 :: Int -> [Char] -> [Char]
unEscapeUtf8 Int
c [Char]
rest
    | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x80 = Int -> Char
chr Int
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
unEscapeString [Char]
rest
    | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xc0 = Char
replacement_character Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
unEscapeString [Char]
rest
    | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xe0 = [Char]
multi1
    | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xf0 = Int -> Int -> Int -> [Char]
multi_byte Int
2 Int
0xf Int
0x800
    | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xf8 = Int -> Int -> Int -> [Char]
multi_byte Int
3 Int
0x7 Int
0x10000
    | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xfc = Int -> Int -> Int -> [Char]
multi_byte Int
4 Int
0x3 Int
0x200000
    | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xfe = Int -> Int -> Int -> [Char]
multi_byte Int
5 Int
0x1 Int
0x4000000
    | Bool
otherwise    = Char
replacement_character Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
unEscapeString [Char]
rest
    where
    replacement_character :: Char
replacement_character = Char
'\xfffd'
    multi1 :: [Char]
multi1 = case [Char] -> Maybe (Int, [Char])
unEscapeByte [Char]
rest of
      Just (Int
c1, [Char]
ds) | Int
c1 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xc0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0x80 ->
        let d :: Int
d = ((Int -> Int
forall a. Enum a => a -> Int
fromEnum Int
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x1f) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
6) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|.  Int -> Int
forall a. Enum a => a -> Int
fromEnum (Int
c1 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3f)
        in if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0x000080 then Int -> Char
forall a. Enum a => Int -> a
toEnum Int
d Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
unEscapeString [Char]
ds
                            else Char
replacement_character Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
unEscapeString [Char]
ds
      Maybe (Int, [Char])
_ -> Char
replacement_character Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
unEscapeString [Char]
rest

    multi_byte :: Int -> Int -> Int -> String
    multi_byte :: Int -> Int -> Int -> [Char]
multi_byte Int
i Int
mask Int
overlong =
      Int -> [Char] -> Maybe (Int, [Char]) -> Int -> [Char]
forall {t}.
(Eq t, Num t) =>
t -> [Char] -> Maybe (Int, [Char]) -> Int -> [Char]
aux Int
i [Char]
rest ([Char] -> Maybe (Int, [Char])
unEscapeByte [Char]
rest) (Int
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask)
      where
        aux :: t -> [Char] -> Maybe (Int, [Char]) -> Int -> [Char]
aux t
0 [Char]
rs Maybe (Int, [Char])
_ Int
acc
          | Int
overlong Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
acc Bool -> Bool -> Bool
&& Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x10ffff Bool -> Bool -> Bool
&&
            (Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xd800 Bool -> Bool -> Bool
|| Int
0xdfff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
acc)     Bool -> Bool -> Bool
&&
            (Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xfffe Bool -> Bool -> Bool
|| Int
0xffff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
acc)      = Int -> Char
chr Int
acc Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
unEscapeString [Char]
rs
          | Bool
otherwise = Char
replacement_character Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
unEscapeString [Char]
rs

        aux t
n [Char]
_ (Just (Int
r, [Char]
rs)) Int
acc
          | Int
r Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xc0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0x80 = t -> [Char] -> Maybe (Int, [Char]) -> Int -> [Char]
aux (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) [Char]
rs ([Char] -> Maybe (Int, [Char])
unEscapeByte [Char]
rs)
                               (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
acc Int
6 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. (Int
r Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3f)

        aux t
_ [Char]
rs Maybe (Int, [Char])
_ Int
_ = Char
replacement_character Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
unEscapeString [Char]
rs

------------------------------------------------------------
-- Resolving a relative URI relative to a base URI
------------------------------------------------------------

-- |Returns a new 'URI' which represents the value of the
--  first 'URI' interpreted as relative to the second 'URI'.
--  For example:
--
--  > "foo" `relativeTo` "http://bar.org/" = "http://bar.org/foo"
--  > "http:foo" `nonStrictRelativeTo` "http://bar.org/" = "http://bar.org/foo"
--
--  Algorithm from RFC3986 [3], section 5.2.2
--

nonStrictRelativeTo :: URI -> URI -> URI
nonStrictRelativeTo :: URI -> URI -> URI
nonStrictRelativeTo URI
ref URI
base = URI -> URI -> URI
relativeTo URI
ref' URI
base
    where
        ref' :: URI
ref' = if URI -> [Char]
uriScheme URI
ref [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== URI -> [Char]
uriScheme URI
base
               then URI
ref { uriScheme="" }
               else URI
ref

isDefined :: ( MonadPlus m, Eq (m a) ) => m a -> Bool
isDefined :: forall (m :: * -> *) a. (MonadPlus m, Eq (m a)) => m a -> Bool
isDefined m a
a = m a
a m a -> m a -> Bool
forall a. Eq a => a -> a -> Bool
/= m a
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Returns a new 'URI' which represents the value of the first 'URI'
-- interpreted as relative to the second 'URI'.
--
-- Algorithm from RFC3986 [3], section 5.2
relativeTo :: URI -> URI -> URI
relativeTo :: URI -> URI -> URI
relativeTo URI
ref URI
base
    | [Char] -> Bool
forall (m :: * -> *) a. (MonadPlus m, Eq (m a)) => m a -> Bool
isDefined ( URI -> [Char]
uriScheme URI
ref ) =
        URI -> URI
just_segments URI
ref
    | Maybe URIAuth -> Bool
forall (m :: * -> *) a. (MonadPlus m, Eq (m a)) => m a -> Bool
isDefined ( URI -> Maybe URIAuth
uriAuthority URI
ref ) =
        URI -> URI
just_segments URI
ref { uriScheme = uriScheme base }
    | [Char] -> Bool
forall (m :: * -> *) a. (MonadPlus m, Eq (m a)) => m a -> Bool
isDefined ( URI -> [Char]
uriPath URI
ref ) =
        if [Char] -> Char
forall a. HasCallStack => [a] -> a
head (URI -> [Char]
uriPath URI
ref) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' then
            URI -> URI
just_segments URI
ref
                { uriScheme    = uriScheme base
                , uriAuthority = uriAuthority base
                }
        else
            URI -> URI
just_segments URI
ref
                { uriScheme    = uriScheme base
                , uriAuthority = uriAuthority base
                , uriPath      = mergePaths base ref
                }
    | [Char] -> Bool
forall (m :: * -> *) a. (MonadPlus m, Eq (m a)) => m a -> Bool
isDefined ( URI -> [Char]
uriQuery URI
ref ) =
        URI -> URI
just_segments URI
ref
            { uriScheme    = uriScheme base
            , uriAuthority = uriAuthority base
            , uriPath      = uriPath base
            }
    | Bool
otherwise =
        URI -> URI
just_segments URI
ref
            { uriScheme    = uriScheme base
            , uriAuthority = uriAuthority base
            , uriPath      = uriPath base
            , uriQuery     = uriQuery base
            }
    where
        just_segments :: URI -> URI
just_segments URI
u =
            URI
u { uriPath = removeDotSegments (uriPath u) }
        mergePaths :: URI -> URI -> [Char]
mergePaths URI
b URI
r
            | Maybe URIAuth -> Bool
forall (m :: * -> *) a. (MonadPlus m, Eq (m a)) => m a -> Bool
isDefined (URI -> Maybe URIAuth
uriAuthority URI
b) Bool -> Bool -> Bool
&& [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
pb = Char
'/'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
pr
            | Bool
otherwise                             = [Char] -> [Char]
dropLast [Char]
pb [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pr
            where
                pb :: [Char]
pb = URI -> [Char]
uriPath URI
b
                pr :: [Char]
pr = URI -> [Char]
uriPath URI
r
        dropLast :: [Char] -> [Char]
dropLast = ([Char], [Char]) -> [Char]
forall a b. (a, b) -> a
fst (([Char], [Char]) -> [Char])
-> ([Char] -> ([Char], [Char])) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ([Char], [Char])
splitLast -- reverse . dropWhile (/='/') . reverse

--  Remove dot segments, but protect leading '/' character
removeDotSegments :: String -> String
removeDotSegments :: [Char] -> [Char]
removeDotSegments (Char
'/':[Char]
ps) = Char
'/'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char] -> [[Char]] -> [Char]
elimDots [Char]
ps []
removeDotSegments [Char]
ps       = [Char] -> [[Char]] -> [Char]
elimDots [Char]
ps []

--  Second arg accumulates segments processed so far in reverse order
elimDots :: String -> [String] -> String
-- elimDots ps rs | traceVal "\nps " ps $ traceVal "rs " rs $ False = error ""
elimDots :: [Char] -> [[Char]] -> [Char]
elimDots [] [] = [Char]
""
elimDots [] [[Char]]
rs = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse [[Char]]
rs)
elimDots (    Char
'.':Char
'/':[Char]
ps)     [[Char]]
rs = [Char] -> [[Char]] -> [Char]
elimDots [Char]
ps [[Char]]
rs
elimDots (    Char
'.':[]    )     [[Char]]
rs = [Char] -> [[Char]] -> [Char]
elimDots [] [[Char]]
rs
elimDots (    Char
'.':Char
'.':Char
'/':[Char]
ps) [[Char]]
rs = [Char] -> [[Char]] -> [Char]
elimDots [Char]
ps (Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
drop Int
1 [[Char]]
rs)
elimDots (    Char
'.':Char
'.':[]    ) [[Char]]
rs = [Char] -> [[Char]] -> [Char]
elimDots [] (Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
drop Int
1 [[Char]]
rs)
elimDots [Char]
ps [[Char]]
rs = [Char] -> [[Char]] -> [Char]
elimDots [Char]
ps1 ([Char]
r[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[[Char]]
rs)
    where
        ([Char]
r,[Char]
ps1) = [Char] -> ([Char], [Char])
nextSegment [Char]
ps

--  Returns the next segment and the rest of the path from a path string.
--  Each segment ends with the next '/' or the end of string.
--
nextSegment :: String -> (String,String)
nextSegment :: [Char] -> ([Char], [Char])
nextSegment [Char]
ps =
    case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') [Char]
ps of
        ([Char]
r,Char
'/':[Char]
ps1) -> ([Char]
r[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"/",[Char]
ps1)
        ([Char]
r,[Char]
_)       -> ([Char]
r,[])

-- | The segments of the path component of a URI. E.g.,
segments :: String -> [String]
segments :: [Char] -> [[Char]]
segments [Char]
str = [[Char]] -> [[Char]]
dropLeadingEmpty ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Maybe ([Char], [Char])) -> [Char] -> [[Char]]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr [Char] -> Maybe ([Char], [Char])
nextSegmentMaybe [Char]
str
    where
        nextSegmentMaybe :: [Char] -> Maybe ([Char], [Char])
nextSegmentMaybe [Char]
"" = Maybe ([Char], [Char])
forall a. Maybe a
Nothing
        nextSegmentMaybe [Char]
ps =
            case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') [Char]
ps of
                ([Char]
seg, Char
'/':[Char]
ps1) -> ([Char], [Char]) -> Maybe ([Char], [Char])
forall a. a -> Maybe a
Just ([Char]
seg, [Char]
ps1)
                ([Char]
seg, [Char]
_)       -> ([Char], [Char]) -> Maybe ([Char], [Char])
forall a. a -> Maybe a
Just ([Char]
seg, [Char]
"")
        dropLeadingEmpty :: [[Char]] -> [[Char]]
dropLeadingEmpty ([Char]
"":[[Char]]
xs) = [[Char]]
xs
        dropLeadingEmpty [[Char]]
xs      = [[Char]]
xs

-- | Returns the segments of the path component. E.g.,
--    pathSegments <$> parseURI "http://example.org/foo/bar/baz"
-- == ["foo", "bar", "baz"]
pathSegments :: URI -> [String]
pathSegments :: URI -> [[Char]]
pathSegments = [Char] -> [[Char]]
segments ([Char] -> [[Char]]) -> (URI -> [Char]) -> URI -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> [Char]
uriPath

-- | Split last (name) segment from path, returning (path,name)
splitLast :: String -> (String,String)
splitLast :: [Char] -> ([Char], [Char])
splitLast [Char]
p = ([Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
revpath,[Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
revname)
    where
        ([Char]
revname,[Char]
revpath) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') ([Char] -> ([Char], [Char])) -> [Char] -> ([Char], [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
p

------------------------------------------------------------
-- Finding a URI relative to a base URI
------------------------------------------------------------

-- |Returns a new 'URI' which represents the relative location of
--  the first 'URI' with respect to the second 'URI'.  Thus, the
--  values supplied are expected to be absolute URIs, and the result
--  returned may be a relative URI.
--
--  Example:
--
--  > "http://example.com/Root/sub1/name2#frag"
--  >   `relativeFrom` "http://example.com/Root/sub2/name2#frag"
--  >   == "../sub1/name2#frag"
--
--  There is no single correct implementation of this function,
--  but any acceptable implementation must satisfy the following:
--
--  > (uabs `relativeFrom` ubase) `relativeTo` ubase == uabs
--
--  For any valid absolute URI.
--  (cf. <http://lists.w3.org/Archives/Public/uri/2003Jan/0008.html>
--       <http://lists.w3.org/Archives/Public/uri/2003Jan/0005.html>)
--
relativeFrom :: URI -> URI -> URI
relativeFrom :: URI -> URI -> URI
relativeFrom URI
uabs URI
base
    | (URI -> [Char]) -> URI -> URI -> Bool
forall b a. Eq b => (a -> b) -> a -> a -> Bool
diff URI -> [Char]
uriScheme    URI
uabs URI
base = URI
uabs
    | (URI -> Maybe URIAuth) -> URI -> URI -> Bool
forall b a. Eq b => (a -> b) -> a -> a -> Bool
diff URI -> Maybe URIAuth
uriAuthority URI
uabs URI
base = URI
uabs { uriScheme = "" }
    | (URI -> [Char]) -> URI -> URI -> Bool
forall b a. Eq b => (a -> b) -> a -> a -> Bool
diff URI -> [Char]
uriPath      URI
uabs URI
base = URI
uabs
        { uriScheme    = ""
        , uriAuthority = Nothing
        , uriPath      = relPathFrom (removeBodyDotSegments $ uriPath uabs)
                                     (removeBodyDotSegments $ uriPath base)
        }
    | (URI -> [Char]) -> URI -> URI -> Bool
forall b a. Eq b => (a -> b) -> a -> a -> Bool
diff URI -> [Char]
uriQuery     URI
uabs URI
base = URI
uabs
        { uriScheme    = ""
        , uriAuthority = Nothing
        , uriPath      = ""
        }
    | Bool
otherwise = URI
uabs          -- Always carry fragment from uabs
        { uriScheme    = ""
        , uriAuthority = Nothing
        , uriPath      = ""
        , uriQuery     = ""
        }
    where
        diff :: Eq b => (a -> b) -> a -> a -> Bool
        diff :: forall b a. Eq b => (a -> b) -> a -> a -> Bool
diff a -> b
sel a
u1 a
u2 = a -> b
sel a
u1 b -> b -> Bool
forall a. Eq a => a -> a -> Bool
/= a -> b
sel a
u2
        -- Remove dot segments except the final segment
        removeBodyDotSegments :: [Char] -> [Char]
removeBodyDotSegments [Char]
p = [Char] -> [Char]
removeDotSegments [Char]
p1 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
p2
            where
                ([Char]
p1,[Char]
p2) = [Char] -> ([Char], [Char])
splitLast [Char]
p

-- | Calculate the path to the first argument, from the second argument.
relPathFrom :: String -> String -> String
relPathFrom :: [Char] -> [Char] -> [Char]
relPathFrom []   [Char]
_    = [Char]
"/"
relPathFrom [Char]
pabs []   = [Char]
pabs
relPathFrom [Char]
pabs [Char]
base =
    if [Char]
sa1 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
sb1                       -- If the first segments are equal
        then if [Char]
sa1 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"/"              -- and they're absolute,
            then if [Char]
sa2 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
sb2            -- then if the 2nd segs are equal,
                then [Char] -> [Char] -> [Char]
relPathFrom1 [Char]
ra2 [Char]
rb2   -- relativize from there.
                else
                   [Char]
pabs                     -- Otherwise it's not worth trying.
            else [Char] -> [Char] -> [Char]
relPathFrom1 [Char]
ra1 [Char]
rb1     -- If same & relative, relativize.
        else [Char]
pabs                       -- If 1st segs not equal, just use pabs.
    where
        ([Char]
sa1,[Char]
ra1) = [Char] -> ([Char], [Char])
nextSegment [Char]
pabs
        ([Char]
sb1,[Char]
rb1) = [Char] -> ([Char], [Char])
nextSegment [Char]
base
        ([Char]
sa2,[Char]
ra2) = [Char] -> ([Char], [Char])
nextSegment [Char]
ra1
        ([Char]
sb2,[Char]
rb2) = [Char] -> ([Char], [Char])
nextSegment [Char]
rb1

--  relPathFrom1 strips off trailing names from the supplied paths, and finds
--  the relative path from base to target.
relPathFrom1 :: String -> String -> String
relPathFrom1 :: [Char] -> [Char] -> [Char]
relPathFrom1 [Char]
pabs [Char]
base = [Char]
relName
    where
        -- Relative paths are reckoned without the basename, so split those off.
        ([Char]
sa,[Char]
na) = [Char] -> ([Char], [Char])
splitLast [Char]
pabs
        ([Char]
sb,[Char]
nb) = [Char] -> ([Char], [Char])
splitLast [Char]
base
        rp :: [Char]
rp      = [Char] -> [Char] -> [Char]
relSegsFrom [Char]
sa [Char]
sb
        relName :: [Char]
relName = if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
rp then
                      -- If the relative path is empty, and the basenames are
                      -- the same, then the paths must be exactly the same.
                      if [Char]
na [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
nb then [Char]
""
                      -- If the name is vulnerable to being misinterpreted,
                      -- add a dot segment in advance to protect it.
                      else if [Char] -> Bool
forall {t :: * -> *}. Foldable t => t Char -> Bool
protect [Char]
na then [Char]
"./"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
na
                      else [Char]
na
                  else
                      [Char]
rp[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
na
        -- If a single-segment path is null or contains a ':', it needs
        -- "protection" from being interpreted as a different kind of URL.
        protect :: t Char -> Bool
protect t Char
s = t Char -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t Char
s Bool -> Bool -> Bool
|| Char
':' Char -> t Char -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Char
s

--  relSegsFrom discards any equal leading segments from two *directory*
--  paths, then invokes difSegsFrom to calculate a relative path from the end
--  of the base path to the end of the target path.
relSegsFrom :: String -> String -> String
{-
relSegsFrom sabs base
    | traceVal "\nrelSegsFrom\nsabs " sabs $ traceVal "base " base $
      False = error ""
-}
relSegsFrom :: [Char] -> [Char] -> [Char]
relSegsFrom []   []   = [Char]
""      -- paths are identical
relSegsFrom [Char]
sabs [Char]
base =
    if [Char]
sa1 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
sb1
        then [Char] -> [Char] -> [Char]
relSegsFrom [Char]
ra1 [Char]
rb1
        else [Char] -> [Char] -> [Char]
difSegsFrom [Char]
sabs [Char]
base
    where
        ([Char]
sa1,[Char]
ra1) = [Char] -> ([Char], [Char])
nextSegment [Char]
sabs
        ([Char]
sb1,[Char]
rb1) = [Char] -> ([Char], [Char])
nextSegment [Char]
base

-- Given two paths @a@, @b@, count out the necessary number of ".." segments
-- to get from the depth of @b@ to the path @a@.
difSegsFrom :: String -> String -> String
{-
difSegsFrom sabs base
    | traceVal "\ndifSegsFrom\nsabs " sabs $ traceVal "base " base $
      False = error ""
-}
difSegsFrom :: [Char] -> [Char] -> [Char]
difSegsFrom [Char]
sabs [Char]
""   = [Char]
sabs
difSegsFrom [Char]
sabs [Char]
base = [Char] -> [Char] -> [Char]
difSegsFrom ([Char]
"../"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
sabs) (([Char], [Char]) -> [Char]
forall a b. (a, b) -> b
snd (([Char], [Char]) -> [Char]) -> ([Char], [Char]) -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> ([Char], [Char])
nextSegment [Char]
base)

------------------------------------------------------------
--  Other normalization functions
------------------------------------------------------------

-- |Case normalization; cf. RFC3986 section 6.2.2.1
--  NOTE:  authority case normalization is not performed
--
normalizeCase :: String -> String
normalizeCase :: [Char] -> [Char]
normalizeCase [Char]
uristr = [Char] -> [Char]
ncScheme [Char]
uristr
    where
        ncScheme :: [Char] -> [Char]
ncScheme (Char
':':[Char]
cs)                = Char
':'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char] -> [Char]
ncEscape [Char]
cs
        ncScheme (Char
c:[Char]
cs) | Char -> Bool
isSchemeChar Char
c = Char -> Char
toLower Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char] -> [Char]
ncScheme [Char]
cs
        ncScheme [Char]
_                       = [Char] -> [Char]
ncEscape [Char]
uristr -- no scheme present
        ncEscape :: [Char] -> [Char]
ncEscape (Char
'%':Char
h1:Char
h2:[Char]
cs) = Char
'%'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char -> Char
toUpper Char
h1Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char -> Char
toUpper Char
h2Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char] -> [Char]
ncEscape [Char]
cs
        ncEscape (Char
c:[Char]
cs)         = Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char] -> [Char]
ncEscape [Char]
cs
        ncEscape []             = []

-- |Encoding normalization; cf. RFC3986 section 6.2.2.2
--
normalizeEscape :: String -> String
normalizeEscape :: [Char] -> [Char]
normalizeEscape (Char
'%':Char
h1:Char
h2:[Char]
cs)
    | Char -> Bool
isHexDigit Char
h1 Bool -> Bool -> Bool
&& Char -> Bool
isHexDigit Char
h2 Bool -> Bool -> Bool
&& Char -> Bool
isUnreserved Char
escval =
        Char
escvalChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char] -> [Char]
normalizeEscape [Char]
cs
    where
        escval :: Char
escval = Int -> Char
chr (Char -> Int
digitToInt Char
h1Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
16Int -> Int -> Int
forall a. Num a => a -> a -> a
+Char -> Int
digitToInt Char
h2)
normalizeEscape (Char
c:[Char]
cs)         = Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char] -> [Char]
normalizeEscape [Char]
cs
normalizeEscape []             = []

-- |Path segment normalization; cf. RFC3986 section 6.2.2.3
--
normalizePathSegments :: String -> String
normalizePathSegments :: [Char] -> [Char]
normalizePathSegments [Char]
uristr = Maybe URI -> [Char]
normstr Maybe URI
juri
    where
        juri :: Maybe URI
juri = [Char] -> Maybe URI
parseURI [Char]
uristr
        normstr :: Maybe URI -> [Char]
normstr Maybe URI
Nothing  = [Char]
uristr
        normstr (Just URI
u) = URI -> [Char]
forall a. Show a => a -> [Char]
show (URI -> URI
normuri URI
u)
        normuri :: URI -> URI
normuri URI
u = URI
u { uriPath = removeDotSegments (uriPath u) }

------------------------------------------------------------
--  Lift instances to support Network.URI.Static
------------------------------------------------------------

#if __GLASGOW_HASKELL__ >= 800
deriving instance Lift URI
deriving instance Lift URIAuth
#else
instance Lift URI where
    lift (URI {..}) = [| URI {..} |]

instance Lift URIAuth where
    lift (URIAuth {..}) = [| URIAuth {..} |]
#endif

------------------------------------------------------------
--  Deprecated functions
------------------------------------------------------------

{-# DEPRECATED parseabsoluteURI "use parseAbsoluteURI" #-}
parseabsoluteURI :: String -> Maybe URI
parseabsoluteURI :: [Char] -> Maybe URI
parseabsoluteURI = [Char] -> Maybe URI
parseAbsoluteURI

{-# DEPRECATED escapeString "use escapeURIString, and note the flipped arguments" #-}
escapeString :: String -> (Char->Bool) -> String
escapeString :: [Char] -> (Char -> Bool) -> [Char]
escapeString = ((Char -> Bool) -> [Char] -> [Char])
-> [Char] -> (Char -> Bool) -> [Char]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Char -> Bool) -> [Char] -> [Char]
escapeURIString

{-# DEPRECATED reserved "use isReserved" #-}
reserved :: Char -> Bool
reserved :: Char -> Bool
reserved = Char -> Bool
isReserved

{-# DEPRECATED unreserved "use isUnreserved" #-}
unreserved :: Char -> Bool
unreserved :: Char -> Bool
unreserved = Char -> Bool
isUnreserved

--  Additional component access functions for backward compatibility

{-# DEPRECATED scheme "use uriScheme" #-}
scheme :: URI -> String
scheme :: URI -> [Char]
scheme = ([Char] -> [Char]) -> [Char] -> [Char]
forall a. ([a] -> [a]) -> [a] -> [a]
orNull [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
init ([Char] -> [Char]) -> (URI -> [Char]) -> URI -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> [Char]
uriScheme

runShowS :: ShowS -> String
runShowS :: ([Char] -> [Char]) -> [Char]
runShowS [Char] -> [Char]
s = [Char] -> [Char]
s [Char]
""

{-# DEPRECATED authority "use uriAuthority, and note changed functionality" #-}
authority :: URI -> String
authority :: URI -> [Char]
authority = [Char] -> [Char]
dropss ([Char] -> [Char]) -> (URI -> [Char]) -> URI -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char]) -> [Char]
runShowS (([Char] -> [Char]) -> [Char])
-> (URI -> [Char] -> [Char]) -> URI -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char]) -> Maybe URIAuth -> [Char] -> [Char]
uriAuthToString [Char] -> [Char]
forall a. a -> a
id (Maybe URIAuth -> [Char] -> [Char])
-> (URI -> Maybe URIAuth) -> URI -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Maybe URIAuth
uriAuthority
    where
        -- Old-style authority component does not include leading '//'
        dropss :: [Char] -> [Char]
dropss (Char
'/':Char
'/':[Char]
s) = [Char]
s
        dropss [Char]
s           = [Char]
s

{-# DEPRECATED path "use uriPath" #-}
path :: URI -> String
path :: URI -> [Char]
path = URI -> [Char]
uriPath

{-# DEPRECATED query "use uriQuery, and note changed functionality" #-}
query :: URI -> String
query :: URI -> [Char]
query = ([Char] -> [Char]) -> [Char] -> [Char]
forall a. ([a] -> [a]) -> [a] -> [a]
orNull [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
tail ([Char] -> [Char]) -> (URI -> [Char]) -> URI -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> [Char]
uriQuery

{-# DEPRECATED fragment "use uriFragment, and note changed functionality" #-}
fragment :: URI -> String
fragment :: URI -> [Char]
fragment = ([Char] -> [Char]) -> [Char] -> [Char]
forall a. ([a] -> [a]) -> [a] -> [a]
orNull [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
tail ([Char] -> [Char]) -> (URI -> [Char]) -> URI -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> [Char]
uriFragment

orNull :: ([a]->[a]) -> [a] -> [a]
orNull :: forall a. ([a] -> [a]) -> [a] -> [a]
orNull [a] -> [a]
_ [] = []
orNull [a] -> [a]
f [a]
as = [a] -> [a]
f [a]
as

--------------------------------------------------------------------------------
--
--  Copyright (c) 2004, G. KLYNE.  All rights reserved.
--  Distributed as free software under the following license.
--
--  Redistribution and use in source and binary forms, with or without
--  modification, are permitted provided that the following conditions
--  are met:
--
--  - Redistributions of source code must retain the above copyright notice,
--  this list of conditions and the following disclaimer.
--
--  - Redistributions in binary form must reproduce the above copyright
--  notice, this list of conditions and the following disclaimer in the
--  documentation and/or other materials provided with the distribution.
--
--  - Neither name of the copyright holders nor the names of its
--  contributors may be used to endorse or promote products derived from
--  this software without specific prior written permission.
--
--  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS
--  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
--  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
--  A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
--  HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
--  INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
--  BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
--  OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
--  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
--  TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
--  USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--
--------------------------------------------------------------------------------