1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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
|
