Merge pull request #1 from pbrisbin/master

Updates, fixes - request to maintain

Yesod/Auth/OAuth2.hs

@@ -1,55 +1,69 @@
-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
-module Yesod.Auth.OAuth2 where
+-- |
+--
+-- Generic OAuth2 plugin for Yesod
+--
+-- * See Yesod.Auth.OAuth2.Learn for example usage.
+--
+module Yesod.Auth.OAuth2
+    ( authOAuth2
+    , oauth2Url
+    , module Network.OAuth.OAuth2
+    ) where
 
 import Control.Monad.IO.Class
-import Data.ByteString          (ByteString)
+import Data.ByteString (ByteString)
-import Data.Text                (Text)
+import Data.Text (Text)
-import Data.Text.Encoding       (decodeUtf8With, encodeUtf8)
+import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
 import Data.Text.Encoding.Error (lenientDecode)
-import Data.Maybe
+import Network.OAuth.OAuth2
-import Network.HTTP.Conduit as C
 import Yesod.Auth
-import Yesod.Form
 import Yesod.Core
-import Yesod.Auth.OAuth2.Internal
+import Yesod.Form
 
 oauth2Url :: Text -> AuthRoute
 oauth2Url name = PluginR name ["forward"]
 
+authOAuth2 :: YesodAuth m
+           => Text   -- ^ Service name
+           -> OAuth2 -- ^ Service details
+
+           -- | This function defines how to take an @'AccessToken'@ and
+           --   retrieve additional information about the user, to be
+           --   set in the session as @'Creds'@. Usually this means a
+           --   second authorized request to @api/me.json@.
+           -> (AccessToken -> IO (Creds m))
+           -> AuthPlugin m
 authOAuth2 name oauth getCreds = AuthPlugin name dispatch login
+
     where
         url = PluginR name ["callback"]
-        dispatch "GET" ["forward"] = do
+
+        withCallback = do
             tm <- getRouteToParent
-            lift $ do
+            render <- lift $ getUrlRender
-                render <- getUrlRender
+            return $ oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
-                let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
+
-                redirect $ authorizationUrl oauth'
+        dispatch "GET" ["forward"] = do
+            authUrl <- fmap (bsToText . authorizationUrl) withCallback
+            lift $ redirect authUrl
+
         dispatch "GET" ["callback"] = do
             code <- lift $ runInputGet $ ireq textField "code"
