{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_HADDOCK -ignore-exports #-}

-- | A simple OAuth2 Haskell binding.  (This is supposed to be
-- independent of the http client used.)
module Network.OAuth.OAuth2.Internal where

import Control.Applicative
import Control.Arrow (second)
import Control.Monad.Catch
import Data.Aeson
import Data.Aeson.Types (Parser, explicitParseFieldMaybe)
import Data.Binary (Binary)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Maybe
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding
import GHC.Generics
import Lens.Micro
import Lens.Micro.Extras
import Network.HTTP.Conduit as C
import qualified Network.HTTP.Types as H
import URI.ByteString
import URI.ByteString.Aeson ()

--------------------------------------------------

-- * Data Types

--------------------------------------------------

-- | Query Parameter Representation
data OAuth2 = OAuth2
  { OAuth2 -> Text
oauthClientId :: Text,
    OAuth2 -> Maybe Text
oauthClientSecret :: Maybe Text,
    OAuth2 -> URI
oauthOAuthorizeEndpoint :: URI,
    OAuth2 -> URI
oauthAccessTokenEndpoint :: URI,
    OAuth2 -> Maybe URI
oauthCallback :: Maybe URI
  }
  deriving (Int -> OAuth2 -> ShowS
[OAuth2] -> ShowS
OAuth2 -> String
(Int -> OAuth2 -> ShowS)
-> (OAuth2 -> String) -> ([OAuth2] -> ShowS) -> Show OAuth2
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OAuth2] -> ShowS
$cshowList :: [OAuth2] -> ShowS
show :: OAuth2 -> String
$cshow :: OAuth2 -> String
showsPrec :: Int -> OAuth2 -> ShowS
$cshowsPrec :: Int -> OAuth2 -> ShowS
Show, OAuth2 -> OAuth2 -> Bool
(OAuth2 -> OAuth2 -> Bool)
-> (OAuth2 -> OAuth2 -> Bool) -> Eq OAuth2
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OAuth2 -> OAuth2 -> Bool
$c/= :: OAuth2 -> OAuth2 -> Bool
== :: OAuth2 -> OAuth2 -> Bool
$c== :: OAuth2 -> OAuth2 -> Bool
Eq)

newtype AccessToken = AccessToken {AccessToken -> Text
atoken :: Text} deriving (Get AccessToken
[AccessToken] -> Put
AccessToken -> Put
(AccessToken -> Put)
-> Get AccessToken -> ([AccessToken] -> Put) -> Binary AccessToken
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [AccessToken] -> Put
$cputList :: [AccessToken] -> Put
get :: Get AccessToken
$cget :: Get AccessToken
put :: AccessToken -> Put
$cput :: AccessToken -> Put
Binary, AccessToken -> AccessToken -> Bool
(AccessToken -> AccessToken -> Bool)
-> (AccessToken -> AccessToken -> Bool) -> Eq AccessToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AccessToken -> AccessToken -> Bool
$c/= :: AccessToken -> AccessToken -> Bool
== :: AccessToken -> AccessToken -> Bool
$c== :: AccessToken -> AccessToken -> Bool
Eq, Int -> AccessToken -> ShowS
[AccessToken] -> ShowS
AccessToken -> String
(Int -> AccessToken -> ShowS)
-> (AccessToken -> String)
-> ([AccessToken] -> ShowS)
-> Show AccessToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AccessToken] -> ShowS
$cshowList :: [AccessToken] -> ShowS
show :: AccessToken -> String
$cshow :: AccessToken -> String
showsPrec :: Int -> AccessToken -> ShowS
$cshowsPrec :: Int -> AccessToken -> ShowS
Show, Value -> Parser [AccessToken]
Value -> Parser AccessToken
(Value -> Parser AccessToken)
-> (Value -> Parser [AccessToken]) -> FromJSON AccessToken
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [AccessToken]
$cparseJSONList :: Value -> Parser [AccessToken]
parseJSON :: Value -> Parser AccessToken
$cparseJSON :: Value -> Parser AccessToken
FromJSON, [AccessToken] -> Encoding
[AccessToken] -> Value
AccessToken -> Encoding
AccessToken -> Value
(AccessToken -> Value)
-> (AccessToken -> Encoding)
-> ([AccessToken] -> Value)
-> ([AccessToken] -> Encoding)
-> ToJSON AccessToken
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [AccessToken] -> Encoding
$ctoEncodingList :: [AccessToken] -> Encoding
toJSONList :: [AccessToken] -> Value
$ctoJSONList :: [AccessToken] -> Value
toEncoding :: AccessToken -> Encoding
$ctoEncoding :: AccessToken -> Encoding
toJSON :: AccessToken -> Value
$ctoJSON :: AccessToken -> Value
ToJSON)

