aboutsummaryrefslogtreecommitdiff
path: root/src/Sproxy/Application
diff options
context:
space:
mode:
authorIgor Pashev <pashev.igor@gmail.com>2017-07-26 21:11:18 +0300
committerIgor Pashev <pashev.igor@gmail.com>2017-08-06 19:11:48 +0300
commit671005e91e724c7f956cad24305603505e1bd322 (patch)
tree8fc92d7b1f4c6483100fdf72f18cc92b6769792e /src/Sproxy/Application
parent1123c543bdd438ad40428e7814325a53c819cee2 (diff)
downloadsproxy2-671005e91e724c7f956cad24305603505e1bd322.tar.gz
Add Yandex
https://tech.yandex.com/oauth/
Diffstat (limited to 'src/Sproxy/Application')
-rw-r--r--src/Sproxy/Application/OAuth2.hs19
-rw-r--r--src/Sproxy/Application/OAuth2/Yandex.hs83
2 files changed, 94 insertions, 8 deletions
diff --git a/src/Sproxy/Application/OAuth2.hs b/src/Sproxy/Application/OAuth2.hs
index 0f7d6e8..ae23b6e 100644
--- a/src/Sproxy/Application/OAuth2.hs
+++ b/src/Sproxy/Application/OAuth2.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
-module Sproxy.Application.OAuth2 (
- providers
-) where
+
+module Sproxy.Application.OAuth2
+ ( providers
+ ) where
import Data.HashMap.Strict (HashMap, fromList)
import Data.Text (Text)
@@ -9,10 +10,12 @@ import Data.Text (Text)
import Sproxy.Application.OAuth2.Common (OAuth2Provider)
import qualified Sproxy.Application.OAuth2.Google as Google
import qualified Sproxy.Application.OAuth2.LinkedIn as LinkedIn
+import qualified Sproxy.Application.OAuth2.Yandex as Yandex
providers :: HashMap Text OAuth2Provider
-providers = fromList [
- ("google" , Google.provider)
- , ("linkedin" , LinkedIn.provider)
- ]
-
+providers =
+ fromList
+ [ ("google", Google.provider)
+ , ("linkedin", LinkedIn.provider)
+ , ("yandex", Yandex.provider)
+ ]
diff --git a/src/Sproxy/Application/OAuth2/Yandex.hs b/src/Sproxy/Application/OAuth2/Yandex.hs
new file mode 100644
index 0000000..e943a39
--- /dev/null
+++ b/src/Sproxy/Application/OAuth2/Yandex.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Sproxy.Application.OAuth2.Yandex
+ ( provider
+ ) where
+
+import Control.Applicative (empty)
+import Control.Exception (Exception, throwIO)
+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 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)
+
+provider :: OAuth2Provider
+provider (client_id, client_secret) =
+ OAuth2Client
+ { oauth2Description = "Yandex"
+ , oauth2AuthorizeURL =
+ \state _redirect_uri ->
+ "https://oauth.yandex.ru/authorize" <> "?state=" <> urlEncode True state <>
+ "&client_id=" <>
+ urlEncode True client_id <>
+ "&response_type=code" <>
+ "&force_confirm=yes"
+ , oauth2Authenticate =
+ \code _redirect_uri -> do
+ let treq =
+ H.urlEncodedBody
+ [ ("grant_type", "authorization_code")
+ , ("client_id", client_id)
+ , ("client_secret", client_secret)
+ , ("code", code)
+ ] $
+ H.parseRequest_ "POST https://oauth.yandex.ru/token"
+ mgr <- H.newManager H.tlsManagerSettings
+ tresp <- H.httpLbs treq mgr
+ case decode $ H.responseBody tresp of
+ Nothing -> throwIO $ YandexException tresp
+ Just atResp -> do
+ let ureq =
+ (H.parseRequest_ "https://login.yandex.ru/info?format=json")
+ { H.requestHeaders =
+ [ ( "Authorization"
+ , "OAuth " <> encodeUtf8 (accessToken atResp))
+ ]
+ }
+ uresp <- H.httpLbs ureq mgr
+ case decode $ H.responseBody uresp of
+ Nothing -> throwIO $ YandexException uresp
+ Just u ->
+ return $
+ setFamilyName (lastName u) $
+ setGivenName (firstName u) $ newUser (defaultEmail u)
+ }
+
+data YandexException =
+ YandexException (H.Response ByteString)
+ deriving (Show, Typeable)
+
+instance Exception YandexException
+
+data YandexUserInfo = YandexUserInfo
+ { defaultEmail :: Text
+ , firstName :: Text
+ , lastName :: Text
+ } deriving (Eq, Show)
+
+instance FromJSON YandexUserInfo where
+ parseJSON (Object v) =
+ YandexUserInfo <$> v .: "default_email" <*> v .: "first_name" <*>
+ v .: "last_name"
+ parseJSON _ = empty