-            mtoken <- liftIO $ postAccessToken oauth (encodeUtf8 code) (Just "authorization_code")
+            oauth' <- withCallback
-            case mtoken of
+            result <- liftIO $ fetchAccessToken oauth' (encodeUtf8 code)
-                Nothing -> permissionDenied "Couldn't get token"
+            case result of
-                Just token -> getCreds token
+                Left _ -> permissionDenied "Unable to retreive OAuth2 token"
-        disptach _ _ = notFound
+                Right token -> do
+                    creds <- liftIO $ getCreds token
+                    lift $ setCreds True creds
+
+        dispatch _ _ = notFound
+
         login tm = do
             render <- getUrlRender
             let oaUrl = render $ tm $ oauth2Url name
             [whamlet| <a href=#{oaUrl}>Login via #{name} |]
 
-oauth2Google clientId clientSecret = newOAuth2 { oauthClientId = encodeUtf8 clientId
-                                               , oauthClientSecret = encodeUtf8 clientSecret
-                                               , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth"
-                                               , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token" }
-
-cloudsdaleAuth clientId clientSecret = authOAuth2 "cloudsdale" oauth2 $ \token -> do
-    rsp <- request $ authorizeRequest token $ fromJust $ parseUrl "http://api.cloudsdale.org/v2/me.json"
-    undefined
-    where
-        oauth2 = newOAuth2 { oauthClientId = encodeUtf8 clientId
-                           , oauthClientSecret = encodeUtf8 clientSecret
-                           , oauthOAuthorizeEndpoint = "http://www.cloudsdale.org/oauth/authorize"
-                           , oauthAccessTokenEndpoint = "http://www.cloudsdale.org/oauth/token" }
-
 bsToText :: ByteString -> Text
 bsToText = decodeUtf8With lenientDecode

Yesod/Auth/OAuth2/Google.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- |
+--
+-- OAuth2 plugin for http://google.com
+--
+-- * Note: this module is unfinished, do not use.
+--
+module Yesod.Auth.OAuth2.Google
+    ( oauth2Google
+    , module Yesod.Auth.OAuth2
+    ) where
+
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
+import Yesod.Auth
+import Yesod.Auth.OAuth2
+
+oauth2Google :: YesodAuth m
+             => Text -- ^ Client ID
+             -> Text -- ^ Client Secret
+             -> AuthPlugin m
+oauth2Google clientId clientSecret = authOAuth2 "google"
+    (OAuth2
+        { oauthClientId            = encodeUtf8 clientId
+        , oauthClientSecret        = encodeUtf8 clientSecret
+        , oauthOAuthorizeEndpoint  = "https://accounts.google.com/o/oauth2/auth"
+        , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token"
+        , oauthCallback            = Nothing
+        })
+    undefined -- TODO

Yesod/Auth/OAuth2/Internal.hs

@@ -1,110 +0,0 @@
-{-# 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.ByteString.Lazy (toChunks)
-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 ((<$>))
-import Control.Monad (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 req = (withManager . httpLbs) (req { checkStatus = \_ _ _ -> Nothing })
- 
-getAccessToken' :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO BSL.ByteString
-getAccessToken' 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
-    req = fromJust $ parseUrl url
-    url = BS.unpack $ oauthAccessTokenEndpoint oa `BS.append` queryString
-    queryString = renderSimpleQuery True query
-    query = foldr step [] [ ("client_id", Just $ oauthClientId oa)
-                          , ("client_secret", Just $ oauthClientSecret oa)
-                          , ("code", Just code)
-                          , ("redirect_uri", oauthCallback oa)
-                          , ("grant_type", grant_type) ]
- 
-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
- 
-getAccessToken :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO (Maybe AccessToken)
-getAccessToken oa code grant_type = decode <$> getAccessToken' oa code grant_type
- 
-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 m -> Request m
-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 m -> Request m
-authorizeRequest (AccessToken token) req = req { requestHeaders = auth : requestHeaders req }
-    where
-        auth = ("Authorization", BS.concat ["Bearer ", token])

Yesod/Auth/OAuth2/Learn.hs

@@ -0,0 +1,76 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- |
+--
+-- OAuth2 plugin for http://learn.thoughtbot.com
+--
+-- * Authenticates against learn
+-- * Uses learn user id as credentials identifier
+-- * Returns first_name, last_name, and email as extras
+--
+module Yesod.Auth.OAuth2.Learn
+    ( oauth2Learn
+    , module Yesod.Auth.OAuth2
+    ) where
+
+import Control.Applicative ((<$>), (<*>))
+import Control.Monad (mzero)
+import Data.Aeson
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
+import Yesod.Auth
+import Yesod.Auth.OAuth2
+import qualified Data.Text as T
+
+data LearnUser = LearnUser
+    { learnUserId        :: Int
+    , learnUserFirstName :: Text
+    , learnUserLastName  :: Text
+    , learnUserEmail     :: Text
+    }
+
+instance FromJSON LearnUser where
+    parseJSON (Object o) =
+        LearnUser <$> o .: "id"
+                  <*> o .: "first_name"
+                  <*> o .: "last_name"
+                  <*> o .: "email"
+
+    parseJSON _ = mzero
+
+data LearnResponse = LearnResponse LearnUser
+
+instance FromJSON LearnResponse where
+    parseJSON (Object o) =
+        LearnResponse <$> o .: "user"
+
+    parseJSON _ = mzero
+
+oauth2Learn :: YesodAuth m
+            => Text -- ^ Client ID
+            -> Text -- ^ Client Secret
+            -> AuthPlugin m
+oauth2Learn clientId clientSecret = authOAuth2 "learn"
+    (OAuth2
+        { oauthClientId            = encodeUtf8 clientId
+        , oauthClientSecret        = encodeUtf8 clientSecret
+        , oauthOAuthorizeEndpoint  = "http://learn.thoughtbot.com/oauth/authorize"
+        , oauthAccessTokenEndpoint = "http://learn.thoughtbot.com/oauth/token"
+        , oauthCallback            = Nothing
+        })
+    fetchLearnProfile
+
+fetchLearnProfile :: AccessToken -> IO (Creds m)
+fetchLearnProfile token = do
+    result <- authGetJSON token "http://learn.thoughtbot.com/api/v1/me.json"
+
+    case result of
+        Right (LearnResponse user) -> return $ toCreds user
+        _ -> error "Invalid response for learn profile data"
+
+toCreds :: LearnUser -> Creds m
+toCreds user = Creds "learn"
+    (T.pack $ show $ learnUserId user)
+    [ ("first_name", learnUserFirstName user)
+    , ("last_name" , learnUserLastName user)
+    , ("email"     , learnUserEmail user)
+    ]

yesod-auth-oauth2.cabal

@@ -20,17 +20,22 @@ library
         cpp-options:     -DGHC7
     else
         build-depends:   base                >= 4         && < 4.3
+
     build-depends:   bytestring              >= 0.9.1.4
-                   , http-conduit            >= 1.9       && < 2
+                   , http-conduit            >= 2.0       && < 3.0
                    , http-types              >= 0.8       && < 0.9
-                   , aeson                   >= 0.6       && < 0.7
+                   , aeson                   >= 0.6       && < 0.8
                    , yesod-core              >= 1.2       && < 1.3
                    , yesod-auth              >= 1.2       && < 1.3
                    , 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
+                     Yesod.Auth.OAuth2.Google
+                     Yesod.Auth.OAuth2.Learn
+
     ghc-options:     -Wall
 
 source-repository head