newtype RefreshToken = RefreshToken {RefreshToken -> Text
rtoken :: Text} deriving (Get RefreshToken
[RefreshToken] -> Put
RefreshToken -> Put
(RefreshToken -> Put)
-> Get RefreshToken
-> ([RefreshToken] -> Put)
-> Binary RefreshToken
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [RefreshToken] -> Put
$cputList :: [RefreshToken] -> Put
get :: Get RefreshToken
$cget :: Get RefreshToken
put :: RefreshToken -> Put
$cput :: RefreshToken -> Put
Binary, RefreshToken -> RefreshToken -> Bool
(RefreshToken -> RefreshToken -> Bool)
-> (RefreshToken -> RefreshToken -> Bool) -> Eq RefreshToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RefreshToken -> RefreshToken -> Bool
$c/= :: RefreshToken -> RefreshToken -> Bool
== :: RefreshToken -> RefreshToken -> Bool
$c== :: RefreshToken -> RefreshToken -> Bool
Eq, Int -> RefreshToken -> ShowS
[RefreshToken] -> ShowS
RefreshToken -> String
(Int -> RefreshToken -> ShowS)
-> (RefreshToken -> String)
-> ([RefreshToken] -> ShowS)
-> Show RefreshToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RefreshToken] -> ShowS
$cshowList :: [RefreshToken] -> ShowS
show :: RefreshToken -> String
$cshow :: RefreshToken -> String
showsPrec :: Int -> RefreshToken -> ShowS
$cshowsPrec :: Int -> RefreshToken -> ShowS
Show, Value -> Parser [RefreshToken]
Value -> Parser RefreshToken
(Value -> Parser RefreshToken)
-> (Value -> Parser [RefreshToken]) -> FromJSON RefreshToken
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RefreshToken]
$cparseJSONList :: Value -> Parser [RefreshToken]
parseJSON :: Value -> Parser RefreshToken
$cparseJSON :: Value -> Parser RefreshToken
FromJSON, [RefreshToken] -> Encoding
[RefreshToken] -> Value
RefreshToken -> Encoding
RefreshToken -> Value
(RefreshToken -> Value)
-> (RefreshToken -> Encoding)
-> ([RefreshToken] -> Value)
-> ([RefreshToken] -> Encoding)
-> ToJSON RefreshToken
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RefreshToken] -> Encoding
$ctoEncodingList :: [RefreshToken] -> Encoding
toJSONList :: [RefreshToken] -> Value
$ctoJSONList :: [RefreshToken] -> Value
toEncoding :: RefreshToken -> Encoding
$ctoEncoding :: RefreshToken -> Encoding
toJSON :: RefreshToken -> Value
$ctoJSON :: RefreshToken -> Value
ToJSON)

newtype IdToken = IdToken {IdToken -> Text
idtoken :: Text} deriving (Get IdToken
[IdToken] -> Put
IdToken -> Put
(IdToken -> Put)
-> Get IdToken -> ([IdToken] -> Put) -> Binary IdToken
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [IdToken] -> Put
$cputList :: [IdToken] -> Put
get :: Get IdToken
$cget :: Get IdToken
put :: IdToken -> Put
$cput :: IdToken -> Put
Binary, IdToken -> IdToken -> Bool
(IdToken -> IdToken -> Bool)
-> (IdToken -> IdToken -> Bool) -> Eq IdToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IdToken -> IdToken -> Bool
$c/= :: IdToken -> IdToken -> Bool
== :: IdToken -> IdToken -> Bool
$c== :: IdToken -> IdToken -> Bool
Eq, Int -> IdToken -> ShowS
[IdToken] -> ShowS
IdToken -> String
(Int -> IdToken -> ShowS)
-> (IdToken -> String) -> ([IdToken] -> ShowS) -> Show IdToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IdToken] -> ShowS
$cshowList :: [IdToken] -> ShowS
show :: IdToken -> String
$cshow :: IdToken -> String
showsPrec :: Int -> IdToken -> ShowS
$cshowsPrec :: Int -> IdToken -> ShowS
Show, Value -> Parser [IdToken]
Value -> Parser IdToken
(Value -> Parser IdToken)
-> (Value -> Parser [IdToken]) -> FromJSON IdToken
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [IdToken]
$cparseJSONList :: Value -> Parser [IdToken]
parseJSON :: Value -> Parser IdToken
$cparseJSON :: Value -> Parser IdToken
FromJSON, [IdToken] -> Encoding
[IdToken] -> Value
IdToken -> Encoding
IdToken -> Value
(IdToken -> Value)
-> (IdToken -> Encoding)
-> ([IdToken] -> Value)
-> ([IdToken] -> Encoding)
-> ToJSON IdToken
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [IdToken] -> Encoding
$ctoEncodingList :: [IdToken] -> Encoding
toJSONList :: [IdToken] -> Value
$ctoJSONList :: [IdToken] -> Value
toEncoding :: IdToken -> Encoding
$ctoEncoding :: IdToken -> Encoding
toJSON :: IdToken -> Value
$ctoJSON :: IdToken -> Value
ToJSON)

