{-# LANGUAGE QuasiQuotes #-}

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

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

-- * OAuth2 Configuration

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

-- | 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/|]
      }

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

-- * Tokens

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

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, Maybe AccessToken
Value -> Parser [AccessToken]
Value -> Parser AccessToken
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
omittedField :: Maybe AccessToken
$comittedField :: Maybe AccessToken
parseJSONList :: Value -> Parser [AccessToken]
$cparseJSONList :: Value -> Parser [AccessToken]
parseJSON :: Value -> Parser AccessToken
$cparseJSON :: Value -> Parser AccessToken
FromJSON, [AccessToken] -> Encoding
[AccessToken] -> Value
AccessToken -> Bool
AccessToken -> Encoding
AccessToken -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
omitField :: AccessToken -> Bool
$comitField :: AccessToken -> Bool
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, Maybe RefreshToken
Value -> Parser [RefreshToken]
Value -> Parser RefreshToken
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
omittedField :: Maybe RefreshToken
$comittedField :: Maybe RefreshToken
parseJSONList :: Value -> Parser [RefreshToken]
$cparseJSONList :: Value -> Parser [RefreshToken]
parseJSON :: Value -> Parser RefreshToken
$cparseJSON :: Value -> Parser RefreshToken
FromJSON, [RefreshToken] -> Encoding
[RefreshToken] -> Value
RefreshToken -> Bool
RefreshToken -> Encoding
RefreshToken -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
omitField :: RefreshToken -> Bool
$comitField :: RefreshToken -> Bool
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, Maybe IdToken
Value -> Parser [IdToken]
Value -> Parser IdToken
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
omittedField :: Maybe IdToken
$comittedField :: Maybe IdToken
parseJSONList :: Value -> Parser [IdToken]
$cparseJSONList :: Value -> Parser [IdToken]
parseJSON :: Value -> Parser IdToken
$cparseJSON :: Value -> Parser IdToken
FromJSON, [IdToken] -> Encoding
[IdToken] -> Value
IdToken -> Bool
IdToken -> Encoding
IdToken -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
omitField :: IdToken -> Bool
$comitField :: IdToken -> Bool
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, Maybe ExchangeToken
Value -> Parser [ExchangeToken]
Value -> Parser ExchangeToken
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
omittedField :: Maybe ExchangeToken
$comittedField :: Maybe ExchangeToken
parseJSONList :: Value -> Parser [ExchangeToken]
$cparseJSONList :: Value -> Parser [ExchangeToken]
parseJSON :: Value -> Parser ExchangeToken
$cparseJSON :: Value -> Parser ExchangeToken
FromJSON, [ExchangeToken] -> Encoding
[ExchangeToken] -> Value
ExchangeToken -> Bool
ExchangeToken -> Encoding
ExchangeToken -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
omitField :: ExchangeToken -> Bool
$comitField :: ExchangeToken -> Bool
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)

-- FIXME: rename to TokenResponse and move to that module

-- | 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 Authorization Request 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 Authorization Request and the provider supports OpenID protocol.
  }
  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
'_'}

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

-- * Client Authentication methods

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

-- | 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, I found I have to include authentication in the header all the time in real world.
--
-- In other words, `ClientSecretBasic` 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)

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

-- * Utilies for Request and URI

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

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

-- | Type sysnonym of request query params
type QueryParams = [(BS.ByteString, BS.ByteString)]

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 #-}