1 files changed, 83 insertions, 0 deletions
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