newtype ExchangeToken = ExchangeToken {ExchangeToken -> Text
extoken :: Text} deriving (Int -> ExchangeToken -> ShowS
[ExchangeToken] -> ShowS
ExchangeToken -> String
(Int -> ExchangeToken -> ShowS)
-> (ExchangeToken -> String)
-> ([ExchangeToken] -> ShowS)
-> Show ExchangeToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExchangeToken] -> ShowS
$cshowList :: [ExchangeToken] -> ShowS
show :: ExchangeToken -> String
$cshow :: ExchangeToken -> String
showsPrec :: Int -> ExchangeToken -> ShowS
$cshowsPrec :: Int -> ExchangeToken -> ShowS
Show, Value -> Parser [ExchangeToken]
Value -> Parser ExchangeToken
(Value -> Parser ExchangeToken)
-> (Value -> Parser [ExchangeToken]) -> FromJSON ExchangeToken
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ExchangeToken]
$cparseJSONList :: Value -> Parser [ExchangeToken]
parseJSON :: Value -> Parser ExchangeToken
$cparseJSON :: Value -> Parser ExchangeToken
FromJSON, [ExchangeToken] -> Encoding
[ExchangeToken] -> Value
ExchangeToken -> Encoding
ExchangeToken -> Value
(ExchangeToken -> Value)
-> (ExchangeToken -> Encoding)
-> ([ExchangeToken] -> Value)
-> ([ExchangeToken] -> Encoding)
-> ToJSON ExchangeToken
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ExchangeToken] -> Encoding
$ctoEncodingList :: [ExchangeToken] -> Encoding
toJSONList :: [ExchangeToken] -> Value
$ctoJSONList :: [ExchangeToken] -> Value
toEncoding :: ExchangeToken -> Encoding
$ctoEncoding :: ExchangeToken -> Encoding
toJSON :: ExchangeToken -> Value
$ctoJSON :: ExchangeToken -> Value
ToJSON)

-- | The gained Access Token. Use @Data.Aeson.decode@ to
-- decode string to @AccessToken@.  The @refreshToken@ is
-- special in some cases,
-- e.g. <https://developers.google.com/accounts/docs/OAuth2>
data OAuth2Token = OAuth2Token
  { OAuth2Token -> AccessToken
accessToken :: AccessToken,
    OAuth2Token -> Maybe RefreshToken
refreshToken :: Maybe RefreshToken,
    OAuth2Token -> Maybe Int
expiresIn :: Maybe Int,
    OAuth2Token -> Maybe Text
tokenType :: Maybe Text,
    OAuth2Token -> Maybe IdToken
idToken :: Maybe IdToken
  }
  deriving (OAuth2Token -> OAuth2Token -> Bool
(OAuth2Token -> OAuth2Token -> Bool)
-> (OAuth2Token -> OAuth2Token -> Bool) -> Eq OAuth2Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OAuth2Token -> OAuth2Token -> Bool
$c/= :: OAuth2Token -> OAuth2Token -> Bool
== :: OAuth2Token -> OAuth2Token -> Bool
$c== :: OAuth2Token -> OAuth2Token -> Bool
Eq, Int -> OAuth2Token -> ShowS
[OAuth2Token] -> ShowS
OAuth2Token -> String
(Int -> OAuth2Token -> ShowS)
-> (OAuth2Token -> String)
-> ([OAuth2Token] -> ShowS)
-> Show OAuth2Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OAuth2Token] -> ShowS
$cshowList :: [OAuth2Token] -> ShowS
show :: OAuth2Token -> String
$cshow :: OAuth2Token -> String
showsPrec :: Int -> OAuth2Token -> ShowS
$cshowsPrec :: Int -> OAuth2Token -> ShowS
Show, (forall x. OAuth2Token -> Rep OAuth2Token x)
-> (forall x. Rep OAuth2Token x -> OAuth2Token)
-> Generic OAuth2Token
forall x. Rep OAuth2Token x -> OAuth2Token
forall x. OAuth2Token -> Rep OAuth2Token x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OAuth2Token x -> OAuth2Token
$cfrom :: forall x. OAuth2Token -> Rep OAuth2Token x
Generic)

instance Binary OAuth2Token

parseIntFlexible :: Value -> Parser Int
parseIntFlexible :: Value -> Parser Int
parseIntFlexible (String Text
s) = Int -> Parser Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Parser Int) -> (String -> Int) -> String -> Parser Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. Read a => String -> a
read (String -> Parser Int) -> String -> Parser Int
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
s
parseIntFlexible Value
v = Value -> Parser Int
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

-- | Parse JSON data into 'OAuth2Token'
instance FromJSON OAuth2Token where
  parseJSON :: Value -> Parser OAuth2Token
parseJSON = String
-> (Object -> Parser OAuth2Token) -> Value -> Parser OAuth2Token
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"OAuth2Token" ((Object -> Parser OAuth2Token) -> Value -> Parser OAuth2Token)
-> (Object -> Parser OAuth2Token) -> Value -> Parser OAuth2Token
forall a b. (a -> b) -> a -> b
$ \Object
v ->
    AccessToken
-> Maybe RefreshToken
-> Maybe Int
-> Maybe Text
-> Maybe IdToken
-> OAuth2Token
OAuth2Token
      (AccessToken
 -> Maybe RefreshToken
 -> Maybe Int
 -> Maybe Text
 -> Maybe IdToken
 -> OAuth2Token)
-> Parser AccessToken
-> Parser
     (Maybe RefreshToken
      -> Maybe Int -> Maybe Text -> Maybe IdToken -> OAuth2Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser AccessToken
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"access_token"
      Parser
  (Maybe RefreshToken
   -> Maybe Int -> Maybe Text -> Maybe IdToken -> OAuth2Token)
-> Parser (Maybe RefreshToken)
-> Parser (Maybe Int -> Maybe Text -> Maybe IdToken -> OAuth2Token)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe RefreshToken)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"refresh_token"
      Parser (Maybe Int -> Maybe Text -> Maybe IdToken -> OAuth2Token)
