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.

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
-