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

module Data.URI.Auth where

import Data.URI.Auth.Host (URIAuthHost, parseURIAuthHost, printURIAuthHost)

import Prelude hiding (Maybe (..), maybe)
import qualified Prelude as P
import Data.Strict.Maybe (Maybe (..), maybe)
import Data.Text (Text)
import Data.Word (Word16)
import qualified Data.Text as T
import Data.Attoparsec.Text ( Parser, char, decimal, takeWhile1, (<?>))
import Control.Monad (void)
import Control.Applicative (optional)

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


data URIAuth = URIAuth
  { URIAuth -> Maybe Text
uriAuthUser     :: !(Maybe Text) -- ^ a designated user - @ssh://git\@github.com@ is @git@
  , URIAuth -> Maybe Text
uriAuthPassword :: !(Maybe Text) -- ^ a designated password (this field is depricated in RFC 3986, passwords with an at-character will not parse) - @https://user:password\@github.com@ is @password@
  , URIAuth -> URIAuthHost
uriAuthHost     :: !URIAuthHost
  , URIAuth -> Maybe Word16
uriAuthPort     :: !(Maybe Word16) -- ^ the port, if it exists - @foobar.com:3000@ is @3000@ as a 16-bit unsigned int.
  } deriving (Int -> URIAuth -> ShowS
[URIAuth] -> ShowS
URIAuth -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [URIAuth] -> ShowS
$cshowList :: [URIAuth] -> ShowS
show :: URIAuth -> String
$cshow :: URIAuth -> String
showsPrec :: Int -> URIAuth -> ShowS
$cshowsPrec :: Int -> URIAuth -> ShowS
Show, URIAuth -> URIAuth -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URIAuth -> URIAuth -> Bool
$c/= :: URIAuth -> URIAuth -> Bool
== :: URIAuth -> URIAuth -> Bool
$c== :: URIAuth -> URIAuth -> Bool
Eq, Typeable, 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
$cto :: forall x. Rep URIAuth x -> URIAuth
$cfrom :: forall x. URIAuth -> Rep URIAuth x
Generic)

instance Arbitrary URIAuth where
  arbitrary :: Gen URIAuth
arbitrary = do
    Maybe Text
mUser <- Gen (Maybe Text)
arbitraryUser
    Maybe Text
mPassword <- if Maybe Text
mUser forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
arbitraryNonEmptyText
    URIAuthHost
host <- forall a. Arbitrary a => Gen a
arbitrary
    Maybe Word16
mPort <- Gen (Maybe Word16)
arbitraryPort
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Maybe Text -> URIAuthHost -> Maybe Word16 -> URIAuth
URIAuth Maybe Text
mUser Maybe Text
mPassword URIAuthHost
host Maybe Word16
mPort)
    where
      arbitraryUser :: Gen (Maybe Text)
arbitraryUser = 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]
      arbitraryPort :: Gen (Maybe Word16)
arbitraryPort = 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
<$> forall a. Arbitrary a => Gen a
arbitrary]
      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'])


-- | Prints the URI auth but omits the password even if present.
printURIAuth :: URIAuth -> Text
printURIAuth :: URIAuth -> Text
printURIAuth URIAuth{Maybe Word16
Maybe Text
URIAuthHost
uriAuthPort :: Maybe Word16
uriAuthHost :: URIAuthHost
uriAuthPassword :: Maybe Text
uriAuthUser :: Maybe Text
uriAuthPort :: URIAuth -> Maybe Word16
uriAuthHost :: URIAuth -> URIAuthHost
uriAuthPassword :: URIAuth -> Maybe Text
uriAuthUser :: URIAuth -> Maybe Text
..} =
     ( case Maybe Text
uriAuthPassword of
         Maybe Text
Nothing -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (forall a. Semigroup a => a -> a -> a
<> Text
"@") Maybe Text
uriAuthUser
         Just Text
p -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
":" (forall a. Semigroup a => a -> a -> a
<> Text
":") Maybe Text
uriAuthUser forall a. Semigroup a => a -> a -> a
<> Text
p forall a. Semigroup a => a -> a -> a
<> Text
"@"
     )
  forall a. Semigroup a => a -> a -> a
<> URIAuthHost -> Text
printURIAuthHost URIAuthHost
uriAuthHost
  forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\Word16
p -> Text
":" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Word16
p)) Maybe Word16
uriAuthPort


parseURIAuth :: Parser URIAuth
parseURIAuth :: Parser URIAuth
parseURIAuth = do
  let withPassword :: Parser Text Text
withPassword = do
        forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
':')
        Parser Text Text
parsePassword
      hasUsernameOrPassword :: Parser Text (Maybe Text, Maybe Text)
hasUsernameOrPassword = do
        Maybe Text
u <- forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
parseUser
        Maybe Text
p <- 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 Text
withPassword
        forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
'@')
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text
u,Maybe Text
p)
  (Maybe Text
u,Maybe Text
p) <- do
    Maybe (Maybe Text, Maybe Text)
mUP <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text (Maybe Text, Maybe Text)
hasUsernameOrPassword
    case Maybe (Maybe Text, Maybe Text)
mUP of
      Maybe (Maybe Text, Maybe Text)
P.Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
      P.Just (Maybe Text, Maybe Text)
xs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text, Maybe Text)
xs
  Maybe Text -> Maybe Text -> URIAuthHost -> Maybe Word16 -> URIAuth
URIAuth Maybe Text
u
          Maybe Text
p
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser URIAuthHost
parseURIAuthHost
          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 Word16
parsePort)
  where
    parseUser :: Parser Text Text
parseUser = (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
'?',Char
'&',Char
'=',Char
'[']) forall i a. Parser i a -> String -> Parser i a
<?> String
"user value"
    parsePassword :: Parser Text Text
parsePassword = (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
'?',Char
'&',Char
'=',Char
'[']) forall i a. Parser i a -> String -> Parser i a
<?> String
"password value"
    parsePort :: Parser Text Word16
parsePort = 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
"port delimiter"
      forall a. Integral a => Parser a
decimal

    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