{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}

module Network.OAuth.OAuth2.Internal where

import Control.Arrow (second)
import Control.Monad.Catch
import Data.Aeson
import Data.Aeson.Types (Parser, explicitParseFieldMaybe)
import Data.Binary (Binary)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.Default
import Data.Maybe
import Data.Text (Text, unpack)
import Data.Version (showVersion)
import GHC.Generics
import Lens.Micro
import Lens.Micro.Extras
import Network.HTTP.Conduit as C
import Network.HTTP.Types qualified as H
import Network.HTTP.Types qualified as HT
import Paths_hoauth2 (version)
import URI.ByteString
import URI.ByteString.Aeson ()
import URI.ByteString.QQ

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

-- * Data Types

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

-- | Query Parameter Representation
data OAuth2 = OAuth2
  { OAuth2 -> Text
oauth2ClientId :: Text
  , OAuth2 -> Text
oauth2ClientSecret :: Text
  , OAuth2 -> URIRef Absolute
oauth2AuthorizeEndpoint :: URIRef Absolute
  , OAuth2 -> URIRef Absolute
oauth2TokenEndpoint :: URIRef Absolute
  , OAuth2 -> URIRef Absolute
oauth2RedirectUri :: URIRef Absolute
  }
  deriving (Int -> OAuth2 -> ShowS
[OAuth2] -> ShowS
OAuth2 -> String
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
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)

instance Default OAuth2 where
  def :: OAuth2
