Use Network.OAuth.OAuth2

* Provides basically the same interface
* Re-export it for making additional requests

Yesod/Auth/OAuth2.hs

@@ -1,8 +1,9 @@
-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
 module Yesod.Auth.OAuth2
     ( authOAuth2
     , oauth2Google
     , oauth2Learn
+    , module Network.OAuth.OAuth2
     ) where
 
 import Control.Monad.IO.Class
@@ -13,7 +14,7 @@ import Data.Text.Encoding.Error (lenientDecode)
 import Yesod.Auth
 import Yesod.Form
 import Yesod.Core
-import Yesod.Auth.OAuth2.Internal
+import Network.OAuth.OAuth2
 
 oauth2Url :: Text -> AuthRoute
 oauth2Url name = PluginR name ["forward"]
@@ -43,10 +44,10 @@ authOAuth2 name oauth mkCreds = AuthPlugin name dispatch login
             render <- lift $ getUrlRender
             code <- lift $ runInputGet $ ireq textField "code"
             let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
-            mtoken <- liftIO $ postAccessToken oauth' (encodeUtf8 code) (Just "authorization_code")
+            result <- liftIO $ fetchAccessToken oauth' (encodeUtf8 code)
-            case mtoken of
+            case result of
-                Nothing -> permissionDenied "Couldn't get token"
+                Left _ -> permissionDenied "Unable to retreive OAuth2 token"
-                Just token -> do
+                Right token -> do
                     creds <- liftIO $ mkCreds token
                     lift $ setCreds True creds
         dispatch _ _ = notFound
