diff --git a/Yesod/Auth/OAuth2/Github.hs b/Yesod/Auth/OAuth2/Github.hs --- a/Yesod/Auth/OAuth2/Github.hs +++ b/Yesod/Auth/OAuth2/Github.hs @@ -21,6 +21,8 @@ import Control.Exception.Lifted import Control.Monad (mzero) import Data.Aeson +import Data.Maybe (fromMaybe) +import Data.List (find) import Data.Monoid ((<>)) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8) @@ -36,6 +38,7 @@ , githubUserLogin :: Text , githubUserAvatarUrl :: Text , githubUserLocation :: Text + , githubUserPublicEmail :: Maybe Text } instance FromJSON GithubUser where @@ -45,16 +48,19 @@ <*> o .: "login" <*> o .: "avatar_url" <*> o .: "location" + <*> o .: "email" parseJSON _ = mzero data GithubUserEmail = GithubUserEmail - { githubUserEmail :: Text + { githubUserEmailAddress :: Text + , githubUserEmailPrimary :: Bool } instance FromJSON GithubUserEmail where parseJSON (Object o) = GithubUserEmail <$> o .: "email" + <*> o .: "primary" parseJSON _ = mzero @@ -91,18 +97,25 @@ (_, Left err) -> throwIO $ InvalidProfileResponse "github" err toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m -toCreds user userMail token = Creds +toCreds user userMails token = Creds { credsPlugin = "github" , credsIdent = T.pack $ show $ githubUserId user , credsExtra = - [ ("email", githubUserEmail $ head userMail) + [ ("email", githubUserEmailAddress email) , ("login", githubUserLogin user) , ("avatar_url", githubUserAvatarUrl user) , ("location", githubUserLocation user) , ("access_token", decodeUtf8 $ accessToken token) - ] ++ maybeName (githubUserName user) + ] + ++ maybeName (githubUserName user) + ++ maybePublicEmail (githubUserPublicEmail user) } where + email = fromMaybe (head userMails) $ find githubUserEmailPrimary userMails + maybeName Nothing = [] maybeName (Just name) = [("name", name)] + + maybePublicEmail Nothing = [] + maybePublicEmail (Just e) = [("public_email", e)] diff --git a/Yesod/Auth/OAuth2/Twitter.hs b/Yesod/Auth/OAuth2/Twitter.hs deleted file mode 100644 --- a/Yesod/Auth/OAuth2/Twitter.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -module Yesod.Auth.OAuth2.Twitter - ( oauth2Twitter - , module Yesod.Auth.OAuth2 - ) where - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>)) -#endif - -import Control.Monad (mzero) -import Data.Aeson -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import Yesod.Auth -import Yesod.Auth.OAuth2 - -data TwitterUser = TwitterUser - { twitterUserId :: Text - , twitterUserName :: Text - , twitterScreenName :: Text - } - -instance FromJSON TwitterUser where - parseJSON (Object o) = TwitterUser - <$> o .: "id_str" - <*> o .: "name" - <*> o .: "screen_name" - - parseJSON _ = mzero - -oauth2Twitter :: YesodAuth m - => Text -- ^ Client ID - -> Text -- ^ Client Secret - -> AuthPlugin m -oauth2Twitter clientId clientSecret = authOAuth2 "twitter" - OAuth2 - { oauthClientId = encodeUtf8 clientId - , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = "https://api.twitter.com/oauth/authorize" - , oauthAccessTokenEndpoint = "https://api.twitter.com/oauth/access_token" - , oauthCallback = Nothing - } - $ fromProfileURL "twitter" "https://api.twitter.com/1.1/account/verify_credentials.json" - $ \user -> Creds - { credsPlugin = "twitter" - , credsIdent = twitterUserId user - , credsExtra = - [ ("name", twitterUserName user) - , ("screen_name", twitterScreenName user) - ] - } diff --git a/example/main.hs b/example/main.hs new file mode 100644 --- /dev/null +++ b/example/main.hs @@ -0,0 +1,119 @@ +-- | +-- +-- This is a single-file example of using yesod-auth-oauth2. +-- +-- It can be run with: +-- +-- > stack build --flag yesod-auth-oauth2:example +-- > stack exec yesod-auth-oauth2-example +-- > $BROWSER http://localhost:3000 +-- +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Main where + +import Data.Monoid ((<>)) +import Data.Text (Text) +import LoadEnv +import Network.HTTP.Conduit +import Network.Wai.Handler.Warp (runEnv) +import System.Environment (getEnv) +import Yesod +import Yesod.Auth +import Yesod.Auth.OAuth2.Github + +import qualified Data.Text as T + +data OAuthKeys = OAuthKeys + { oauthKeysClientId :: Text + , oauthKeysClientSecret :: Text + } + +loadOAuthKeysEnv :: String -> IO OAuthKeys +loadOAuthKeysEnv prefix = OAuthKeys + <$> (getEnvT $ prefix <> "_CLIENT_ID") + <*> (getEnvT $ prefix <> "_CLIENT_SECRET") + + where + getEnvT = fmap T.pack . getEnv + +data App = App + { appHttpManager :: Manager + , appGithubKeys :: OAuthKeys + -- , appGoogleKeys :: OAuthKeys + -- , etc... + } + +mkYesod "App" [parseRoutes| + / RootR GET + /auth AuthR Auth getAuth +|] + +instance Yesod App where + -- redirect_uri must be absolute to avoid callback mismatch error + approot = ApprootStatic "http://localhost:3000" + +instance YesodAuth App where + type AuthId App = Text + loginDest _ = RootR + logoutDest _ = RootR + + -- Disable any attempt to read persisted authenticated state + maybeAuthId = return Nothing + + -- Copy the Creds response into the session for viewing after + authenticate c = do + mapM_ (uncurry setSession) $ + [ ("credsIdent", credsIdent c) + , ("credsPlugin", credsPlugin c) + ] ++ credsExtra c + + return $ Authenticated "1" + + authHttpManager = appHttpManager + + authPlugins m = + [ oauth2Github + (oauthKeysClientId $ appGithubKeys m) + (oauthKeysClientSecret $ appGithubKeys m) + -- , oauth2Google + -- (oauthKeysClientId $ appGoogleKeys m) + -- (oauthKeysClientSecret $ appGoogleKeys m) + -- , etc... + ] + +instance RenderMessage App FormMessage where + renderMessage _ _ = defaultFormMessage + +getRootR :: Handler Html +getRootR = do + sess <- getSession + + defaultLayout [whamlet| +

