{-# LANGUAGE ExplicitForAll    #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}

-- | A simple http client to request OAuth2 tokens and several utils.

module Network.OAuth.OAuth2.HttpClient (
-- * Token management
  fetchAccessToken,
  fetchAccessToken2,
  fetchRefreshToken,
  refreshAccessToken,
  doJSONPostRequest,
  doFlexiblePostRequest,
  doSimplePostRequest,
-- * AUTH requests
  authGetJSON,
  authGetBS,
  authGetBS2,
  authPostJSON,
  authPostBS,
  authPostBS2,
  authPostBS3,
  authRequest,
-- * Utilities
  handleResponse,
  parseResponseJSON,
  parseResponseFlexible,
  updateRequestHeaders,
  setMethod
) where

import           Data.Aeson
import qualified Data.ByteString.Char8             as BS
import qualified Data.ByteString.Lazy.Char8        as BSL
import qualified Data.HashMap.Strict               as HM (fromList)
import           Data.Maybe
import qualified Data.Text.Encoding                as T
import           Network.HTTP.Conduit
import qualified Network.HTTP.Types                as HT
import           Network.HTTP.Types.URI            (parseQuery)
import           Network.OAuth.OAuth2.Internal
import qualified Network.OAuth.OAuth2.TokenRequest as TR
import           URI.ByteString

--------------------------------------------------
-- * Token management
--------------------------------------------------

-- | Request OAuth2 Token
--   method: POST
--   authenticate in header
fetchAccessToken :: Manager                                   -- ^ HTTP connection manager
                   -> OAuth2                                  -- ^ OAuth Data
                   -> ExchangeToken                           -- ^ OAuth 2 Tokens
                   -> IO (OAuth2Result TR.Errors OAuth2Token) -- ^ Access Token
fetchAccessToken manager oa code = doFlexiblePostRequest manager oa uri body
                           where (uri, body) = accessTokenUrl oa code

-- | Request OAuth2 Token
--   method: POST
--   authenticate in both header and body
fetchAccessToken2 :: Manager                                   -- ^ HTTP connection manager
                   -> OAuth2                                  -- ^ OAuth Data
                   -> ExchangeToken                           -- ^ OAuth 2 Tokens
                   -> IO (OAuth2Result TR.Errors OAuth2Token) -- ^ Access Token
fetchAccessToken2 mgr oa code = do
  let (url, body1) = accessTokenUrl oa code
  let extraBody = [ ("client_id", T.encodeUtf8 $ oauthClientId oa)
                  , ("client_secret", T.encodeUtf8 $ oauthClientSecret oa)
                  ]
  doFlexiblePostRequest mgr oa url (extraBody ++ body1)

-- | Request a new AccessToken with the Refresh Token.
refreshAccessToken :: Manager                         -- ^ HTTP connection manager.
                     -> OAuth2                       -- ^ OAuth context
                     -> RefreshToken                 -- ^ refresh token gained after authorization
                     -> IO (OAuth2Result TR.Errors OAuth2Token)
refreshAccessToken manager oa token = doFlexiblePostRequest manager oa uri body
                              where (uri, body) = refreshAccessTokenUrl oa token

{-# DEPRECATED fetchRefreshToken "Use refreshAccessToken since this method will be removed in future release" #-}
fetchRefreshToken :: Manager                         -- ^ HTTP connection manager.
                     -> OAuth2                       -- ^ OAuth context
                     -> RefreshToken                 -- ^ refresh token gained after authorization
                     -> IO (OAuth2Result TR.Errors OAuth2Token)
fetchRefreshToken = refreshAccessToken


-- | Conduct post request and return response as JSON.
doJSONPostRequest :: FromJSON err => FromJSON a
                  => Manager                             -- ^ HTTP connection manager.
                  -> OAuth2                              -- ^ OAuth options
                  -> URI                                 -- ^ The URL
                  -> PostBody                            -- ^ request body
                  -> IO (OAuth2Result err a)             -- ^ Response as JSON
doJSONPostRequest manager oa uri body = fmap parseResponseJSON (doSimplePostRequest manager oa uri body)

-- | Conduct post request and return response as JSON or Query String.
{-# DEPRECATED doFlexiblePostRequest "Use doJSONPostRequest since this function would be removed in future release." #-}
doFlexiblePostRequest :: FromJSON err => FromJSON a
                         => Manager                             -- ^ HTTP connection manager.
                         -> OAuth2                              -- ^ OAuth options
                         -> URI                                 -- ^ The URL
                         -> PostBody                            -- ^ request body
                         -> IO (OAuth2Result err a)             -- ^ Response as ByteString
doFlexiblePostRequest manager oa uri body = fmap parseResponseFlexible (doSimplePostRequest manager oa uri body)

-- | Conduct post request.
doSimplePostRequest :: FromJSON err => Manager                 -- ^ HTTP connection manager.
                       -> OAuth2                               -- ^ OAuth options
                       -> URI                                  -- ^ URL
                       -> PostBody                             -- ^ Request body.
                       -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString
doSimplePostRequest manager oa url body = fmap handleResponse go
                                  where go = do
                                             req <- uriToRequest url
                                             let addBasicAuth = applyBasicAuth (T.encodeUtf8 $ oauthClientId oa) (T.encodeUtf8 $ oauthClientSecret oa)
                                                 req' = (addBasicAuth . updateRequestHeaders Nothing) req
                                             httpLbs (urlEncodedBody body req') manager

--------------------------------------------------
-- * AUTH requests
--------------------------------------------------

-- | Conduct an authorized GET request and return response as JSON.
authGetJSON :: FromJSON err => FromJSON a
                 => Manager                 -- ^ HTTP connection manager.
                 -> AccessToken
                 -> URI
                 -> IO (OAuth2Result err a) -- ^ Response as JSON
authGetJSON manager t uri = parseResponseJSON <$> authGetBS manager t uri

-- | Conduct an authorized GET request.
authGetBS :: FromJSON err => Manager                 -- ^ HTTP connection manager.
             -> AccessToken
             -> URI
             -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString
authGetBS manager token url = do
  req <- uriToRequest url
  authRequest req upReq manager
  where upReq = updateRequestHeaders (Just token) . setMethod HT.GET

-- | same to 'authGetBS' but set access token to query parameter rather than header
authGetBS2 :: FromJSON err => Manager                -- ^ HTTP connection manager.
             -> AccessToken
             -> URI
             -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString
authGetBS2 manager token url = do
  req <- uriToRequest (url `appendAccessToken` token)
  -- print $ queryString req
  authRequest req upReq manager
  where upReq = updateRequestHeaders Nothing . setMethod HT.GET

-- | Conduct POST request and return response as JSON.
authPostJSON :: FromJSON err => FromJSON a
                 => Manager                 -- ^ HTTP connection manager.
                 -> AccessToken
                 -> URI
                 -> PostBody
                 -> IO (OAuth2Result err a) -- ^ Response as JSON
authPostJSON manager t uri pb = parseResponseJSON <$> authPostBS manager t uri pb

-- | Conduct POST request.
authPostBS :: FromJSON err => Manager                -- ^ HTTP connection manager.
             -> AccessToken
             -> URI
             -> PostBody
             -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString
authPostBS manager token url pb = do
  req <- uriToRequest url
  authRequest req upReq manager
  where upBody = urlEncodedBody (pb ++ accessTokenToParam token)
        upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST
        upReq = upHeaders . upBody

-- | Conduct POST request with access token in the request body rather header
authPostBS2 :: FromJSON err => Manager               -- ^ HTTP connection manager.
             -> AccessToken
             -> URI
             -> PostBody
             -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString
authPostBS2 manager token url pb = do
  req <- uriToRequest url
  authRequest req upReq manager
  where upBody = urlEncodedBody (pb ++ accessTokenToParam token)
        upHeaders = updateRequestHeaders Nothing . setMethod HT.POST
        upReq = upHeaders . upBody

-- | Conduct POST request with access token in the header and null in body
authPostBS3 :: FromJSON err => Manager               -- ^ HTTP connection manager.
             -> AccessToken
             -> URI
             -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString
authPostBS3 manager token url = do
  req <- uriToRequest url
  authRequest req upReq manager
  where upBody req = req { requestBody = "null" }
        upHeaders = updateRequestHeaders (Just token) . setMethod HT.POST
        upReq = upHeaders . upBody

-- |Send an HTTP request including the Authorization header with the specified
--  access token.
--
authRequest :: FromJSON err => Request          -- ^ Request to perform
               -> (Request -> Request)          -- ^ Modify request before sending
               -> Manager                       -- ^ HTTP connection manager.
               -> IO (OAuth2Result err BSL.ByteString)
authRequest req upReq manager = fmap handleResponse (httpLbs (upReq req) manager)

--------------------------------------------------
-- * Utilities
--------------------------------------------------

-- | Parses a @Response@ to to @OAuth2Result@
handleResponse :: FromJSON err => Response BSL.ByteString -> OAuth2Result err BSL.ByteString
handleResponse rsp =
    if HT.statusIsSuccessful (responseStatus rsp)
        then Right $ responseBody rsp
        else Left $ parseOAuth2Error (responseBody rsp)

-- | Parses a @OAuth2Result BSL.ByteString@ into @FromJSON a => a@
parseResponseJSON :: FromJSON err => FromJSON a
              => OAuth2Result err BSL.ByteString
              -> OAuth2Result err a
parseResponseJSON (Left b) = Left b
parseResponseJSON (Right b) = case eitherDecode b of
                            Left e  -> Left $ mkDecodeOAuth2Error b e
                            Right x -> Right x

-- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String
parseResponseString :: FromJSON err => FromJSON a
              => OAuth2Result err BSL.ByteString
              -> OAuth2Result err a
parseResponseString (Left b) = Left b
parseResponseString (Right b) = case parseQuery $ BSL.toStrict b of
                              [] -> Left errorMessage
                              a -> case fromJSON $ queryToValue a of
                                    Error _   -> Left errorMessage
                                    Success x -> Right x
  where
    queryToValue = Object . HM.fromList . map paramToPair
    paramToPair (k, mv) = (T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv)
    errorMessage = parseOAuth2Error b

-- | Try 'parseResponseJSON', if failed then parses the @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String.
parseResponseFlexible :: FromJSON err => FromJSON a
                         => OAuth2Result err BSL.ByteString
                         -> OAuth2Result err a
parseResponseFlexible r = case parseResponseJSON r of
                           Left _ -> parseResponseString r
                           x      -> x

-- | Set several header values:
--   + userAgennt    : `hoauth2`
--   + accept        : `application/json`
--   + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided.
updateRequestHeaders :: Maybe AccessToken -> Request -> Request
updateRequestHeaders t req =
  let extras = [ (HT.hUserAgent, "hoauth2")
               , (HT.hAccept, "application/json") ]
      bearer = [(HT.hAuthorization, "Bearer " `BS.append` T.encodeUtf8 (fromJust (fmap atoken t))) | isJust t]
      headers = bearer ++ extras ++ requestHeaders req
  in
  req { requestHeaders = headers }

-- | Set the HTTP method to use.
setMethod :: HT.StdMethod -> Request -> Request
setMethod m req = req { method = HT.renderStdMethod m }