{-# 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                        -- ^ 'OAuth' data-type for signing.
          -> (Credential -> IO (Creds master)) -- ^ How to extract ident.
          -> 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)
mkExtractCreds :: forall m. 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 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 -- ^ Consumer Key
             -> ByteString -- ^ Consumer Secret
             -> String
             -> AuthPlugin m
authTwitter' :: forall m.
YesodAuth m =>
ByteString -> ByteString -> String -> AuthPlugin m
authTwitter' 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)

-- | 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 :: forall m. YesodAuth m => ByteString -> ByteString -> AuthPlugin m
authTwitter 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" #-}

-- | 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 :: forall m. YesodAuth m => ByteString -> ByteString -> AuthPlugin m
authTwitterUsingUserId ByteString
key ByteString
secret = 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 :: 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