Yesod Auth OAuth2 Example +

+ Log in +

Session Information + 
+            #{show sess}
+    |]
+
+mkFoundation :: IO App
+mkFoundation = do
+    loadEnv
+
+    appHttpManager <- newManager tlsManagerSettings
+    appGithubKeys <- loadOAuthKeysEnv "GITHUB"
+    -- appGoogleKeys <- loadOAuthKeysEnv "GOOGLE"
+    -- etc...
+
+    return App{..}
+
+main :: IO ()
+main = runEnv 3000 =<< toWaiApp =<< mkFoundation
diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal
--- a/yesod-auth-oauth2.cabal
+++ b/yesod-auth-oauth2.cabal
@@ -1,5 +1,5 @@
 name:            yesod-auth-oauth2
-version:         0.1.6
+version:         0.1.7
 license:         BSD3
 license-file:    LICENSE
 author:          Tom Streller
@@ -16,6 +16,10 @@
    description: Get Network.URI from the network-uri package
    default: True
 
+flag example
+  description: Build the example application
+  default: False
+
 library
     if flag(network-uri)
         build-depends: network-uri >= 2.6
@@ -43,12 +47,30 @@
                      Yesod.Auth.OAuth2.Github
                      Yesod.Auth.OAuth2.Google
                      Yesod.Auth.OAuth2.Spotify
-                     Yesod.Auth.OAuth2.Twitter
                      Yesod.Auth.OAuth2.Upcase
                      Yesod.Auth.OAuth2.EveOnline
                      Yesod.Auth.OAuth2.Nylas
 
     ghc-options:     -Wall
+
+executable yesod-auth-oauth2-example
+  if flag(example)
+    buildable: True
+  else
+    buildable: False
+
+  hs-source-dirs:      example
+  main-is:             main.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , containers
+                     , http-conduit
+                     , load-env
+                     , text
+                     , warp
+                     , yesod
+                     , yesod-auth
+                     , yesod-auth-oauth2
 
 test-suite test
   type:              exitcode-stdio-1.0