def =
    OAuth2
      { oauth2ClientId :: Text
oauth2ClientId = Text
""
      , oauth2ClientSecret :: Text
oauth2ClientSecret = Text
""
      , oauth2AuthorizeEndpoint :: URIRef Absolute
oauth2AuthorizeEndpoint = [uri|https://www.example.com/|]
      , oauth2TokenEndpoint :: URIRef Absolute
oauth2TokenEndpoint = [uri|https://www.example.com/|]
      , oauth2RedirectUri :: URIRef Absolute
oauth2RedirectUri = [uri|https://www.example.com/|]
      }

newtype AccessToken = AccessToken {AccessToken -> Text
atoken :: Text} deriving (Get AccessToken
[AccessToken] -> Put
AccessToken -> Put
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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)

-- | Authorization Code
newtype ExchangeToken = ExchangeToken {ExchangeToken -> Text
extoken :: Text} deriving (Int -> ExchangeToken -> ShowS
[ExchangeToken] -> ShowS
ExchangeToken -> String
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
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
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)

-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4
data OAuth2Token = OAuth2Token
  { OAuth2Token -> AccessToken
accessToken :: AccessToken
  , OAuth2Token -> Maybe RefreshToken
refreshToken :: Maybe RefreshToken
  -- ^ Exists when @offline_access@ scope is in the 'authorizeUrl' and the provider supports Refresh Access Token.
  , OAuth2Token -> Maybe Int
expiresIn :: Maybe Int
  , OAuth2Token -> Maybe Text
tokenType :: Maybe Text
  -- ^ See https://www.rfc-editor.org/rfc/rfc6749#section-5.1. It's required per spec. But OAuth2 provider implementation are vary. Maybe will remove 'Maybe' in future release.
  , OAuth2Token -> Maybe IdToken
idToken :: Maybe IdToken
  -- ^ Exists when @openid@ scope is in the 'authorizeUrl' and the provider supports OpenID.
  }
  deriving (OAuth2Token -> OAuth2Token -> Bool
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
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. 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

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

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

-- | https://www.rfc-editor.org/rfc/rfc6749#section-2.3
-- According to spec:
--
-- The client MUST NOT use more than one authentication method in each request.
--
-- Which means use Authorization header or Post body.
--
-- However, in reality, I always have to include authentication in the header.
--
-- In other words, 'ClientSecrectBasic' is always assured. 'ClientSecretPost' is optional.
--
-- Maybe consider an alternative implementation that boolean kind of data type is good enough.
data ClientAuthenticationMethod
  = ClientSecretBasic
  | ClientSecretPost
  | ClientAssertionJwt
  deriving (ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
$c/= :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
== :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
$c== :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
Eq, Eq ClientAuthenticationMethod
ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
ClientAuthenticationMethod
-> ClientAuthenticationMethod -> Ordering
ClientAuthenticationMethod
-> ClientAuthenticationMethod -> ClientAuthenticationMethod
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ClientAuthenticationMethod
-> ClientAuthenticationMethod -> ClientAuthenticationMethod
$cmin :: ClientAuthenticationMethod
-> ClientAuthenticationMethod -> ClientAuthenticationMethod
max :: ClientAuthenticationMethod
-> ClientAuthenticationMethod -> ClientAuthenticationMethod
$cmax :: ClientAuthenticationMethod
-> ClientAuthenticationMethod -> ClientAuthenticationMethod
>= :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
$c>= :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
> :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
$c> :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
<= :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
$c<= :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
< :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
$c< :: ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
compare :: ClientAuthenticationMethod
-> ClientAuthenticationMethod -> Ordering
$ccompare :: ClientAuthenticationMethod
-> ClientAuthenticationMethod -> Ordering
Ord)

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

-- * Types Synonym

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

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

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

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

-- * Utilies

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

defaultRequestHeaders :: [(HT.HeaderName, BS.ByteString)]
defaultRequestHeaders :: [(HeaderName, ByteString)]
defaultRequestHeaders =
  [ (HeaderName
HT.hUserAgent, ByteString
"hoauth2-" forall a. Semigroup a => a -> a -> a
<> String -> ByteString
BS8.pack (Version -> String
showVersion Version
version))
  , (HeaderName
HT.hAccept, ByteString
"application/json")
  ]

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

uriToRequest :: MonadThrow m => URI -> m Request
uriToRequest :: forall (m :: * -> *). MonadThrow m => URIRef Absolute -> m Request
uriToRequest URIRef Absolute
auri = do
  Bool
ssl <- case forall a s. Getting a s a -> s -> a
view (Lens' (URIRef Absolute) Scheme
uriSchemeL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Scheme ByteString
schemeBSL) URIRef Absolute
auri of
    ByteString
"http" -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    ByteString
"https" -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    ByteString
s -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> String -> HttpException
InvalidUrlException (forall a. Show a => a -> String
show URIRef Absolute
auri) (String
"Invalid scheme: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
s)
  let query :: [(ByteString, Maybe ByteString)]
query = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. a -> Maybe a
Just) (forall a s. Getting a s a -> s -> a
view (forall a. Lens' (URIRef a) Query
queryL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Query [(ByteString, ByteString)]
queryPairsL) URIRef Absolute
auri)
      hostL :: (ByteString -> Const (First ByteString) ByteString)
-> URIRef a -> Const (First ByteString) (URIRef a)
hostL = forall a. Lens' (URIRef a) (Maybe Authority)
authorityL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Authority Host
authorityHostL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Host ByteString
hostBSL
      portL :: (Int -> Const (First Int) Int)
-> URIRef a -> Const (First Int) (URIRef a)
portL = forall a. Lens' (URIRef a) (Maybe Authority)
authorityL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Authority (Maybe Port)
authorityPortL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$
          Request
defaultRequest
            { secure :: Bool
secure = Bool
ssl
            , path :: ByteString
path = forall a s. Getting a s a -> s -> a
view forall a. Lens' (URIRef a) ByteString
pathL URIRef Absolute
auri
            }
      req2 :: Request
req2 = (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' Request ByteString
hostLens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting (First a) s a -> s -> Maybe a
preview forall {a}.
(ByteString -> Const (First ByteString) ByteString)
-> URIRef a -> Const (First ByteString) (URIRef a)
hostL) URIRef Absolute
auri Request
req
      req3 :: Request
req3 = (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' Request Int
portLens forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe Int
defaultPort) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting (First a) s a -> s -> Maybe a
preview forall {a}.
(Int -> Const (First Int) Int)
-> URIRef a -> Const (First Int) (URIRef a)
portL) URIRef Absolute
auri Request
req2
  forall (m :: * -> *) a. Monad m => a -> m a
return Request
req3

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

hostLens :: Lens' Request BS.ByteString
hostLens :: Lens' Request ByteString
hostLens ByteString -> f ByteString
f Request
req = ByteString -> f ByteString
f (Request -> ByteString
C.host Request
req) 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 :: Lens' Request Int
portLens Int -> f Int
f Request
req = Int -> f Int
f (Request -> Int
C.port Request
req) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Int
p' -> Request
req {port :: Int
C.port = Int
p'}
{-# INLINE portLens #-}