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
84
|
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
module Sproxy.Application.OAuth2.LinkedIn (
provider
) where
import Control.Applicative (empty)
import Control.Exception (Exception, throwIO)
import Data.Aeson (FromJSON, decode, parseJSON, Value(Object), (.:))
import Data.ByteString.Lazy (ByteString)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Typeable (Typeable)
import Network.HTTP.Types (hContentType)
import Network.HTTP.Types.URI (urlEncode)
import qualified Network.HTTP.Conduit as H
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 = "LinkedIn"
, oauth2AuthorizeURL = \state redirect_uri ->
"https://www.linkedin.com/oauth/v2/authorization"
<> "?scope=r_basicprofile%20r_emailaddress"
<> "&client_id=" <> urlEncode True client_id
<> "&redirect_uri=" <> urlEncode True redirect_uri
<> "&response_type=code"
<> "&state=" <> urlEncode True state
, oauth2Authenticate = \code redirect_uri -> do
let treq = H.setQueryString [
("client_id" , Just client_id)
, ("client_secret" , Just client_secret)
, ("code" , Just code)
, ("grant_type" , Just "authorization_code")
, ("redirect_uri" , Just redirect_uri)
] $ (H.parseRequest_ "POST https://www.linkedin.com/oauth/v2/accessToken") {
H.requestHeaders = [
(hContentType, "application/x-www-form-urlencoded")
]
}
mgr <- H.newManager H.tlsManagerSettings
tresp <- H.httpLbs treq mgr
case decode $ H.responseBody tresp of
Nothing -> throwIO $ LinkedInException tresp
Just atResp -> do
let ureq = (H.parseRequest_ "https://api.linkedin.com/v1/people/\
\~:(email-address,first-name,last-name)?format=json") {
H.requestHeaders = [ ("Authorization", "Bearer " <> encodeUtf8 (accessToken atResp)) ]
}
uresp <- H.httpLbs ureq mgr
case decode $ H.responseBody uresp of
Nothing -> throwIO $ LinkedInException uresp
Just u -> return $ setFamilyName (lastName u) $
setGivenName (firstName u) $
newUser (emailAddress u)
}
data LinkedInException = LinkedInException (H.Response ByteString)
deriving (Show, Typeable)
instance Exception LinkedInException
data LinkedInUserInfo = LinkedInUserInfo {
emailAddress :: Text
, firstName :: Text
, lastName :: Text
} deriving (Eq, Show)
instance FromJSON LinkedInUserInfo where
parseJSON (Object v) = LinkedInUserInfo
<$> v .: "emailAddress"
<*> v .: "firstName"
<*> v .: "lastName"
parseJSON _ = empty
|