-> Parser (Maybe Int)
-> Parser (Maybe Text -> Maybe IdToken -> OAuth2Token)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value -> Parser Int) -> Object -> Text -> Parser (Maybe Int)
forall a. (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)
explicitParseFieldMaybe Value -> Parser Int
parseIntFlexible Object
v Text
"expires_in"
      Parser (Maybe Text -> Maybe IdToken -> OAuth2Token)
-> Parser (Maybe Text) -> Parser (Maybe IdToken -> OAuth2Token)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"token_type"
      Parser (Maybe IdToken -> OAuth2Token)
-> Parser (Maybe IdToken) -> Parser OAuth2Token
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe IdToken)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"id_token"

instance ToJSON OAuth2Token where
  toJSON :: OAuth2Token -> Value
toJSON = Options -> OAuth2Token -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions {fieldLabelModifier :: ShowS
fieldLabelModifier = Char -> ShowS
camelTo2 Char
'_'}
  toEncoding :: OAuth2Token -> Encoding
toEncoding = Options -> OAuth2Token -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions {fieldLabelModifier :: ShowS
fieldLabelModifier = Char -> ShowS
camelTo2 Char
'_'}

data OAuth2Error a = OAuth2Error
  { OAuth2Error a -> Either Text a
error :: Either Text a,
    OAuth2Error a -> Maybe Text
errorDescription :: Maybe Text,
    OAuth2Error a -> Maybe URI
errorUri :: Maybe (URIRef Absolute)
  }
  deriving (Int -> OAuth2Error a -> ShowS
[OAuth2Error a] -> ShowS
OAuth2Error a -> String
(Int -> OAuth2Error a -> ShowS)
-> (OAuth2Error a -> String)
-> ([OAuth2Error a] -> ShowS)
-> Show (OAuth2Error a)
forall a. Show a => Int -> OAuth2Error a -> ShowS
forall a. Show a => [OAuth2Error a] -> ShowS
forall a. Show a => OAuth2Error a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OAuth2Error a] -> ShowS
$cshowList :: forall a. Show a => [OAuth2Error a] -> ShowS
show :: OAuth2Error a -> String
$cshow :: forall a. Show a => OAuth2Error a -> String
showsPrec :: Int -> OAuth2Error a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> OAuth2Error a -> ShowS
Show, OAuth2Error a -> OAuth2Error a -> Bool
(OAuth2Error a -> OAuth2Error a -> Bool)
-> (OAuth2Error a -> OAuth2Error a -> Bool) -> Eq (OAuth2Error a)
forall a. Eq a => OAuth2Error a -> OAuth2Error a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OAuth2Error a -> OAuth2Error a -> Bool
$c/= :: forall a. Eq a => OAuth2Error a -> OAuth2Error a -> Bool
== :: OAuth2Error a -> OAuth2Error a -> Bool
$c== :: forall a. Eq a => OAuth2Error a -> OAuth2Error a -> Bool
Eq, (forall x. OAuth2Error a -> Rep (OAuth2Error a) x)
-> (forall x. Rep (OAuth2Error a) x -> OAuth2Error a)
-> Generic (OAuth2Error a)
forall x. Rep (OAuth2Error a) x -> OAuth2Error a
forall x. OAuth2Error a -> Rep (OAuth2Error a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (OAuth2Error a) x -> OAuth2Error a
forall a x. OAuth2Error a -> Rep (OAuth2Error a) x
$cto :: forall a x. Rep (OAuth2Error a) x -> OAuth2Error a
$cfrom :: forall a x. OAuth2Error a -> Rep (OAuth2Error a) x
Generic)

instance FromJSON err => FromJSON (OAuth2Error err) where
  parseJSON :: Value -> Parser (OAuth2Error err)
parseJSON (Object Object
a) =
    do
      Either Text err
err <- (Object
a Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"error") Parser Value
-> (Value -> Parser (Either Text err)) -> Parser (Either Text err)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Value
str -> err -> Either Text err
forall a b. b -> Either a b
Right (err -> Either Text err) -> Parser err -> Parser (Either Text err)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser err
forall a. FromJSON a => Value -> Parser a
parseJSON Value
str Parser (Either Text err)
-> Parser (Either Text err) -> Parser (Either Text err)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Either Text err
forall a b. a -> Either a b
Left (Text -> Either Text err)
-> Parser Text -> Parser (Either Text err)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON Value
str)
      Maybe Text
desc <- Object
a Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"error_description"
      Maybe URI
uri <- Object
a Object -> Text -> Parser (Maybe URI)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"error_uri"
      OAuth2Error err -> Parser (OAuth2Error err)
forall (m :: * -> *) a. Monad m => a -> m a
return (OAuth2Error err -> Parser (OAuth2Error err))
-> OAuth2Error err -> Parser (OAuth2Error err)
forall a b. (a -> b) -> a -> b
$ Either Text err -> Maybe Text -> Maybe URI -> OAuth2Error err
forall a. Either Text a -> Maybe Text -> Maybe URI -> OAuth2Error a
OAuth2Error Either Text err
err Maybe Text
desc Maybe URI
uri
  parseJSON Value
