{-# 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           UnliftIO                 (MonadUnliftIO)
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
(Int -> YesodOAuthException -> ShowS)
-> (YesodOAuthException -> String)
-> ([YesodOAuthException] -> ShowS)
-> Show YesodOAuthException
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                        -- ^ 'OAuth' data-type for signing.
          -> (Credential -> IO (Creds master)) -- ^ How to extract ident.
          -> AuthPlugin master
authOAuth :: OAuth -> (Credential -> IO (Creds master)) -> AuthPlugin master
authOAuth OAuth
oauth Credential -> IO (Creds master)
mkCreds = Text
-> (Text -> Texts -> AuthHandler master TypedContent)
-> ((AuthRoute -> Route master) -> WidgetFor master ())
-> AuthPlugin master
forall master.
Text
-> (Text -> Texts -> AuthHandler master TypedContent)
-> ((AuthRoute -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
name Text -> Texts -> AuthHandler master TypedContent
forall (m :: * -> *).
(MonadHandler m, master ~ HandlerSite m, Auth ~ SubHandlerSite m,
 MonadUnliftIO m) =>
Text -> Texts -> m TypedContent
dispatch (AuthRoute -> Route master) -> WidgetFor master ()
login
  where
    name :: Text
name = String -> Text
T.pack (String -> Text) -> String -> Text
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 (ByteString -> Text)
-> (Credential -> ByteString) -> Credential -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString)
-> (Credential -> Maybe ByteString) -> Credential -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"oauth_token_secret" ([(ByteString, ByteString)] -> Maybe ByteString)
-> (Credential -> [(ByteString, ByteString)])
-> Credential
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential -> [(ByteString, ByteString)]
unCredential

    oauthSessionName :: Text
    oauthSessionName :: Text
oauthSessionName = Text
"__oauth_token_secret"

    dispatch
      :: ( MonadHandler m
         , master ~ HandlerSite m
         , Auth ~ SubHandlerSite m
         , MonadUnliftIO m
         )
      => Text
      -> [Text]
      -> m TypedContent
    dispatch :: Text -> Texts -> m TypedContent
dispatch Text
"GET" [Text
"forward"] = do
        Route master -> Text
render <- m (Route master -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
        AuthRoute -> Route master
tm <- m (AuthRoute -> Route master)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
        let oauth' :: OAuth
oauth' = OAuth
oauth { oauthCallback :: Maybe ByteString
oauthCallback = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Route master -> Text
render (Route master -> Text) -> Route master -> Text
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route master
tm AuthRoute
url }
        Manager
manager <- m Manager
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
        Credential
tok <- OAuth -> Manager -> m Credential
forall (m :: * -> *). MonadIO m => OAuth -> Manager -> m Credential
getTemporaryCredential OAuth
oauth' Manager
manager
        Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
oauthSessionName (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Credential -> Text
lookupTokenSecret Credential
tok
        String -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (String -> m TypedContent) -> String -> m TypedContent
forall a b. (a -> b) -> a -> b
$ OAuth -> Credential -> String
authorizeUrl OAuth
oauth' Credential
tok
    dispatch Text
"GET" [] = do
      Text
tokSec <- Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
oauthSessionName m (Maybe Text) -> (Maybe Text -> m Text) -> m Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Text
t -> Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
        Maybe Text
Nothing -> IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lookupSession could not find session"
      Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
oauthSessionName
      Credential
reqTok <-
        if OAuth -> OAuthVersion
oauthVersion OAuth
oauth OAuthVersion -> OAuthVersion -> Bool
forall a. Eq a => a -> a -> Bool
== OAuthVersion
OAuth10
          then do
            Text
oaTok  <- FormInput m Text -> m Text
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputGet (FormInput m Text -> m Text) -> FormInput m Text -> m Text
forall a b. (a -> b) -> a -> b
$ Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"oauth_token"
            Credential -> m Credential
forall (m :: * -> *) a. Monad m => a -> m a
return (Credential -> m Credential) -> Credential -> m Credential
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) <-
                FormInput m (Text, Text) -> m (Text, Text)
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputGet (FormInput m (Text, Text) -> m (Text, Text))
-> FormInput m (Text, Text) -> m (Text, Text)
forall a b. (a -> b) -> a -> b
$ (,) (Text -> Text -> (Text, Text))
-> FormInput m Text -> FormInput m (Text -> (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"oauth_verifier"
                                  FormInput m (Text -> (Text, Text))
-> FormInput m Text -> FormInput m (Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
A.<*> Field m Text -> Text -> FormInput m Text
forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"oauth_token"
            Credential -> m Credential
forall (m :: * -> *) a. Monad m => a -> m a
return (Credential -> m Credential) -> Credential -> m Credential
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 <- m Manager
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
      Credential
accTok <- OAuth -> Credential -> Manager -> m Credential
forall (m :: * -> *).
MonadIO m =>
OAuth -> Credential -> Manager -> m Credential
getAccessToken OAuth
oauth Credential
reqTok Manager
manager
      Creds master
creds  <- IO (Creds master) -> m (Creds master)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Creds master) -> m (Creds master))
-> IO (Creds master) -> m (Creds master)
forall a b. (a -> b) -> a -> b
$ Credential -> IO (Creds master)
mkCreds Credential
accTok
      Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect Creds master
Creds (HandlerSite m)
creds
    dispatch Text
_ Texts
_ = m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound

    login :: (AuthRoute -> Route master) -> WidgetFor master ()
login AuthRoute -> Route master
tm = do
        Route master -> Text
render <- WidgetFor master (Route master -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
        let oaUrl :: Text
oaUrl = Route master -> Text
render (Route master -> Text) -> Route master -> Text
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route master
tm (AuthRoute -> Route master) -> AuthRoute -> Route master
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)
mkExtractCreds :: Text -> String -> Credential -> IO (Creds m)
mkExtractCreds Text
name String
idName (Credential [(ByteString, ByteString)]
dic) = do
  let mcrId :: Maybe Text
mcrId = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
idName) [(ByteString, ByteString)]
dic
  case Maybe Text
mcrId of
    Just Text
crId -> Creds m -> IO (Creds m)
forall (m :: * -> *) a. Monad m => a -> m a
return (Creds m -> IO (Creds m)) -> Creds m -> IO (Creds m)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [(Text, Text)] -> Creds m
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
name Text
crId ([(Text, Text)] -> Creds m) -> [(Text, Text)] -> Creds m
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> (Text, Text))
-> [(ByteString, ByteString)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Text
bsToText (ByteString -> Text)
-> (ByteString -> Text) -> (ByteString, ByteString) -> (Text, Text)
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 -> YesodOAuthException -> IO (Creds m)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (YesodOAuthException -> IO (Creds m))
-> YesodOAuthException -> IO (Creds m)
forall a b. (a -> b) -> a -> b
$ String -> Credential -> YesodOAuthException
CredentialError (String
"key not found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
idName) ([(ByteString, ByteString)] -> Credential
Credential [(ByteString, ByteString)]
dic)

authTwitter' :: YesodAuth m
             => ByteString -- ^ Consumer Key
             -> ByteString -- ^ Consumer Secret
             -> String
             -> AuthPlugin m
authTwitter' :: ByteString -> ByteString -> String -> AuthPlugin m
authTwitter' ByteString
key ByteString
secret String
idName = OAuth -> (Credential -> IO (Creds m)) -> AuthPlugin m
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
                          })
                (Text -> String -> Credential -> IO (Creds m)
forall m. Text -> String -> Credential -> IO (Creds m)
mkExtractCreds Text
"twitter" String
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 :: ByteString -> ByteString -> AuthPlugin m
authTwitter ByteString
key ByteString
secret = ByteString -> ByteString -> String -> AuthPlugin m
forall m.
YesodAuth m =>
ByteString -> ByteString -> String -> AuthPlugin m
authTwitter' ByteString
key ByteString
secret String
"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 :: ByteString -> ByteString -> AuthPlugin m
authTwitterUsingUserId ByteString
key ByteString
secret = ByteString -> ByteString -> String -> AuthPlugin m
forall m.
YesodAuth m =>
ByteString -> ByteString -> String -> AuthPlugin m
authTwitter' ByteString
key ByteString
secret String
"user_id"

twitterUrl :: AuthRoute
twitterUrl :: AuthRoute
twitterUrl = Text -> AuthRoute
oauthUrl Text
"twitter"

authTumblr :: YesodAuth m
            => ByteString -- ^ Consumer Key
            -> ByteString -- ^ Consumer Secret
            -> AuthPlugin m
authTumblr :: ByteString -> ByteString -> AuthPlugin m
authTumblr ByteString
key ByteString
secret = OAuth -> (Credential -> IO (Creds m)) -> AuthPlugin m
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
                          })
                (Text -> String -> Credential -> IO (Creds m)
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