    {-# 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
    (Int -> YesodOAuthException -> ShowS)
    -> (YesodOAuthException -> String)
    -> ([YesodOAuthException] -> ShowS)
    -> Show YesodOAuthException
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> YesodOAuthException -> ShowS
    showsPrec :: Int -> YesodOAuthException -> ShowS
    $cshow :: YesodOAuthException -> String
    show :: YesodOAuthException -> String
    $cshowList :: [YesodOAuthException] -> ShowS
    showList :: [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 = 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 -> m TypedContent
    Text -> Texts -> AuthHandler master 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
          :: Text
          -> [Text]
          -> AuthHandler master TypedContent
        dispatch :: Text -> Texts -> AuthHandler master TypedContent
    dispatch Text
    "GET" [Text
    "forward"] = do
            render <- m (Route master -> Text)
    m (Route (HandlerSite m) -> Text)
    forall (m :: * -> *).
    MonadHandler m =>
    m (Route (HandlerSite m) -> Text)
    getUrlRender
            tm <- getRouteToParent
            let oauth' = OAuth
    oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
            manager <- authHttpManager
            tok <- getTemporaryCredential oauth' manager
            setSession oauthSessionName $ lookupTokenSecret tok
            redirect $ authorizeUrl oauth' tok
        dispatch Text
    "GET" [] = do
          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 a b. m a -> (a -> m b) -> m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \case
            Just Text
    t -> Text -> m Text
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    t
            Maybe Text
    Nothing -> IO Text -> m Text
    forall a. IO a -> m a
    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 a. String -> IO a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "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 Text
    _ Texts
    _ = m TypedContent
    forall (m :: * -> *) a. MonadHandler m => m a
    notFound

        login :: (AuthRoute -> Route master) -> WidgetFor master ()
    login AuthRoute -> Route master
    tm = do
            render <- WidgetFor master (Route master -> Text)
    WidgetFor master (Route (HandlerSite (WidgetFor master)) -> Text)
    forall (m :: * -> *).
    MonadHandler m =>
    m (Route (HandlerSite m) -> Text)
    getUrlRender
            let 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 :: 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 (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 a. a -> IO a
    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 b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
    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' :: forall m.
    YesodAuth m =>
    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      = "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
                              })
                    (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 :: forall m. YesodAuth m => 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 :: forall m. YesodAuth m => 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 :: forall m. YesodAuth m => 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      = "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
                              })
                    (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