Add Yandex

https://tech.yandex.com/oauth/

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