From 016ef10b0a429d7c2b0c7d83914316f2211cc36b Mon Sep 17 00:00:00 2001 From: Igor Pashev Date: Sun, 6 Aug 2017 19:22:28 +0300 Subject: Fix POST requests for tokens Really use application/x-www-form-urlencoded instead of query paramaters. Apparently, Google and LinkedIn are too tolerant. Yandex is not. --- src/Sproxy/Application/OAuth2/Google.hs | 122 ++++++++++++++-------------- src/Sproxy/Application/OAuth2/LinkedIn.hs | 127 ++++++++++++++++-------------- 2 files changed, 131 insertions(+), 118 deletions(-) diff --git a/src/Sproxy/Application/OAuth2/Google.hs b/src/Sproxy/Application/OAuth2/Google.hs index 5a1834c..b2ea2c1 100644 --- a/src/Sproxy/Application/OAuth2/Google.hs +++ b/src/Sproxy/Application/OAuth2/Google.hs @@ -1,81 +1,87 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} -module Sproxy.Application.OAuth2.Google ( - provider -) where + +module Sproxy.Application.OAuth2.Google + ( provider + ) where import Control.Applicative (empty) import Control.Exception (Exception, throwIO) -import Data.Aeson (FromJSON, decode, parseJSON, Value(Object), (.:)) +import Data.Aeson + (FromJSON, Value(Object), (.:), decode, parseJSON) import Data.ByteString.Lazy (ByteString) import Data.Monoid ((<>)) import Data.Text (Text, unpack) import Data.Typeable (Typeable) -import Network.HTTP.Types (hContentType) -import Network.HTTP.Types.URI (urlEncode) import qualified Network.HTTP.Conduit as H +import Network.HTTP.Types.URI (urlEncode) -import Sproxy.Application.Cookie (newUser, setFamilyName, setGivenName) -import Sproxy.Application.OAuth2.Common (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider) - +import Sproxy.Application.Cookie + (newUser, setFamilyName, setGivenName) +import Sproxy.Application.OAuth2.Common + (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider) provider :: OAuth2Provider provider (client_id, client_secret) = - OAuth2Client { - oauth2Description = "Google" - , oauth2AuthorizeURL = \state redirect_uri -> - "https://accounts.google.com/o/oauth2/v2/auth" - <> "?scope=" <> urlEncode True "https://www.googleapis.com/auth/userinfo.email https://www.googleapis.com/auth/userinfo.profile" - <> "&client_id=" <> urlEncode True client_id - <> "&prompt=select_account" - <> "&redirect_uri=" <> urlEncode True redirect_uri - <> "&response_type=code" - <> "&state=" <> urlEncode True state - - , oauth2Authenticate = \code redirect_uri -> do - let treq = H.setQueryString [ - ("client_id" , Just client_id) - , ("client_secret" , Just client_secret) - , ("code" , Just code) - , ("grant_type" , Just "authorization_code") - , ("redirect_uri" , Just redirect_uri) - ] $ (H.parseRequest_ "POST https://www.googleapis.com/oauth2/v4/token") { - H.requestHeaders = [ - (hContentType, "application/x-www-form-urlencoded") - ] - } - mgr <- H.newManager H.tlsManagerSettings - tresp <- H.httpLbs treq mgr - case decode $ H.responseBody tresp of - Nothing -> throwIO $ GoogleException tresp - Just atResp -> do - ureq <- H.parseRequest $ unpack ("https://www.googleapis.com/oauth2/v1/userinfo?access_token=" <> accessToken atResp) - uresp <- H.httpLbs ureq mgr - case decode $ H.responseBody uresp of - Nothing -> throwIO $ GoogleException uresp - Just u -> return $ setFamilyName (familyName u) $ - setGivenName (givenName u) $ - newUser (email u) + OAuth2Client + { oauth2Description = "Google" + , oauth2AuthorizeURL = + \state redirect_uri -> + "https://accounts.google.com/o/oauth2/v2/auth" <> "?scope=" <> + urlEncode + True + "https://www.googleapis.com/auth/userinfo.email https://www.googleapis.com/auth/userinfo.profile" <> + "&client_id=" <> + urlEncode True client_id <> + "&prompt=select_account" <> + "&redirect_uri=" <> + urlEncode True redirect_uri <> + "&response_type=code" <> + "&state=" <> + urlEncode True state + , oauth2Authenticate = + \code redirect_uri -> do + let treq = + H.urlEncodedBody + [ ("client_id", client_id) + , ("client_secret", client_secret) + , ("code", code) + , ("grant_type", "authorization_code") + , ("redirect_uri", redirect_uri) + ] $ + H.parseRequest_ "POST https://www.googleapis.com/oauth2/v4/token" + mgr <- H.newManager H.tlsManagerSettings + tresp <- H.httpLbs treq mgr + case decode $ H.responseBody tresp of + Nothing -> throwIO $ GoogleException tresp + Just atResp -> do + ureq <- + H.parseRequest $ + unpack + ("https://www.googleapis.com/oauth2/v1/userinfo?access_token=" <> + accessToken atResp) + uresp <- H.httpLbs ureq mgr + case decode $ H.responseBody uresp of + Nothing -> throwIO $ GoogleException uresp + Just u -> + return $ + setFamilyName (familyName u) $ + setGivenName (givenName u) $ newUser (email u) } - -data GoogleException = GoogleException (H.Response ByteString) +data GoogleException = + GoogleException (H.Response ByteString) deriving (Show, Typeable) - instance Exception GoogleException - -data GoogleUserInfo = GoogleUserInfo { - email :: Text -, givenName :: Text -, familyName :: Text -} deriving (Eq, Show) +data GoogleUserInfo = GoogleUserInfo + { email :: Text + , givenName :: Text + , familyName :: Text + } deriving (Eq, Show) instance FromJSON GoogleUserInfo where - parseJSON (Object v) = GoogleUserInfo - <$> v .: "email" - <*> v .: "given_name" - <*> v .: "family_name" + parseJSON (Object v) = + GoogleUserInfo <$> v .: "email" <*> v .: "given_name" <*> v .: "family_name" parseJSON _ = empty - diff --git a/src/Sproxy/Application/OAuth2/LinkedIn.hs b/src/Sproxy/Application/OAuth2/LinkedIn.hs index b35c566..3fdd7be 100644 --- a/src/Sproxy/Application/OAuth2/LinkedIn.hs +++ b/src/Sproxy/Application/OAuth2/LinkedIn.hs @@ -1,84 +1,91 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} -module Sproxy.Application.OAuth2.LinkedIn ( - provider -) where + +module Sproxy.Application.OAuth2.LinkedIn + ( provider + ) where import Control.Applicative (empty) import Control.Exception (Exception, throwIO) -import Data.Aeson (FromJSON, decode, parseJSON, Value(Object), (.:)) +import Data.Aeson + (FromJSON, Value(Object), (.:), decode, parseJSON) import Data.ByteString.Lazy (ByteString) import Data.Monoid ((<>)) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Typeable (Typeable) -import Network.HTTP.Types (hContentType) -import Network.HTTP.Types.URI (urlEncode) import qualified Network.HTTP.Conduit as H +import Network.HTTP.Types.URI (urlEncode) -import Sproxy.Application.Cookie (newUser, setFamilyName, setGivenName) -import Sproxy.Application.OAuth2.Common (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider) - +import Sproxy.Application.Cookie + (newUser, setFamilyName, setGivenName) +import Sproxy.Application.OAuth2.Common + (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider) provider :: OAuth2Provider provider (client_id, client_secret) = - OAuth2Client { - oauth2Description = "LinkedIn" - , oauth2AuthorizeURL = \state redirect_uri -> - "https://www.linkedin.com/oauth/v2/authorization" - <> "?scope=r_basicprofile%20r_emailaddress" - <> "&client_id=" <> urlEncode True client_id - <> "&redirect_uri=" <> urlEncode True redirect_uri - <> "&response_type=code" - <> "&state=" <> urlEncode True state - - , oauth2Authenticate = \code redirect_uri -> do - let treq = H.setQueryString [ - ("client_id" , Just client_id) - , ("client_secret" , Just client_secret) - , ("code" , Just code) - , ("grant_type" , Just "authorization_code") - , ("redirect_uri" , Just redirect_uri) - ] $ (H.parseRequest_ "POST https://www.linkedin.com/oauth/v2/accessToken") { - H.requestHeaders = [ - (hContentType, "application/x-www-form-urlencoded") - ] - } - mgr <- H.newManager H.tlsManagerSettings - tresp <- H.httpLbs treq mgr - case decode $ H.responseBody tresp of - Nothing -> throwIO $ LinkedInException tresp - Just atResp -> do - let ureq = (H.parseRequest_ "https://api.linkedin.com/v1/people/\ - \~:(email-address,first-name,last-name)?format=json") { - H.requestHeaders = [ ("Authorization", "Bearer " <> encodeUtf8 (accessToken atResp)) ] - } - uresp <- H.httpLbs ureq mgr - case decode $ H.responseBody uresp of - Nothing -> throwIO $ LinkedInException uresp - Just u -> return $ setFamilyName (lastName u) $ - setGivenName (firstName u) $ - newUser (emailAddress u) + OAuth2Client + { oauth2Description = "LinkedIn" + , oauth2AuthorizeURL = + \state redirect_uri -> + "https://www.linkedin.com/oauth/v2/authorization" <> + "?scope=r_basicprofile%20r_emailaddress" <> + "&client_id=" <> + urlEncode True client_id <> + "&redirect_uri=" <> + urlEncode True redirect_uri <> + "&response_type=code" <> + "&state=" <> + urlEncode True state + , oauth2Authenticate = + \code redirect_uri -> do + let treq = + H.urlEncodedBody + [ ("client_id", client_id) + , ("client_secret", client_secret) + , ("code", code) + , ("grant_type", "authorization_code") + , ("redirect_uri", redirect_uri) + ] $ + H.parseRequest_ + "POST https://www.linkedin.com/oauth/v2/accessToken" + mgr <- H.newManager H.tlsManagerSettings + tresp <- H.httpLbs treq mgr + case decode $ H.responseBody tresp of + Nothing -> throwIO $ LinkedInException tresp + Just atResp -> do + let ureq = + (H.parseRequest_ + "https://api.linkedin.com/v1/people/\ + \~:(email-address,first-name,last-name)?format=json") + { H.requestHeaders = + [ ( "Authorization" + , "Bearer " <> encodeUtf8 (accessToken atResp)) + ] + } + uresp <- H.httpLbs ureq mgr + case decode $ H.responseBody uresp of + Nothing -> throwIO $ LinkedInException uresp + Just u -> + return $ + setFamilyName (lastName u) $ + setGivenName (firstName u) $ newUser (emailAddress u) } - -data LinkedInException = LinkedInException (H.Response ByteString) +data LinkedInException = + LinkedInException (H.Response ByteString) deriving (Show, Typeable) - instance Exception LinkedInException - -data LinkedInUserInfo = LinkedInUserInfo { - emailAddress :: Text -, firstName :: Text -, lastName :: Text -} deriving (Eq, Show) +data LinkedInUserInfo = LinkedInUserInfo + { emailAddress :: Text + , firstName :: Text + , lastName :: Text + } deriving (Eq, Show) instance FromJSON LinkedInUserInfo where - parseJSON (Object v) = LinkedInUserInfo - <$> v .: "emailAddress" - <*> v .: "firstName" - <*> v .: "lastName" + parseJSON (Object v) = + LinkedInUserInfo <$> v .: "emailAddress" <*> v .: "firstName" <*> + v .: "lastName" parseJSON _ = empty - -- cgit v1.2.3