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

module Data.URI where

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

import           Control.Applicative       (optional, (<|>))
import           Control.Monad             (void, when)
import           Data.Attoparsec.Text      (Parser, char, sepBy, string,
                                            takeWhile, takeWhile1, (<?>))
import           Data.Char                 (isControl, isSpace)
import           Data.Strict.Maybe         (Maybe (..), isJust, 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           Prelude                   hiding (Maybe (..), maybe, takeWhile)
import qualified Prelude                   as P

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


data DirOrFile = Dir | File
  deriving (Int -> DirOrFile -> ShowS
[DirOrFile] -> ShowS
DirOrFile -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DirOrFile] -> ShowS
$cshowList :: [DirOrFile] -> ShowS
show :: DirOrFile -> String
$cshow :: DirOrFile -> String
showsPrec :: Int -> DirOrFile -> ShowS
$cshowsPrec :: Int -> DirOrFile -> ShowS
Show, DirOrFile -> DirOrFile -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DirOrFile -> DirOrFile -> Bool
$c/= :: DirOrFile -> DirOrFile -> Bool
== :: DirOrFile -> DirOrFile -> Bool
$c== :: DirOrFile -> DirOrFile -> Bool
Eq, Typeable, forall x. Rep DirOrFile x -> DirOrFile
forall x. DirOrFile -> Rep DirOrFile x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DirOrFile x -> DirOrFile
$cfrom :: forall x. DirOrFile -> Rep DirOrFile x
Generic)

instance Arbitrary DirOrFile where
  arbitrary :: Gen DirOrFile
arbitrary = forall a. [Gen a] -> Gen a
oneof [forall (f :: * -> *) a. Applicative f => a -> f a
pure DirOrFile
Dir, forall (f :: * -> *) a. Applicative f => a -> f a
pure DirOrFile
File]

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, DirOrFile)
uriPath      :: !(Maybe (Vector Text, DirOrFile)) -- ^ slash-separated list - @https://hackage.haskell.org/foo@ is @["foo"]@, second value is if the path has a trailing slash
  , 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 = do
    URIAuth
auth <- forall a. Arbitrary a => Gen a
arbitrary
    Maybe Text
scheme <- if forall a. Maybe a -> Bool
isJust (URIAuth -> Maybe Text
uriAuthPassword URIAuth
auth)
      then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
arbitraryNonEmptyText
      else Gen (Maybe Text)
arbitraryScheme
    Bool
slashes <- forall a. Arbitrary a => Gen a
arbitrary
    Maybe (Vector Text, DirOrFile)
path <- Gen (Maybe (Vector Text, DirOrFile))
arbitraryPath
    Vector (Pair Text (Maybe Text))
query <- Gen (Vector (Pair Text (Maybe Text)))
arbitraryQuery
    Maybe Text
fragment <- Gen (Maybe Text)
arbitraryScheme
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe Text
-> Bool
-> URIAuth
-> Maybe (Vector Text, DirOrFile)
-> Vector (Pair Text (Maybe Text))
-> Maybe Text
-> URI
URI Maybe Text
scheme Bool
slashes URIAuth
auth Maybe (Vector Text, DirOrFile)
path Vector (Pair Text (Maybe Text))
query Maybe Text
fragment
    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, DirOrFile))
arbitraryPath =
        forall a. [Gen a] -> Gen a
oneof
          [ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          , do
              Vector Text
xs <- 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
              DirOrFile
y <- forall a. Arbitrary a => Gen a
arbitrary
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Vector Text
xs, DirOrFile
y)
          ]
      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 (Vector Text, DirOrFile)
Maybe Text
Vector (Pair Text (Maybe Text))
URIAuth
uriFragment :: Maybe Text
uriQuery :: Vector (Pair Text (Maybe Text))
uriPath :: Maybe (Vector Text, DirOrFile)
uriAuthority :: URIAuth
uriSlashes :: Bool
uriScheme :: Maybe Text
uriFragment :: URI -> Maybe Text
uriQuery :: URI -> Vector (Pair Text (Maybe Text))
uriPath :: URI -> Maybe (Vector Text, DirOrFile)
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, DirOrFile)
uriPath of
         Just (Vector Text
xs, DirOrFile
f) -> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"/" (forall a. Vector a -> [a]
V.toList Vector Text
xs) forall a. Semigroup a => a -> a -> a
<> (if DirOrFile
f forall a. Eq a => a -> a -> Bool
== DirOrFile
Dir Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Vector Text
xs) then Text
"/" else Text
"")
         Maybe (Vector Text, DirOrFile)
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, DirOrFile)
-> 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, DirOrFile))
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, DirOrFile))
    parsePath :: Parser (Maybe (Vector Text, DirOrFile))
parsePath =
      let withRoot :: Parser (Maybe (Vector Text, DirOrFile))
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"
            (
              do
                Vector Text
xs <- 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 (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                  if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Vector Text
xs) Bool -> Bool -> Bool
&& forall a. Vector a -> a
V.last Vector Text
xs forall a. Eq a => a -> a -> Bool
== Text
""
                  then (forall a. Vector a -> Vector a
V.init Vector Text
xs, DirOrFile
Dir)
                  else (Vector Text
xs, DirOrFile
File)
              ) 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, DirOrFile))
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