@@ -56,17 +57,21 @@ authOAuth2 name oauth mkCreds = AuthPlugin name dispatch login
             [whamlet| <a href=#{oaUrl}>Login via #{name} |]
 
 oauth2Google :: Text -> Text -> OAuth2
-oauth2Google clientId clientSecret = newOAuth2 { oauthClientId = encodeUtf8 clientId
+oauth2Google clientId clientSecret = OAuth2
-                                               , oauthClientSecret = encodeUtf8 clientSecret
+    { oauthClientId            = encodeUtf8 clientId
-                                               , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth"
+    , oauthClientSecret        = encodeUtf8 clientSecret
-                                               , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token" }
+    , oauthOAuthorizeEndpoint  = "https://accounts.google.com/o/oauth2/auth"
+    , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token"
+    , oauthCallback            = Nothing
+    }
 
 oauth2Learn :: Text -> Text -> OAuth2
-oauth2Learn clientId clientSecret = newOAuth2
+oauth2Learn clientId clientSecret = OAuth2
     { oauthClientId            = encodeUtf8 clientId
     , oauthClientSecret        = encodeUtf8 clientSecret
     , oauthOAuthorizeEndpoint  = "http://learn.thoughtbot.com/oauth/authorize"
     , oauthAccessTokenEndpoint = "http://learn.thoughtbot.com/oauth/token"
+    , oauthCallback            = Nothing
     }
 
 bsToText :: ByteString -> Text

Yesod/Auth/OAuth2/Internal.hs

@@ -1,97 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-module Yesod.Auth.OAuth2.Internal where
-
-{- see https://gist.github.com/qzchenwl/2351071 -}
-
-import Data.Aeson
-import qualified Data.ByteString.Char8 as BS
-import qualified Data.ByteString.Lazy.Char8 as BSL
-import Data.List
-import Data.Maybe
-import Data.Typeable (Typeable)
-import Network.HTTP.Types (renderSimpleQuery, parseSimpleQuery)
-import qualified Network.HTTP.Types as HT
-import Network.HTTP.Conduit as C
-import Control.Exception
-import Control.Applicative ((<$>), pure)
-import Control.Monad (mzero)
-import Data.Text.Encoding (encodeUtf8)
-
-instance FromJSON BS.ByteString where
-    parseJSON (String t) = pure $ encodeUtf8 t
-    parseJSON _          = mzero
-
-data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString
-                     , oauthClientSecret :: BS.ByteString
-                     , oauthOAuthorizeEndpoint :: BS.ByteString
-                     , oauthAccessTokenEndpoint :: BS.ByteString
-                     , oauthCallback :: Maybe BS.ByteString
-                     , oauthAccessToken :: Maybe BS.ByteString
-                     } deriving (Show, Eq)
-
-data OAuthException = OAuthException String
-                      deriving (Show, Eq, Typeable)
-
-instance Exception OAuthException
-
-newOAuth2 :: OAuth2
-newOAuth2 = OAuth2 { oauthClientId = error "You must specify client id."
-                   , oauthClientSecret = error "You must specify client secret."
-                   , oauthOAuthorizeEndpoint = error "You must specify authorize endpoint."
-                   , oauthAccessTokenEndpoint = error "You must specify access_token endpoint."
-                   , oauthCallback = Nothing
-                   , oauthAccessToken = Nothing
-                   }
-
-authorizationUrl :: OAuth2 -> BS.ByteString
-authorizationUrl oa = oauthOAuthorizeEndpoint oa `BS.append` queryString'
-  where queryString' = renderSimpleQuery True query
-        query = foldr step [] [ ("client_id", Just $ oauthClientId oa)
-                              , ("response_type", Just "code")
-                              , ("redirect_uri", oauthCallback oa)]
-
-request :: Request -> IO (Response BSL.ByteString)
-request req = (withManager . httpLbs) (req { checkStatus = \_ _ _ -> Nothing })
-
-postAccessToken' :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO BSL.ByteString
-postAccessToken' oa code grant_type = do
-    rsp <- request req
-    if (HT.statusCode . responseStatus) rsp == 200
-        then return $ responseBody rsp
-        else throwIO . OAuthException $ "Gaining access_token failed: " ++ BSL.unpack (responseBody rsp)
-  where
-    toPost r = r { method = "POST" }
-    req = urlEncodedBody query . toPost . fromJust $ parseUrl url
-    url = BS.unpack $ oauthAccessTokenEndpoint oa
-    query = foldr step [] [ ("client_id", Just $ oauthClientId oa)
-                          , ("client_secret", Just $ oauthClientSecret oa)
-                          , ("code", Just code)
-                          , ("redirect_uri", oauthCallback oa)
-                          , ("grant_type", grant_type) ]
-
-step :: (a, Maybe b) -> [(a, b)] -> [(a, b)]
-step (a, Just b) xs = (a, b):xs
-step _           xs = xs
-
-postAccessToken :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO (Maybe AccessToken)
-postAccessToken oa code grant_type = decode <$> postAccessToken' oa code grant_type
-
-data AccessToken = AccessToken { accessToken :: BS.ByteString } deriving (Show)
-instance FromJSON AccessToken where
-    parseJSON (Object o) = AccessToken <$> o .: "access_token"
-    parseJSON _          = mzero
-
-signRequest :: OAuth2 -> Request -> Request
-signRequest oa req = req { queryString = (renderSimpleQuery False newQuery) }
-  where
-    newQuery = case oauthAccessToken oa of
-                    Just at -> insert ("oauth_token", at) oldQuery
-                    _       -> insert ("client_id", oauthClientId oa) . insert ("client_secret", oauthClientSecret oa) $ oldQuery
-    oldQuery = parseSimpleQuery (queryString req)
-
-authorizeRequest :: AccessToken -> Request -> Request
-authorizeRequest (AccessToken token) req = req { requestHeaders = auth : requestHeaders req }
-    where
-        auth = ("Authorization", BS.concat ["Bearer ", token])

yesod-auth-oauth2.cabal

@@ -20,6 +20,7 @@ library
         cpp-options:     -DGHC7
     else
         build-depends:   base                >= 4         && < 4.3
+
     build-depends:   bytestring              >= 0.9.1.4
                    , http-conduit            >= 2.0       && < 3.0
                    , http-types              >= 0.8       && < 0.9
@@ -29,8 +30,10 @@ library
                    , text                    >= 0.7       && < 0.12
                    , yesod-form              >= 1.3       && < 1.4
                    , transformers            >= 0.2.2     && < 0.4
+                   , hoauth2                 >= 0.3.6     && < 0.4
+
     exposed-modules: Yesod.Auth.OAuth2
-    other-modules: Yesod.Auth.OAuth2.Internal
+
     ghc-options:     -Wall
 
 source-repository head