_ = String -> Parser (OAuth2Error err)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected an object"

instance ToJSON err => ToJSON (OAuth2Error err) where
  toJSON :: OAuth2Error err -> Value
toJSON = Options -> OAuth2Error err -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions {constructorTagModifier :: ShowS
constructorTagModifier = Char -> ShowS
camelTo2 Char
'_', allNullaryToStringTag :: Bool
allNullaryToStringTag = Bool
True}
  toEncoding :: OAuth2Error err -> Encoding
toEncoding = Options -> OAuth2Error err -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions {constructorTagModifier :: ShowS
constructorTagModifier = Char -> ShowS
camelTo2 Char
'_', allNullaryToStringTag :: Bool
allNullaryToStringTag = Bool
True}

parseOAuth2Error :: FromJSON err => BSL.ByteString -> OAuth2Error err
parseOAuth2Error :: ByteString -> OAuth2Error err
parseOAuth2Error ByteString
string =
  (String -> OAuth2Error err)
-> (OAuth2Error err -> OAuth2Error err)
-> Either String (OAuth2Error err)
-> OAuth2Error err
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> String -> OAuth2Error err
forall err. ByteString -> String -> OAuth2Error err
mkDecodeOAuth2Error ByteString
string) OAuth2Error err -> OAuth2Error err
forall a. a -> a
id (ByteString -> Either String (OAuth2Error err)
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
string)

mkDecodeOAuth2Error :: BSL.ByteString -> String -> OAuth2Error err
mkDecodeOAuth2Error :: ByteString -> String -> OAuth2Error err
mkDecodeOAuth2Error ByteString
response String
err =
  Either Text err -> Maybe Text -> Maybe URI -> OAuth2Error err
forall a. Either Text a -> Maybe Text -> Maybe URI -> OAuth2Error a
OAuth2Error
    (Text -> Either Text err
forall a b. a -> Either a b
Left Text
"Decode error")
    (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n Original Response:\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict ByteString
response))
    Maybe URI
forall a. Maybe a
Nothing

--------------------------------------------------

-- * Types Synonym

--------------------------------------------------

-- | Is either 'Left' containing an error or 'Right' containg a result
type OAuth2Result err a = Either (OAuth2Error err) a

-- | type synonym of post body content
type PostBody = [(BS.ByteString, BS.ByteString)]

type QueryParams = [(BS.ByteString, BS.ByteString)]

--------------------------------------------------

-- * URLs

--------------------------------------------------

-- | Prepare the authorization URL.  Redirect to this URL
-- asking for user interactive authentication.
authorizationUrl :: OAuth2 -> URI
authorizationUrl :: OAuth2 -> URI
authorizationUrl OAuth2
oa = ASetter
  URI URI [(ByteString, ByteString)] [(ByteString, ByteString)]
-> ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> URI
-> URI
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Query -> Identity Query) -> URI -> Identity URI
forall a. Lens' (URIRef a) Query
queryL ((Query -> Identity Query) -> URI -> Identity URI)
-> (([(ByteString, ByteString)]
     -> Identity [(ByteString, ByteString)])
    -> Query -> Identity Query)
-> ASetter
     URI URI [(ByteString, ByteString)] [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(ByteString, ByteString)] -> Identity [(ByteString, ByteString)])
