{-# 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 Int -> YesodOAuthException -> ShowS
[YesodOAuthException] -> ShowS
YesodOAuthException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [YesodOAuthException] -> ShowS
$cshowList :: [YesodOAuthException] -> ShowS
show :: YesodOAuthException -> String
$cshow :: YesodOAuthException -> String
showsPrec :: Int -> YesodOAuthException -> ShowS
$cshowsPrec :: Int -> YesodOAuthException -> ShowS
Show
instance Exception YesodOAuthException
oauthUrl :: Text -> AuthRoute
oauthUrl :: Text -> AuthRoute
oauthUrl Text
name = Text -> Texts -> AuthRoute
PluginR Text
name [Text
"forward"]
authOAuth :: forall master. YesodAuth master
=> OAuth
-> (Credential -> IO (Creds master))
-> AuthPlugin master
authOAuth :: forall master.
YesodAuth master =>
OAuth -> (Credential -> IO (Creds master)) -> AuthPlugin master
authOAuth OAuth
oauth Credential -> IO (Creds master)
mkCreds = forall master.
Text
-> (Text -> Texts -> AuthHandler master TypedContent)
-> ((AuthRoute -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
name Text -> Texts -> AuthHandler master TypedContent
dispatch (AuthRoute -> Route master) -> WidgetFor master ()
login
where
name :: Text
name = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ OAuth -> String
oauthServerName OAuth
oauth
url :: AuthRoute
url = Text -> Texts -> AuthRoute
PluginR Text
name []
lookupTokenSecret :: Credential -> Text
lookupTokenSecret = ByteString -> Text
bsToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe ByteString
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"oauth_token_secret" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential -> [(ByteString, ByteString)]
unCredential
oauthSessionName :: Text
oauthSessionName :: Text
oauthSessionName = Text
"__oauth_token_secret"
dispatch
:: Text
-> [Text]
-> AuthHandler master TypedContent
dispatch :: Text -> Texts -> AuthHandler master TypedContent
dispatch Text
"GET" [Text
"forward"] = do
Route master -> Text
render <- forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
AuthRoute -> Route master
tm <- forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
let oauth' :: OAuth
oauth' = OAuth
oauth { oauthCallback :: Maybe ByteString
oauthCallback = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ Route master -> Text
render forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route master
tm AuthRoute
url }
Manager
manager <- forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
Credential
tok <- forall (m :: * -> *). MonadIO m => OAuth -> Manager -> m Credential
getTemporaryCredential OAuth
oauth' Manager
manager
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
oauthSessionName forall a b. (a -> b) -> a -> b
$ Credential -> Text
lookupTokenSecret Credential
tok
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect forall a b. (a -> b) -> a -> b
$ OAuth -> Credential -> String
authorizeUrl OAuth
oauth' Credential
tok
dispatch Text
"GET" [] = do
Text
tokSec <- forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
oauthSessionName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Text
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
Maybe Text
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lookupSession could not find session"
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
oauthSessionName
Credential
reqTok <-
if OAuth -> OAuthVersion
oauthVersion OAuth
oauth forall a. Eq a => a -> a -> Bool
== OAuthVersion
OAuth10
then do
Text
oaTok <- forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputGet forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"oauth_token"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> Credential
Credential [ (ByteString
"oauth_token", Text -> ByteString
encodeUtf8 Text
oaTok)
, (ByteString
"oauth_token_secret", Text -> ByteString
encodeUtf8 Text
tokSec)
]
else do
(Text
verifier, Text
oaTok) <-
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputGet forall a b. (a -> b) -> a -> b
$ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"oauth_verifier"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
A.<*> forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"oauth_token"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> Credential
Credential [ (ByteString
"oauth_verifier", Text -> ByteString
encodeUtf8 Text
verifier)
, (ByteString
"oauth_token", Text -> ByteString
encodeUtf8 Text
oaTok)
, (ByteString
"oauth_token_secret", Text -> ByteString
encodeUtf8 Text
tokSec)
]
Manager
manager <- forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
Credential
accTok <- forall (m :: * -> *).
MonadIO m =>
OAuth -> Credential -> Manager -> m Credential
getAccessToken OAuth
oauth Credential
reqTok Manager
manager
Creds master
creds <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Credential -> IO (Creds master)
mkCreds Credential
accTok
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect Creds master
creds
dispatch Text
_ Texts
_ = forall (m :: * -> *) a. MonadHandler m => m a
notFound
login :: (AuthRoute -> Route master) -> WidgetFor master ()
login AuthRoute -> Route master
tm = do
Route master -> Text
render <- forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
let oaUrl :: Text
oaUrl = Route master -> Text
render forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route master
tm forall a b. (a -> b) -> a -> b
$ Text -> AuthRoute
oauthUrl Text
name
[whamlet| <a href=#{oaUrl}>Login via #{name} |]
mkExtractCreds :: Text -> String -> Credential -> IO (Creds m)
Text
name String
idName (Credential [(ByteString, ByteString)]
dic) = do
let mcrId :: Maybe Text
mcrId = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
idName) [(ByteString, ByteString)]
dic
case Maybe Text
mcrId of
Just Text
crId -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
name Text
crId forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Text
bsToText forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> Text
bsToText) [(ByteString, ByteString)]
dic
Maybe Text
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> Credential -> YesodOAuthException
CredentialError (String
"key not found: " forall a. [a] -> [a] -> [a]
++ String
idName) ([(ByteString, ByteString)] -> Credential
Credential [(ByteString, ByteString)]
dic)
authTwitter' :: YesodAuth m
=> ByteString
-> ByteString
-> String
-> AuthPlugin m
ByteString
key ByteString
secret String
idName = forall master.
YesodAuth master =>
OAuth -> (Credential -> IO (Creds master)) -> AuthPlugin master
authOAuth
(OAuth
newOAuth { oauthServerName :: String
oauthServerName = String
"twitter"
, oauthRequestUri :: String
oauthRequestUri = String
"https://api.twitter.com/oauth/request_token"
, oauthAccessTokenUri :: String
oauthAccessTokenUri = String
"https://api.twitter.com/oauth/access_token"
, oauthAuthorizeUri :: String
oauthAuthorizeUri = String
"https://api.twitter.com/oauth/authorize"
, oauthSignatureMethod :: SignMethod
oauthSignatureMethod = SignMethod
HMACSHA1
, oauthConsumerKey :: ByteString
oauthConsumerKey = ByteString
key
, oauthConsumerSecret :: ByteString
oauthConsumerSecret = ByteString
secret
, oauthVersion :: OAuthVersion
oauthVersion = OAuthVersion
OAuth10a
})
(forall m. Text -> String -> Credential -> IO (Creds m)
mkExtractCreds Text
"twitter" String
idName)
authTwitter :: YesodAuth m
=> ByteString
-> ByteString
-> AuthPlugin m
ByteString
key ByteString
secret = forall m.
YesodAuth m =>
ByteString -> ByteString -> String -> AuthPlugin m
authTwitter' ByteString
key ByteString
secret String
"screen_name"
{-# DEPRECATED authTwitter "Use authTwitterUsingUserId instead" #-}
authTwitterUsingUserId :: YesodAuth m
=> ByteString
-> ByteString
-> AuthPlugin m
ByteString
key ByteString
secret = forall m.
YesodAuth m =>
ByteString -> ByteString -> String -> AuthPlugin m
authTwitter' ByteString
key ByteString
secret String
"user_id"
twitterUrl :: AuthRoute
= Text -> AuthRoute
oauthUrl Text
"twitter"
authTumblr :: YesodAuth m
=> ByteString
-> ByteString
-> AuthPlugin m
authTumblr :: forall m. YesodAuth m => ByteString -> ByteString -> AuthPlugin m
authTumblr ByteString
key ByteString
secret = forall master.
YesodAuth master =>
OAuth -> (Credential -> IO (Creds master)) -> AuthPlugin master
authOAuth
(OAuth
newOAuth { oauthServerName :: String
oauthServerName = String
"tumblr"
, oauthRequestUri :: String
oauthRequestUri = String
"http://www.tumblr.com/oauth/request_token"
, oauthAccessTokenUri :: String
oauthAccessTokenUri = String
"http://www.tumblr.com/oauth/access_token"
, oauthAuthorizeUri :: String
oauthAuthorizeUri = String
"http://www.tumblr.com/oauth/authorize"
, oauthSignatureMethod :: SignMethod
oauthSignatureMethod = SignMethod
HMACSHA1
, oauthConsumerKey :: ByteString
oauthConsumerKey = ByteString
key
, oauthConsumerSecret :: ByteString
oauthConsumerSecret = ByteString
secret
, oauthVersion :: OAuthVersion
oauthVersion = OAuthVersion
OAuth10a
})
(forall m. Text -> String -> Credential -> IO (Creds m)
mkExtractCreds Text
"tumblr" String
"name")
tumblrUrl :: AuthRoute
tumblrUrl :: AuthRoute
tumblrUrl = Text -> AuthRoute
oauthUrl Text
"tumblr"
bsToText :: ByteString -> Text
bsToText :: ByteString -> Text
bsToText = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode