{-# LANGUAGE
    OverloadedStrings
  , RecordWildCards
  , DeriveGeneric
  , DeriveDataTypeable
  #-}

module Data.URI where

import Data.URI.Auth (URIAuth, parseURIAuth, printURIAuth)

import Prelude hiding (Maybe (..), takeWhile, maybe)
import qualified Prelude as P
import Data.Strict.Maybe (Maybe (..), maybe)
import Data.Strict.Tuple (Pair (..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Monoid ((<>))
import Data.Attoparsec.Text (Parser, char, string, sepBy, takeWhile, takeWhile1, (<?>))
import Data.Char (isControl, isSpace)
import Control.Monad (void, when)
import Control.Applicative ((<|>), optional)

import Data.Data (Typeable)
import GHC.Generics (Generic)
import Test.QuickCheck (Arbitrary (..))
import Test.QuickCheck.Gen (oneof, listOf, listOf1, elements)
import Test.QuickCheck.Instances ()


data URI = URI
  { URI -> Maybe Text
uriScheme    :: !(Maybe Text) -- ^ the scheme without the colon - @https://hackage.haskell.org/@ has a scheme of @https@
  , URI -> Bool
uriSlashes   :: !Bool -- ^ are the slashes present? - @https://hackage.haskell.org/@ is @True@
  , URI -> URIAuth
uriAuthority :: !URIAuth
  , URI -> Maybe (Vector Text)
uriPath      :: !(Maybe (Vector Text)) -- ^ slash-separated list - @https://hackage.haskell.org/foo@ is @["foo"]@
  , URI -> Vector (Pair Text (Maybe Text))
uriQuery     :: !(Vector (Pair Text (Maybe Text))) -- ^ list of key-value pairs - @https://hackage.haskell.org/?foo=bar&baz&qux=@ is
                                                       -- @[("foo", Just "bar"), ("baz", Nothing), ("qux", Just "")]@
  , URI -> Maybe Text
uriFragment  :: !(Maybe Text) -- ^ uri suffix - @https://hackage.haskell.org/#some-header@ is @Just "some-header"@
  } deriving (Int -> URI -> ShowS
[URI] -> ShowS
URI -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [URI] -> ShowS
$cshowList :: [URI] -> ShowS
show :: URI -> String
$cshow :: URI -> String
showsPrec :: Int -> URI -> ShowS
$cshowsPrec :: Int -> URI -> ShowS
Show, URI -> URI -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URI -> URI -> Bool
$c/= :: URI -> URI -> Bool
== :: URI -> URI -> Bool
$c== :: URI -> URI -> Bool
Eq, Typeable, 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
$cto :: forall x. Rep URI x -> URI
$cfrom :: forall x. URI -> Rep URI x
Generic)

instance Arbitrary URI where
  arbitrary :: Gen URI
arbitrary = Maybe Text
-> Bool
-> URIAuth
-> Maybe (Vector Text)
-> Vector (Pair Text (Maybe Text))
-> Maybe Text
-> URI
URI forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Maybe Text)
arbitraryScheme
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Maybe (Vector Text))
arbitraryPath
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Vector (Pair Text (Maybe Text)))
arbitraryQuery
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Maybe Text)
arbitraryScheme
    where
      arbitraryScheme :: Gen (Maybe Text)
arbitraryScheme = forall a. [Gen a] -> Gen a
oneof [forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
arbitraryNonEmptyText]
      arbitraryNonEmptyText :: Gen Text
arbitraryNonEmptyText = String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen [a]
listOf1 (forall a. [a] -> Gen a
elements [Char
'a' .. Char
'z'])
      arbitraryPath :: Gen (Maybe (Vector Text))
arbitraryPath =
        forall a. [Gen a] -> Gen a
oneof [forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
V.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen [a]
listOf1 Gen Text
arbitraryNonEmptyText]
      arbitraryQuery :: Gen (Vector (Pair Text (Maybe Text)))
arbitraryQuery =
        forall a. [a] -> Vector a
V.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen [a]
listOf Gen (Pair Text (Maybe Text))
go
        where
          go :: Gen (Pair Text (Maybe Text))
go = do
            Text
a <- Gen Text
arbitraryNonEmptyText
            Maybe Text
mb <- forall a. [Gen a] -> Gen a
oneof [forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
arbitraryNonEmptyText]
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
a forall a b. a -> b -> Pair a b
:!: Maybe Text
mb)



printURI :: URI -> Text
printURI :: URI -> Text
printURI URI{Bool
Maybe Text
Maybe (Vector Text)
Vector (Pair Text (Maybe Text))
URIAuth
uriFragment :: Maybe Text
uriQuery :: Vector (Pair Text (Maybe Text))
uriPath :: Maybe (Vector Text)
uriAuthority :: URIAuth
uriSlashes :: Bool
uriScheme :: Maybe Text
uriFragment :: URI -> Maybe Text
uriQuery :: URI -> Vector (Pair Text (Maybe Text))
uriPath :: URI -> Maybe (Vector Text)
uriAuthority :: URI -> URIAuth
uriSlashes :: URI -> Bool
uriScheme :: URI -> Maybe Text
..} =
     forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (forall a. Semigroup a => a -> a -> a
<> Text
":") Maybe Text
uriScheme
  forall a. Semigroup a => a -> a -> a
<> (if Bool
uriSlashes then Text
"//" else Text
"")
  forall a. Semigroup a => a -> a -> a
<> URIAuth -> Text
printURIAuth URIAuth
uriAuthority
  forall a. Semigroup a => a -> a -> a
<> ( case Maybe (Vector Text)
uriPath of
         Just Vector Text
xs -> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"/" (forall a. Vector a -> [a]
V.toList Vector Text
xs)
         Maybe (Vector Text)
Nothing -> Text
""
     )
  forall a. Semigroup a => a -> a -> a
<> ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Vector (Pair Text (Maybe Text))
uriQuery
          then Text
""
          else Text
"?"
            forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"&"
                ( forall a. Vector a -> [a]
V.toList forall a b. (a -> b) -> a -> b
$
                  (\(Text
k :!: Maybe Text
mV) ->
                    let v' :: Text
v' = case Maybe Text
mV of
                              Maybe Text
Nothing -> Text
""
                              Just Text
v  -> Text
"=" forall a. Semigroup a => a -> a -> a
<> Text
v
                    in  Text
k forall a. Semigroup a => a -> a -> a
<> Text
v'
                  ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (Pair Text (Maybe Text))
uriQuery
                )
      )
  forall a. Semigroup a => a -> a -> a
<> case Maybe Text
uriFragment of
        Maybe Text
Nothing -> Text
""
        Just Text
f -> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
f



parseURI :: Parser URI
parseURI :: Parser URI
parseURI =
  Maybe Text
-> Bool
-> URIAuth
-> Maybe (Vector Text)
-> Vector (Pair Text (Maybe Text))
-> Maybe Text
-> URI
URI forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall {a}. Maybe a -> Maybe a
toStrictMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text
parseScheme)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
parseSlashes
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser URIAuth
parseURIAuth
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe (Vector Text))
parsePath
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Vector (Pair Text (Maybe Text)))
parseQuery
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall {a}. Maybe a -> Maybe a
toStrictMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text
parseFragment)
  where
    parseScheme :: Parser Text
    parseScheme :: Parser Text
parseScheme = do
      Text
sch <- (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
':',Char
'/',Char
'@',Char
'.',Char
'[',Char
'*']) forall i a. Parser i a -> String -> Parser i a
<?> String
"scheme value"
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
sch forall a. Eq a => a -> a -> Bool
== Text
"localhost") (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"can't be localhost")
      forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
':') forall i a. Parser i a -> String -> Parser i a
<?> String
"scheme colon"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
sch
    parseSlashes :: Parser Bool
    parseSlashes :: Parser Bool
parseSlashes = do
      Maybe Text
mS <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Text -> Parser Text
string Text
"//") forall i a. Parser i a -> String -> Parser i a
<?> String
"slashes"
      case Maybe Text
mS of
        Maybe Text
P.Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        P.Just Text
_  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    parsePath :: Parser (Maybe (Vector Text))
    parsePath :: Parser (Maybe (Vector Text))
parsePath =
      let withRoot :: Parser (Maybe (Vector Text))
withRoot = do
            forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
'/') forall i a. Parser i a -> String -> Parser i a
<?> String
"root"
            (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
V.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser Text
parseChunkWithout [Char
'/', Char
'?', Char
'=', Char
'&', Char
'#'] forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Char -> Parser Char
char Char
'/') forall i a. Parser i a -> String -> Parser i a
<?> String
"path"
          withoutRoot :: Parser i (Maybe a)
withoutRoot = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing forall i a. Parser i a -> String -> Parser i a
<?> String
"empty path"
      in  Parser (Maybe (Vector Text))
withRoot forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {i} {a}. Parser i (Maybe a)
withoutRoot
    parseQuery :: Parser (Vector (Pair Text (Maybe Text)))
    parseQuery :: Parser (Vector (Pair Text (Maybe Text)))
parseQuery =
      ( do  forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
'?') forall i a. Parser i a -> String -> Parser i a
<?> String
"uri query init"
            let parse1 :: Parser Text (Pair Text (Maybe Text))
parse1 = do
                  Text
k <- String -> Parser Text
parseChunkWithout [Char
'=',Char
'&',Char
'#'] forall i a. Parser i a -> String -> Parser i a
<?> String
"uri query key"
                  Maybe Text
mV <- ( forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
'=') forall i a. Parser i a -> String -> Parser i a
<?> String
"uri query sep"
                                      String -> Parser Text
parseChunkWithout [Char
'&',Char
'#'] forall i a. Parser i a -> String -> Parser i a
<?> String
"uri query val"
                        ) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
k forall a b. a -> b -> Pair a b
:!: Maybe Text
mV)
            [Pair Text (Maybe Text)]
qs <- Parser Text (Pair Text (Maybe Text))
parse1 forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Char -> Parser Char
char Char
'&' forall i a. Parser i a -> String -> Parser i a
<?> String
"query params"
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> Vector a
V.fromList [Pair Text (Maybe Text)]
qs)
      ) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Vector a
V.empty
    parseFragment :: Parser Text
    parseFragment :: Parser Text
parseFragment = do
      forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
'#') forall i a. Parser i a -> String -> Parser i a
<?> String
"fragment init"
      String -> Parser Text
parseChunkWithout [] forall i a. Parser i a -> String -> Parser i a
<?> String
"fragment value"
    parseChunkWithout :: [Char] -> Parser Text
    parseChunkWithout :: String -> Parser Text
parseChunkWithout String
xs =
      (Char -> Bool) -> Parser Text
takeWhile (\Char
c -> Bool -> Bool
not (Char -> Bool
isControl Char
c Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
&& Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
xs)

    toStrictMaybe :: Maybe a -> Maybe a
toStrictMaybe Maybe a
P.Nothing = forall a. Maybe a
Nothing
    toStrictMaybe (P.Just a
x) = forall a. a -> Maybe a
Just a
x