-> Query -> Identity Query
Lens' Query [(ByteString, ByteString)]
queryPairsL) ([(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(ByteString, ByteString)]
queryParts) (OAuth2 -> URI
oauthOAuthorizeEndpoint OAuth2
oa)
  where
    queryParts :: [(ByteString, ByteString)]
queryParts =
      [Maybe (ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [Maybe a] -> [a]
catMaybes
        [ (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
"client_id", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ OAuth2 -> Text
oauthClientId OAuth2
oa),
          (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
"response_type", ByteString
"code"),
          (URI -> (ByteString, ByteString))
-> Maybe URI -> Maybe (ByteString, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ByteString
"redirect_uri",) (ByteString -> (ByteString, ByteString))
-> (URI -> ByteString) -> URI -> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef') (OAuth2 -> Maybe URI
oauthCallback OAuth2
oa)
        ]

-- | Prepare the URL and the request body query for fetching an access token.
accessTokenUrl ::
  OAuth2 ->
  -- | access code gained via authorization URL
  ExchangeToken ->
  -- | access token request URL plus the request body.
  (URI, PostBody)
accessTokenUrl :: OAuth2 -> ExchangeToken -> (URI, [(ByteString, ByteString)])
accessTokenUrl OAuth2
oa ExchangeToken
code = OAuth2
-> ExchangeToken -> Maybe Text -> (URI, [(ByteString, ByteString)])
accessTokenUrl' OAuth2
oa ExchangeToken
code (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"authorization_code")

-- | Prepare the URL and the request body query for fetching an access token, with
-- optional grant type.
accessTokenUrl' ::
  OAuth2 ->
  -- | access code gained via authorization URL
  ExchangeToken ->
  -- | Grant Type
  Maybe Text ->
  -- | access token request URL plus the request body.
  (URI, PostBody)
accessTokenUrl' :: OAuth2
-> ExchangeToken -> Maybe Text -> (URI, [(ByteString, ByteString)])
accessTokenUrl' OAuth2
oa ExchangeToken
code Maybe Text
gt = (URI
uri, [(ByteString, ByteString)]
body)
  where
    uri :: URI
uri = OAuth2 -> URI
oauthAccessTokenEndpoint OAuth2
oa
    body :: [(ByteString, ByteString)]
body =
      [Maybe (ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [Maybe a] -> [a]
catMaybes
        [ (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
"code", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ ExchangeToken -> Text
extoken ExchangeToken
code),
          (ByteString
"redirect_uri",) (ByteString -> (ByteString, ByteString))
-> (URI -> ByteString) -> URI -> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef' (URI -> (ByteString, ByteString))
-> Maybe URI -> Maybe (ByteString, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OAuth2 -> Maybe URI
oauthCallback OAuth2
oa,
          (Text -> (ByteString, ByteString))
-> Maybe Text -> Maybe (ByteString, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ByteString
"grant_type",) (ByteString -> (ByteString, ByteString))
-> (Text -> ByteString) -> Text -> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8) Maybe Text
gt
        ]

-- | Using a Refresh Token.  Obtain a new access token by
-- sending a refresh token to the Authorization server.
refreshAccessTokenUrl ::
  OAuth2 ->
  -- | refresh token gained via authorization URL
  RefreshToken ->
  -- | refresh token request URL plus the request body.
  (URI, PostBody)
refreshAccessTokenUrl :: OAuth2 -> RefreshToken -> (URI, [(ByteString, ByteString)])
refreshAccessTokenUrl OAuth2
oa RefreshToken
token = (URI
uri, [(ByteString, ByteString)]
body)
  where
    uri :: URI
uri = OAuth2 -> URI
oauthAccessTokenEndpoint OAuth2
oa
    body :: [(ByteString, ByteString)]
body =
      [ (ByteString
"grant_type", ByteString
"refresh_token"),
        (ByteString
"refresh_token", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ RefreshToken -> Text
rtoken RefreshToken
token)
      ]

-- | For `GET` method API.
appendAccessToken ::
  -- | Base URI
  URIRef a ->
  -- | Authorized Access Token
  AccessToken ->
  -- | Combined Result
  URIRef a
appendAccessToken :: URIRef a -> AccessToken -> URIRef a
appendAccessToken URIRef a
uri AccessToken
t = ASetter
  (URIRef a)
  (URIRef a)
  [(ByteString, ByteString)]
  [(ByteString, ByteString)]
-> ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> URIRef a
-> URIRef a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Query -> Identity Query) -> URIRef a -> Identity (URIRef a)
forall a. Lens' (URIRef a) Query
queryL ((Query -> Identity Query) -> URIRef a -> Identity (URIRef a))
-> (([(ByteString, ByteString)]
     -> Identity [(ByteString, ByteString)])
    -> Query -> Identity Query)
-> ASetter
     (URIRef a)
     (URIRef a)
     [(ByteString, ByteString)]
     [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(ByteString, ByteString)] -> Identity [(ByteString, ByteString)])
-> Query -> Identity Query
Lens' Query [(ByteString, ByteString)]
queryPairsL) (\[(ByteString, ByteString)]
query -> [(ByteString, ByteString)]
query [(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a] -> [a]
++ AccessToken -> [(ByteString, ByteString)]
accessTokenToParam AccessToken
t) URIRef a
uri

-- | Create 'QueryParams' with given access token value.
accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)]
accessTokenToParam :: AccessToken -> [(ByteString, ByteString)]
accessTokenToParam AccessToken
t = [(ByteString
"access_token", Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ AccessToken -> Text
atoken AccessToken
t)]

appendQueryParams :: [(BS.ByteString, BS.ByteString)] -> URIRef a -> URIRef a
appendQueryParams :: [(ByteString, ByteString)] -> URIRef a -> URIRef a
appendQueryParams [(ByteString, ByteString)]
params =
  ASetter
  (URIRef a)
  (URIRef a)
  [(ByteString, ByteString)]
  [(ByteString, ByteString)]
-> ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> URIRef a
-> URIRef a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Query -> Identity Query) -> URIRef a -> Identity (URIRef a)
forall a. Lens' (URIRef a) Query
queryL ((Query -> Identity Query) -> URIRef a -> Identity (URIRef a))
-> (([(ByteString, ByteString)]
     -> Identity [(ByteString, ByteString)])
    -> Query -> Identity Query)
-> ASetter
     (URIRef a)
     (URIRef a)
     [(ByteString, ByteString)]
     [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(ByteString, ByteString)] -> Identity [(ByteString, ByteString)])
-> Query -> Identity Query
Lens' Query [(ByteString, ByteString)]
queryPairsL) ([(ByteString, ByteString)]
params [(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a] -> [a]
++)

uriToRequest :: MonadThrow m => URI -> m Request
uriToRequest :: URI -> m Request
uriToRequest URI
uri = do
  Bool
ssl <- case Getting ByteString URI ByteString -> URI -> ByteString
forall a s. Getting a s a -> s -> a
view ((Scheme -> Const ByteString Scheme) -> URI -> Const ByteString URI
Lens' URI Scheme
uriSchemeL ((Scheme -> Const ByteString Scheme)
 -> URI -> Const ByteString URI)
-> ((ByteString -> Const ByteString ByteString)
    -> Scheme -> Const ByteString Scheme)
-> Getting ByteString URI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Const ByteString ByteString)
-> Scheme -> Const ByteString Scheme
Lens' Scheme ByteString
schemeBSL) URI
uri of
    ByteString
