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

module Data.URI.Auth.Host where

import Prelude hiding (Either (..))

import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Text (Text)
import qualified Data.Text as T
import Data.Attoparsec.Text (Parser, char, sepBy1, takeWhile1, (<?>))
import Control.Monad (void)
import Control.Applicative ((<|>))
import Net.Types (IPv4, IPv6)
import qualified Net.Types as NetTypes
import qualified Net.IPv4 as IPv4
import qualified Net.IPv6 as IPv6

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




data URIAuthHost
  = Glob
  | IPv4 !IPv4
  | IPv6 !IPv6
  | Localhost
  | -- | @Host ["foo","bar"] "com"@ represents @foo.bar.com@
    Host
      { URIAuthHost -> Vector Text
uriAuthHostName   :: !(Vector Text)
      , URIAuthHost -> Text
uriAuthHostSuffix :: !Text
      } deriving (Int -> URIAuthHost -> ShowS
[URIAuthHost] -> ShowS
URIAuthHost -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [URIAuthHost] -> ShowS
$cshowList :: [URIAuthHost] -> ShowS
show :: URIAuthHost -> [Char]
$cshow :: URIAuthHost -> [Char]
showsPrec :: Int -> URIAuthHost -> ShowS
$cshowsPrec :: Int -> URIAuthHost -> ShowS
Show, URIAuthHost -> URIAuthHost -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URIAuthHost -> URIAuthHost -> Bool
$c/= :: URIAuthHost -> URIAuthHost -> Bool
== :: URIAuthHost -> URIAuthHost -> Bool
$c== :: URIAuthHost -> URIAuthHost -> Bool
Eq, Typeable, forall x. Rep URIAuthHost x -> URIAuthHost
forall x. URIAuthHost -> Rep URIAuthHost x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep URIAuthHost x -> URIAuthHost
$cfrom :: forall x. URIAuthHost -> Rep URIAuthHost x
Generic)

instance Arbitrary URIAuthHost where
  arbitrary :: Gen URIAuthHost
arbitrary = forall a. [Gen a] -> Gen a
oneof
    [ forall (f :: * -> *) a. Applicative f => a -> f a
pure URIAuthHost
Glob
    , IPv4 -> URIAuthHost
IPv4 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen IPv4
arbitraryIPv4
    , IPv6 -> URIAuthHost
IPv6 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen IPv6
arbitraryIPv6
    , forall (f :: * -> *) a. Applicative f => a -> f a
pure URIAuthHost
Localhost
    , Vector Text -> Text -> URIAuthHost
Host forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. Gen a -> Gen (Vector a)
arbitraryNonEmptyVector Gen Text
arbitraryNonEmptyText
           forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Text
arbitraryNonEmptyText
    ]
    where
      arbitraryNonEmptyText :: Gen Text
arbitraryNonEmptyText = [Char] -> 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'])
      arbitraryNonEmptyVector :: Gen a -> Gen (Vector a)
arbitraryNonEmptyVector Gen a
x = 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 a
x
      arbitraryIPv4 :: Gen IPv4
arbitraryIPv4 = Word32 -> IPv4
NetTypes.IPv4 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
      arbitraryIPv6 :: Gen IPv6
arbitraryIPv6 = Word16
-> Word16
-> Word16
-> Word16
-> Word16
-> Word16
-> Word16
-> Word16
-> IPv6
IPv6.ipv6 forall (f :: * -> *) a b. Functor 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
<*> 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
<*> 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
<*> 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

printURIAuthHost :: URIAuthHost -> Text
printURIAuthHost :: URIAuthHost -> Text
printURIAuthHost URIAuthHost
x = case URIAuthHost
x of
  URIAuthHost
Glob -> Text
"*"
  IPv4 IPv4
l4 -> IPv4 -> Text
IPv4.encode IPv4
l4
  IPv6 IPv6
r6 -> Text
"[" forall a. Semigroup a => a -> a -> a
<> IPv6 -> Text
IPv6.encode IPv6
r6 forall a. Semigroup a => a -> a -> a
<> Text
"]"
  URIAuthHost
Localhost -> Text
"localhost"
  Host Vector Text
ns Text
c -> Text -> [Text] -> Text
T.intercalate Text
"." (forall a. Vector a -> [a]
V.toList (Vector Text
ns forall a. Vector a -> a -> Vector a
`V.snoc` Text
c))


parseURIAuthHost :: Parser URIAuthHost
parseURIAuthHost :: Parser URIAuthHost
parseURIAuthHost =
      (IPv4 -> URIAuthHost
IPv4 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser IPv4
IPv4.parser)
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (IPv6 -> URIAuthHost
IPv6 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text IPv6
ipv6')
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser URIAuthHost
parseHost
  where
    ipv6' :: Parser Text IPv6
ipv6' = do
      forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
'[') forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"init ipv6"
      IPv6
x <- Parser Text IPv6
IPv6.parser
      forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
']') forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"end ipv6"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure IPv6
x
    parseHost :: Parser URIAuthHost
    parseHost :: Parser URIAuthHost
parseHost = do
      let hostChunk :: Parser Text Text
hostChunk = (Char -> Bool) -> Parser Text Text
takeWhile1 (\Char
c -> Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'.',Char
':',Char
'/',Char
'?',Char
'#']) forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"host chunk"
          hostChunks :: Parser Text [Text]
hostChunks = Parser Text Text
hostChunk forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Char -> Parser Char
char Char
'.' forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"host chunks"
      xss :: [Text]
xss@(Text
x:[Text]
xs) <- Parser Text [Text]
hostChunks
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
xs
        then case () of
               ()
_ | Text
x forall a. Eq a => a -> a -> Bool
== Text
"localhost" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure URIAuthHost
Localhost
                 | Text
x forall a. Eq a => a -> a -> Bool
== Text
"*" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure URIAuthHost
Glob
                 | Bool
otherwise -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Only one term parsed: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Text]
xss)
        else let xss' :: Vector Text
                 xss' :: Vector Text
xss' = forall a. [a] -> Vector a
V.fromList [Text]
xss
                 unsnoc :: Vector a -> (Vector a, a)
                 unsnoc :: forall a. Vector a -> (Vector a, a)
unsnoc Vector a
x' =
                   let (Vector a
fs,Vector a
l) = forall a. Int -> Vector a -> (Vector a, Vector a)
V.splitAt (forall a. Vector a -> Int
V.length Vector a
x' forall a. Num a => a -> a -> a
- Int
1) Vector a
x'
                   in  (Vector a
fs, Vector a
l forall a. Vector a -> Int -> a
V.! Int
0)
                 (Vector Text
ns,Text
c) = forall a. Vector a -> (Vector a, a)
unsnoc Vector Text
xss'
             in  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vector Text -> Text -> URIAuthHost
Host Vector Text
ns Text
c)