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
|
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-}
module Yesod.Auth.OAuth
( authOAuth
, oauthUrl
, authTwitter
, twitterUrl
, authTumblr
, tumblrUrl
, module Web.Authenticate.OAuth
) where
import Control.Applicative ((<$>), (<*>))
import Control.Arrow ((***))
import Control.Exception.Lifted
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 Data.Typeable
import Web.Authenticate.OAuth
import Yesod.Auth
import Yesod.Form
import Yesod.Core
data YesodOAuthException = CredentialError String Credential
| SessionError String
deriving (Show, Typeable)
instance Exception YesodOAuthException
oauthUrl :: Text -> AuthRoute
oauthUrl name = PluginR name ["forward"]
authOAuth :: YesodAuth m
=> OAuth -- ^ 'OAuth' data-type for signing.
-> (Credential -> IO (Creds m)) -- ^ How to extract ident.
-> AuthPlugin m
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 = "__oauth_token_secret"
dispatch "GET" ["forward"] = do
render <- lift getUrlRender
tm <- getRouteToParent
let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
master <- lift getYesod
tok <- lift $ getTemporaryCredential oauth' (authHttpManager master)
setSession oauthSessionName $ lookupTokenSecret tok
redirect $ authorizeUrl oauth' tok
dispatch "GET" [] = lift $ do
Just tokSec <- lookupSession oauthSessionName
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 $ (,) <$> ireq textField "oauth_verifier"
<*> ireq textField "oauth_token"
return $ Credential [ ("oauth_verifier", encodeUtf8 verifier)
, ("oauth_token", encodeUtf8 oaTok)
, ("oauth_token_secret", encodeUtf8 tokSec)
]
master <- getYesod
accTok <- getAccessToken oauth reqTok (authHttpManager master)
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 :: YesodAuth m => 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
-> AuthPlugin m
authTwitter key secret = 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" "screen_name")
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
|
