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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Yesod.Auth.OAuth
( authOAuth
, oauthUrl
, authTwitter
, authTwitterUsingUserId
, twitterUrl
, authTumblr
, tumblrUrl
, module Web.Authenticate.OAuth
) where
import Control.Applicative as A ((<$>), (<*>))
import Control.Arrow ((***))
import UnliftIO.Exception
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import Web.Authenticate.OAuth
import Yesod.Auth
import Yesod.Form
import Yesod.Core
data YesodOAuthException = CredentialError String Credential
| SessionError String
deriving Show
instance Exception YesodOAuthException
oauthUrl :: Text -> AuthRoute
oauthUrl name = PluginR name ["forward"]
authOAuth :: forall master. YesodAuth master
=> OAuth -- ^ 'OAuth' data-type for signing.
-> (Credential -> IO (Creds master)) -- ^ How to extract ident.
-> AuthPlugin master
authOAuth oauth mkCreds = AuthPlugin name dispatch login
where
name = T.pack $ oauthServerName oauth
url = PluginR name []
lookupTokenSecret = bsToText . fromMaybe "" . lookup "oauth_token_secret" . unCredential
oauthSessionName :: Text
oauthSessionName = "__oauth_token_secret"
dispatch
:: Text
-> [Text]
-> AuthHandler master TypedContent
dispatch "GET" ["forward"] = do
render <- getUrlRender
tm <- getRouteToParent
let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
manager <- authHttpManager
tok <- getTemporaryCredential oauth' manager
setSession oauthSessionName $ lookupTokenSecret tok
redirect $ authorizeUrl oauth' tok
dispatch "GET" [] = do
tokSec <- lookupSession oauthSessionName >>= \case
Just t -> return t
Nothing -> liftIO $ fail "lookupSession could not find session"
deleteSession oauthSessionName
reqTok <-
if oauthVersion oauth == OAuth10
then do
oaTok <- runInputGet $ ireq textField "oauth_token"
return $ Credential [ ("oauth_token", encodeUtf8 oaTok)
, ("oauth_token_secret", encodeUtf8 tokSec)
]
else do
(verifier, oaTok) <-
runInputGet $ (,) A.<$> ireq textField "oauth_verifier"
A.<*> ireq textField "oauth_token"
return $ Credential [ ("oauth_verifier", encodeUtf8 verifier)
, ("oauth_token", encodeUtf8 oaTok)
, ("oauth_token_secret", encodeUtf8 tokSec)
]
manager <- authHttpManager
accTok <- getAccessToken oauth reqTok manager
creds <- liftIO $ mkCreds accTok
setCredsRedirect creds
dispatch _ _ = notFound
login tm = do
render <- getUrlRender
let oaUrl = render $ tm $ oauthUrl name
[whamlet| <a href=#{oaUrl}>Login via #{name} |]
mkExtractCreds :: Text -> String -> Credential -> IO (Creds m)
mkExtractCreds name idName (Credential dic) = do
let mcrId = decodeUtf8With lenientDecode <$> lookup (encodeUtf8 $ T.pack idName) dic
case mcrId of
Just crId -> return $ Creds name crId $ map (bsToText *** bsToText) dic
Nothing -> throwIO $ CredentialError ("key not found: " ++ idName) (Credential dic)
authTwitter' :: YesodAuth m
=> ByteString -- ^ Consumer Key
-> ByteString -- ^ Consumer Secret
-> String
-> AuthPlugin m
authTwitter' key secret idName = authOAuth
(newOAuth { oauthServerName = "twitter"
, oauthRequestUri = "https://api.twitter.com/oauth/request_token"
, oauthAccessTokenUri = "https://api.twitter.com/oauth/access_token"
, oauthAuthorizeUri = "https://api.twitter.com/oauth/authorize"
, oauthSignatureMethod = HMACSHA1
, oauthConsumerKey = key
, oauthConsumerSecret = secret
, oauthVersion = OAuth10a
})
(mkExtractCreds "twitter" idName)
-- | This plugin uses Twitter's /screen_name/ as ID, which shouldn't be used for authentication because it is mutable.
authTwitter :: YesodAuth m
=> ByteString -- ^ Consumer Key
-> ByteString -- ^ Consumer Secret
-> AuthPlugin m
authTwitter key secret = authTwitter' key secret "screen_name"
{-# DEPRECATED authTwitter "Use authTwitterUsingUserId instead" #-}
-- | Twitter plugin which uses Twitter's /user_id/ as ID.
--
-- For more information, see: https://github.com/yesodweb/yesod/pull/1168
--
-- @since 1.4.1
authTwitterUsingUserId :: YesodAuth m
=> ByteString -- ^ Consumer Key
-> ByteString -- ^ Consumer Secret
-> AuthPlugin m
authTwitterUsingUserId key secret = authTwitter' key secret "user_id"
twitterUrl :: AuthRoute
twitterUrl = oauthUrl "twitter"
authTumblr :: YesodAuth m
=> ByteString -- ^ Consumer Key
-> ByteString -- ^ Consumer Secret
-> AuthPlugin m
authTumblr key secret = authOAuth
(newOAuth { oauthServerName = "tumblr"
, oauthRequestUri = "http://www.tumblr.com/oauth/request_token"
, oauthAccessTokenUri = "http://www.tumblr.com/oauth/access_token"
, oauthAuthorizeUri = "http://www.tumblr.com/oauth/authorize"
, oauthSignatureMethod = HMACSHA1
, oauthConsumerKey = key
, oauthConsumerSecret = secret
, oauthVersion = OAuth10a
})
(mkExtractCreds "tumblr" "name")
tumblrUrl :: AuthRoute
tumblrUrl = oauthUrl "tumblr"
bsToText :: ByteString -> Text
bsToText = decodeUtf8With lenientDecode
|