"http" -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    ByteString
"https" -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    ByteString
s -> HttpException -> m Bool
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HttpException -> m Bool) -> HttpException -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> String -> HttpException
InvalidUrlException (URI -> String
forall a. Show a => a -> String
show URI
uri) (String
"Invalid scheme: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
s)
  let query :: [(ByteString, Maybe ByteString)]
query = ((ByteString, ByteString) -> (ByteString, Maybe ByteString))
-> [(ByteString, ByteString)] -> [(ByteString, Maybe ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ByteString -> Maybe ByteString)
-> (ByteString, ByteString) -> (ByteString, Maybe ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just) (Getting [(ByteString, ByteString)] URI [(ByteString, ByteString)]
-> URI -> [(ByteString, ByteString)]
forall a s. Getting a s a -> s -> a
view ((Query -> Const [(ByteString, ByteString)] Query)
-> URI -> Const [(ByteString, ByteString)] URI
forall a. Lens' (URIRef a) Query
queryL ((Query -> Const [(ByteString, ByteString)] Query)
 -> URI -> Const [(ByteString, ByteString)] URI)
-> (([(ByteString, ByteString)]
     -> Const [(ByteString, ByteString)] [(ByteString, ByteString)])
    -> Query -> Const [(ByteString, ByteString)] Query)
-> Getting
     [(ByteString, ByteString)] URI [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(ByteString, ByteString)]
 -> Const [(ByteString, ByteString)] [(ByteString, ByteString)])
-> Query -> Const [(ByteString, ByteString)] Query
Lens' Query [(ByteString, ByteString)]
queryPairsL) URI
uri)
      hostL :: (ByteString -> Const (First ByteString) ByteString)
-> URIRef a -> Const (First ByteString) (URIRef a)
hostL = (Maybe Authority -> Const (First ByteString) (Maybe Authority))
-> URIRef a -> Const (First ByteString) (URIRef a)
forall a. Lens' (URIRef a) (Maybe Authority)
authorityL ((Maybe Authority -> Const (First ByteString) (Maybe Authority))
 -> URIRef a -> Const (First ByteString) (URIRef a))
-> ((ByteString -> Const (First ByteString) ByteString)
    -> Maybe Authority -> Const (First ByteString) (Maybe Authority))
-> (ByteString -> Const (First ByteString) ByteString)
-> URIRef a
-> Const (First ByteString) (URIRef a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Authority -> Const (First ByteString) Authority)
-> Maybe Authority -> Const (First ByteString) (Maybe Authority)
forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just ((Authority -> Const (First ByteString) Authority)
 -> Maybe Authority -> Const (First ByteString) (Maybe Authority))
-> ((ByteString -> Const (First ByteString) ByteString)
    -> Authority -> Const (First ByteString) Authority)
-> (ByteString -> Const (First ByteString) ByteString)
-> Maybe Authority
-> Const (First ByteString) (Maybe Authority)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Host -> Const (First ByteString) Host)
-> Authority -> Const (First ByteString) Authority
Lens' Authority Host
authorityHostL ((Host -> Const (First ByteString) Host)
 -> Authority -> Const (First ByteString) Authority)
-> ((ByteString -> Const (First ByteString) ByteString)
    -> Host -> Const (First ByteString) Host)
-> (ByteString -> Const (First ByteString) ByteString)
-> Authority
-> Const (First ByteString) Authority
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Const (First ByteString) ByteString)
-> Host -> Const (First ByteString) Host
Lens' Host ByteString
hostBSL
      portL :: (Int -> Const (First Int) Int)
-> URIRef a -> Const (First Int) (URIRef a)
portL = (Maybe Authority -> Const (First Int) (Maybe Authority))
-> URIRef a -> Const (First Int) (URIRef a)
forall a. Lens' (URIRef a) (Maybe Authority)
authorityL ((Maybe Authority -> Const (First Int) (Maybe Authority))
 -> URIRef a -> Const (First Int) (URIRef a))
-> ((Int -> Const (First Int) Int)
    -> Maybe Authority -> Const (First Int) (Maybe Authority))
-> (Int -> Const (First Int) Int)
-> URIRef a
-> Const (First Int) (URIRef a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Authority -> Const (First Int) Authority)
-> Maybe Authority -> Const (First Int) (Maybe Authority)
forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just ((Authority -> Const (First Int) Authority)
 -> Maybe Authority -> Const (First Int) (Maybe Authority))
-> ((Int -> Const (First Int) Int)
    -> Authority -> Const (First Int) Authority)
-> (Int -> Const (First Int) Int)
-> Maybe Authority
-> Const (First Int) (Maybe Authority)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Port -> Const (First Int) (Maybe Port))
-> Authority -> Const (First Int) Authority
Lens' Authority (Maybe Port)
authorityPortL ((Maybe Port -> Const (First Int) (Maybe Port))
 -> Authority -> Const (First Int) Authority)
-> ((Int -> Const (First Int) Int)
    -> Maybe Port -> Const (First Int) (Maybe Port))
