Yandex.hs

{-# 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