aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Sproxy/Application/OAuth2/Google.hs122
-rw-r--r--src/Sproxy/Application/OAuth2/LinkedIn.hs127
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
-
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-21 13:16:37 +0000