-> (Int -> Const (First Int) Int)
-> Authority
-> Const (First Int) Authority
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Port -> Const (First Int) Port)
-> Maybe Port -> Const (First Int) (Maybe Port)
forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just ((Port -> Const (First Int) Port)
 -> Maybe Port -> Const (First Int) (Maybe Port))
-> ((Int -> Const (First Int) Int)
    -> Port -> Const (First Int) Port)
-> (Int -> Const (First Int) Int)
-> Maybe Port
-> Const (First Int) (Maybe Port)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const (First Int) Int) -> Port -> Const (First Int) Port
Lens' Port Int
portNumberL
      defaultPort :: Int
defaultPort = (if Bool
ssl then Int
443 else Int
80) :: Int

      req :: Request
req =
        [(ByteString, Maybe ByteString)] -> Request -> Request
setQueryString [(ByteString, Maybe ByteString)]
query (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$
          Request
defaultRequest
            { secure :: Bool
secure = Bool
ssl,
              path :: ByteString
path = Getting ByteString URI ByteString -> URI -> ByteString
forall a s. Getting a s a -> s -> a
view Getting ByteString URI ByteString
forall a. Lens' (URIRef a) ByteString
pathL URI
uri
            }
      req2 :: Request
req2 = (ASetter Request Request ByteString ByteString
-> (ByteString -> ByteString) -> Request -> Request
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Request Request ByteString ByteString
Lens' Request ByteString
hostLens ((ByteString -> ByteString) -> Request -> Request)
-> (URI -> ByteString -> ByteString) -> URI -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString)
-> (ByteString -> ByteString -> ByteString)
-> Maybe ByteString
-> ByteString
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString -> ByteString
forall a. a -> a
id ByteString -> ByteString -> ByteString
forall a b. a -> b -> a
const (Maybe ByteString -> ByteString -> ByteString)
-> (URI -> Maybe ByteString) -> URI -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First ByteString) URI ByteString
-> URI -> Maybe ByteString
forall a s. Getting (First a) s a -> s -> Maybe a
preview Getting (First ByteString) URI ByteString
forall a.
(ByteString -> Const (First ByteString) ByteString)
-> URIRef a -> Const (First ByteString) (URIRef a)
hostL) URI
uri Request
req
      req3 :: Request
req3 = (ASetter Request Request Int Int
-> (Int -> Int) -> Request -> Request
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Request Request Int Int
Lens' Request Int
portLens ((Int -> Int) -> Request -> Request)
-> (URI -> Int -> Int) -> URI -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a b. a -> b -> a
const (Int -> Int -> Int)
-> (Maybe Int -> Int) -> Maybe Int -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
defaultPort) (Maybe Int -> Int -> Int)
-> (URI -> Maybe Int) -> URI -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Int) URI Int -> URI -> Maybe Int
forall a s. Getting (First a) s a -> s -> Maybe a
preview Getting (First Int) URI Int
forall a.
(Int -> Const (First Int) Int)
-> URIRef a -> Const (First Int) (URIRef a)
portL) URI
uri Request
req2
  Request -> m Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req3

requestToUri :: Request -> URI
requestToUri :: Request -> URI
requestToUri Request
req =
  Scheme
-> Maybe Authority
-> ByteString
-> Query
-> Maybe ByteString
-> URI
URI
    ( ByteString -> Scheme
Scheme
        ( if Request -> Bool
secure Request
req
            then ByteString
"https"
            else ByteString
"http"
        )
    )
    (Authority -> Maybe Authority
forall a. a -> Maybe a
Just (Maybe UserInfo -> Host -> Maybe Port -> Authority
Authority Maybe UserInfo
forall a. Maybe a
Nothing (ByteString -> Host
Host (ByteString -> Host) -> ByteString -> Host
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
host Request
req) (Port -> Maybe Port
forall a. a -> Maybe a
Just (Port -> Maybe Port) -> Port -> Maybe Port
forall a b. (a -> b) -> a -> b
$ Int -> Port
Port (Int -> Port) -> Int -> Port
forall a b. (a -> b) -> a -> b
$ Request -> Int
port Request
req)))
    (Request -> ByteString
path Request
req)
    ([(ByteString, ByteString)] -> Query
Query ([(ByteString, ByteString)] -> Query)
-> [(ByteString, ByteString)] -> Query
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)]
H.parseSimpleQuery (ByteString -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
queryString Request
req)
    Maybe ByteString
forall a. Maybe a
Nothing

hostLens :: Lens' Request BS.ByteString
hostLens :: (ByteString -> f ByteString) -> Request -> f Request
hostLens ByteString -> f ByteString
f Request
req = ByteString -> f ByteString
f (Request -> ByteString
C.host Request
req) f ByteString -> (ByteString -> Request) -> f Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ByteString
h' -> Request
req {host :: ByteString
C.host = ByteString
h'}
{-# INLINE hostLens #-}

portLens :: Lens' Request Int
portLens :: (Int -> f Int) -> Request -> f Request
portLens Int -> f Int
f Request
req = Int -> f Int
f (Request -> Int
C.port Request
req) f Int -> (Int -> Request) -> f Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Int
p' -> Request
req {port :: Int
C.port = Int
p'}
{-# INLINE portLens #-}