{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} module Network.HTTP.Req.OAuth2.Internal.Util ( acceptLanguage , evalOAuth2 , hasResponseStatus , oAuth2AuthHeader , oAuth2BearerHeader , oAuth2PostRaw , runOAuth2 ) where import Control.Monad.Trans.State.Strict (evalStateT, runStateT) import Data.Aeson (Value) import qualified Data.ByteString as ByteString (append, concat) import qualified Data.ByteString.Base64 as Base64 (encode) import Data.Default.Class (def) import qualified Data.Text.Encoding as Text (encodeUtf8) import qualified Network.HTTP.Client as HTTP (HttpException(..), HttpExceptionContent(..), responseStatus) import Network.HTTP.Req ( FormUrlEncodedParam , HttpException(..) , Option , POST(..) , ReqBodyUrlEnc(..) , Scheme(..) , Url , header , jsonResponse , oAuth2Bearer , req , responseBody , runReq ) import Network.HTTP.Req.OAuth2.Internal.Types import Network.HTTP.Types (Status) hasResponseStatus :: HttpException -> Status -> Bool hasResponseStatus (VanillaHttpException (HTTP.HttpExceptionRequest _ (HTTP.StatusCodeException response _))) status = HTTP.responseStatus response == status hasResponseStatus _ _ = False acceptLanguage :: Option scheme acceptLanguage = header "Accept-Language" "en_US" oAuth2AuthHeader :: ClientPair -> Option scheme oAuth2AuthHeader clientPair = header "Authorization" (ByteString.append "Basic " (encodeClientAuth clientPair)) where encodeClientAuth (ClientPair (ClientId cid) (ClientSecret cs)) = Base64.encode $ ByteString.concat [Text.encodeUtf8 cid, ":", Text.encodeUtf8 cs] oAuth2BearerHeader :: AccessToken -> Option 'Https oAuth2BearerHeader (AccessToken at) = oAuth2Bearer (Text.encodeUtf8 at) oAuth2PostRaw :: Url 'Https -> Option 'Https -> FormUrlEncodedParam -> IO Value oAuth2PostRaw url opts formBody = runReq def $ responseBody <$> req POST url (ReqBodyUrlEnc formBody) jsonResponse opts evalOAuth2 :: TokenPair -> OAuth2 a -> IO a evalOAuth2 = flip evalStateT runOAuth2 :: TokenPair -> OAuth2 a -> IO (a, TokenPair) runOAuth2 = flip runStateT