diff --git a/Yesod/Auth/OAuth2.hs b/Yesod/Auth/OAuth2.hs index c7e01ce..d659eab 100644 --- a/Yesod/Auth/OAuth2.hs +++ b/Yesod/Auth/OAuth2.hs @@ -23,17 +23,17 @@ import Data.Text (Text, pack) import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode) import Data.Typeable +import Network.HTTP.Conduit (Manager) import Network.OAuth.OAuth2 -import Network.HTTP.Conduit(Manager) import System.Random import Yesod.Auth import Yesod.Core import Yesod.Form -import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy as BL -- | Provider name and Aeson parse error -data YesodOAuth2Exception = InvalidProfileResponse Text BSL.ByteString +data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString deriving (Show, Typeable) instance Exception YesodOAuth2Exception @@ -52,52 +52,52 @@ authOAuth2 :: YesodAuth m -> AuthPlugin m authOAuth2 name oauth getCreds = AuthPlugin name dispatch login - where - url = PluginR name ["callback"] + where + url = PluginR name ["callback"] - withCallback csrfToken = do - tm <- getRouteToParent - render <- lift getUrlRender - return oauth - { oauthCallback = Just $ encodeUtf8 $ render $ tm url - , oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth - <> "&state=" <> encodeUtf8 csrfToken - } + withCallback csrfToken = do + tm <- getRouteToParent + render <- lift getUrlRender + return oauth + { oauthCallback = Just $ encodeUtf8 $ render $ tm url + , oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth + <> "&state=" <> encodeUtf8 csrfToken + } - dispatch "GET" ["forward"] = do - csrfToken <- liftIO generateToken - setSession tokenSessionKey csrfToken - authUrl <- bsToText . authorizationUrl <$> withCallback csrfToken - lift $ redirect authUrl + dispatch "GET" ["forward"] = do + csrfToken <- liftIO generateToken + setSession tokenSessionKey csrfToken + authUrl <- bsToText . authorizationUrl <$> withCallback csrfToken + lift $ redirect authUrl - dispatch "GET" ["callback"] = do - newToken <- lookupGetParam "state" - oldToken <- lookupSession tokenSessionKey - deleteSession tokenSessionKey - case newToken of - Just csrfToken | newToken == oldToken -> do - code <- lift $ runInputGet $ ireq textField "code" - oauth' <- withCallback csrfToken - master <- lift getYesod - result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (encodeUtf8 code) - case result of - Left _ -> permissionDenied "Unable to retreive OAuth2 token" - Right token -> do - creds <- liftIO $ getCreds (authHttpManager master) token - lift $ setCredsRedirect creds - _ -> - permissionDenied "Invalid OAuth2 state token" + dispatch "GET" ["callback"] = do + newToken <- lookupGetParam "state" + oldToken <- lookupSession tokenSessionKey + deleteSession tokenSessionKey + case newToken of + Just csrfToken | newToken == oldToken -> do + code <- lift $ runInputGet $ ireq textField "code" + oauth' <- withCallback csrfToken + master <- lift getYesod + result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (encodeUtf8 code) + case result of + Left _ -> permissionDenied "Unable to retreive OAuth2 token" + Right token -> do + creds <- liftIO $ getCreds (authHttpManager master) token + lift $ setCredsRedirect creds + _ -> + permissionDenied "Invalid OAuth2 state token" - dispatch _ _ = notFound + dispatch _ _ = notFound - generateToken = pack . take 30 . randomRs ('a', 'z') <$> newStdGen + generateToken = pack . take 30 . randomRs ('a', 'z') <$> newStdGen - tokenSessionKey :: Text - tokenSessionKey = "_yesod_oauth2_" <> name + tokenSessionKey :: Text + tokenSessionKey = "_yesod_oauth2_" <> name - login tm = [whamlet| - Login via #{name} - |] + login tm = [whamlet| + Login via #{name} + |] bsToText :: ByteString -> Text bsToText = decodeUtf8With lenientDecode diff --git a/Yesod/Auth/OAuth2/Github.hs b/Yesod/Auth/OAuth2/Github.hs index 4d759f2..d211251 100644 --- a/Yesod/Auth/OAuth2/Github.hs +++ b/Yesod/Auth/OAuth2/Github.hs @@ -17,27 +17,28 @@ import Control.Applicative ((<$>), (<*>)) import Control.Exception.Lifted import Control.Monad (mzero) import Data.Aeson -import Data.Text (Text) import Data.Monoid ((<>)) +import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Network.HTTP.Conduit (Manager) import Yesod.Auth import Yesod.Auth.OAuth2 -import Network.HTTP.Conduit(Manager) + import qualified Data.Text as T data GithubUser = GithubUser - { githubUserId :: Int - , githubUserName :: Maybe Text + { githubUserId :: Int + , githubUserName :: Maybe Text , githubUserLogin :: Text , githubUserAvatarUrl :: Text } instance FromJSON GithubUser where - parseJSON (Object o) = - GithubUser <$> o .: "id" - <*> o .:? "name" - <*> o .: "login" - <*> o .: "avatar_url" + parseJSON (Object o) = GithubUser + <$> o .: "id" + <*> o .:? "name" + <*> o .: "login" + <*> o .: "avatar_url" parseJSON _ = mzero @@ -46,8 +47,8 @@ data GithubUserEmail = GithubUserEmail } instance FromJSON GithubUserEmail where - parseJSON (Object o) = - GithubUserEmail <$> o .: "email" + parseJSON (Object o) = GithubUserEmail + <$> o .: "email" parseJSON _ = mzero @@ -63,14 +64,14 @@ oauth2GithubScoped :: YesodAuth m -> [Text] -- ^ List of scopes to request -> AuthPlugin m oauth2GithubScoped clientId clientSecret scopes = authOAuth2 "github" oauth fetchGithubProfile - where - oauth = OAuth2 - { oauthClientId = encodeUtf8 clientId - , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scope=" <> T.intercalate "," scopes - , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token" - , oauthCallback = Nothing - } + where + oauth = OAuth2 + { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scope=" <> T.intercalate "," scopes + , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token" + , oauthCallback = Nothing + } fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m) fetchGithubProfile manager token = do @@ -84,14 +85,17 @@ fetchGithubProfile manager token = do (_, Left err) -> throwIO $ InvalidProfileResponse "github" err toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m -toCreds user userMail token = Creds "github" - (T.pack $ show $ githubUserId user) - cExtra - where - cExtra = [ ("email", githubUserEmail $ head userMail) - , ("login", githubUserLogin user) - , ("avatar_url", githubUserAvatarUrl user) - , ("access_token", decodeUtf8 $ accessToken token) - ] ++ (maybeName $ githubUserName user) - maybeName Nothing = [] - maybeName (Just name) = [("name", name)] +toCreds user userMail token = Creds + { credsPlugin = "github" + , credsIdent = T.pack $ show $ githubUserId user + , credsExtra = + [ ("email", githubUserEmail $ head userMail) + , ("login", githubUserLogin user) + , ("avatar_url", githubUserAvatarUrl user) + , ("access_token", decodeUtf8 $ accessToken token) + ] ++ maybeName (githubUserName user) + } + + where + maybeName Nothing = [] + maybeName (Just name) = [("name", name)] diff --git a/Yesod/Auth/OAuth2/Spotify.hs b/Yesod/Auth/OAuth2/Spotify.hs index 600f015..669078c 100644 --- a/Yesod/Auth/OAuth2/Spotify.hs +++ b/Yesod/Auth/OAuth2/Spotify.hs @@ -1,5 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} - +-- | +-- +-- OAuth2 plugin for http://spotify.com +-- module Yesod.Auth.OAuth2.Spotify ( oauth2Spotify , module Yesod.Auth.OAuth2 @@ -16,6 +19,7 @@ import Data.Text.Encoding (encodeUtf8) import Network.HTTP.Conduit(Manager) import Yesod.Auth import Yesod.Auth.OAuth2 + import qualified Data.ByteString as B import qualified Data.Text as T @@ -26,49 +30,50 @@ data SpotifyUserImage = SpotifyUserImage } instance FromJSON SpotifyUserImage where - parseJSON (Object v) = SpotifyUserImage <$> - v .: "height" <*> - v .: "width" <*> - v .: "url" + parseJSON (Object v) = SpotifyUserImage + <$> v .: "height" + <*> v .: "width" + <*> v .: "url" parseJSON _ = mzero data SpotifyUser = SpotifyUser - { spotifyUserId :: Text - , spotifyUserHref :: Text - , spotifyUserUri :: Text + { spotifyUserId :: Text + , spotifyUserHref :: Text + , spotifyUserUri :: Text , spotifyUserDisplayName :: Maybe Text - , spotifyUserProduct :: Maybe Text - , spotifyUserCountry :: Maybe Text - , spotifyUserEmail :: Maybe Text - , spotifyUserImages :: Maybe [SpotifyUserImage] + , spotifyUserProduct :: Maybe Text + , spotifyUserCountry :: Maybe Text + , spotifyUserEmail :: Maybe Text + , spotifyUserImages :: Maybe [SpotifyUserImage] } instance FromJSON SpotifyUser where - parseJSON (Object v) = SpotifyUser <$> - v .: "id" <*> - v .: "href" <*> - v .: "uri" <*> - v .:? "display_name" <*> - v .:? "product" <*> - v .:? "country" <*> - v .:? "email" <*> - v .:? "images" + parseJSON (Object v) = SpotifyUser + <$> v .: "id" + <*> v .: "href" + <*> v .: "uri" + <*> v .:? "display_name" + <*> v .:? "product" + <*> v .:? "country" + <*> v .:? "email" + <*> v .:? "images" + parseJSON _ = mzero oauth2Spotify :: YesodAuth m - => Text -- ^ Client ID - -> Text -- ^ Client Secret - -> [ByteString] -- ^ Scopes - -> AuthPlugin m + => Text -- ^ Client ID + -> Text -- ^ Client Secret + -> [ByteString] -- ^ Scopes + -> AuthPlugin m oauth2Spotify clientId clientSecret scope = authOAuth2 "spotify" - (OAuth2 - { oauthClientId = encodeUtf8 clientId - , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = B.append "https://accounts.spotify.com/authorize?scope=" (B.intercalate "%20" scope) + OAuth2 + { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = B.append "https://accounts.spotify.com/authorize?scope=" (B.intercalate "%20" scope) , oauthAccessTokenEndpoint = "https://accounts.spotify.com/api/token" - , oauthCallback = Nothing - }) + , oauthCallback = Nothing + } fetchSpotifyProfile fetchSpotifyProfile :: Manager -> AccessToken -> IO (Creds m) @@ -79,9 +84,11 @@ fetchSpotifyProfile manager token = do Left err -> throwIO $ InvalidProfileResponse "spotify" err toCreds :: SpotifyUser -> Creds m -toCreds user = Creds "spotify" - (spotifyUserId user) - (mapMaybe getExtra extrasTemplate) +toCreds user = Creds + { credsPlugin = "spotify" + , credsIdent = spotifyUserId user + , credsExtra = mapMaybe getExtra extrasTemplate + } where userImage :: Maybe SpotifyUserImage @@ -90,18 +97,15 @@ toCreds user = Creds "spotify" userImagePart :: (SpotifyUserImage -> Maybe a) -> Maybe a userImagePart getter = userImage >>= getter - extrasTemplate = [ ("href" , Just $ spotifyUserHref user) - , ("uri" , Just $ spotifyUserUri user) + extrasTemplate = [ ("href", Just $ spotifyUserHref user) + , ("uri", Just $ spotifyUserUri user) , ("display_name", spotifyUserDisplayName user) - , ("product" , spotifyUserProduct user) - , ("country" , spotifyUserCountry user) - , ("email" , spotifyUserEmail user) - , ("image_url" , userImage >>= - return . spotifyUserImageUrl) - , ("image_height", userImagePart spotifyUserImageHeight >>= - return . T.pack . show) - , ("image_width" , userImagePart spotifyUserImageWidth >>= - return . T.pack . show) + , ("product", spotifyUserProduct user) + , ("country", spotifyUserCountry user) + , ("email", spotifyUserEmail user) + , ("image_url", spotifyUserImageUrl <$> userImage) + , ("image_height", T.pack . show <$> userImagePart spotifyUserImageHeight) + , ("image_width", T.pack . show <$> userImagePart spotifyUserImageWidth) ] getExtra :: (Text, Maybe Text) -> Maybe (Text, Text) diff --git a/Yesod/Auth/OAuth2/Upcase.hs b/Yesod/Auth/OAuth2/Upcase.hs index e3c6ce3..fbfca3f 100644 --- a/Yesod/Auth/OAuth2/Upcase.hs +++ b/Yesod/Auth/OAuth2/Upcase.hs @@ -24,26 +24,26 @@ import Network.HTTP.Conduit(Manager) import qualified Data.Text as T data UpcaseUser = UpcaseUser - { upcaseUserId :: Int + { upcaseUserId :: Int , upcaseUserFirstName :: Text - , upcaseUserLastName :: Text - , upcaseUserEmail :: Text + , upcaseUserLastName :: Text + , upcaseUserEmail :: Text } instance FromJSON UpcaseUser where - parseJSON (Object o) = - UpcaseUser <$> o .: "id" - <*> o .: "first_name" - <*> o .: "last_name" - <*> o .: "email" + parseJSON (Object o) = UpcaseUser + <$> o .: "id" + <*> o .: "first_name" + <*> o .: "last_name" + <*> o .: "email" parseJSON _ = mzero data UpcaseResponse = UpcaseResponse UpcaseUser instance FromJSON UpcaseResponse where - parseJSON (Object o) = - UpcaseResponse <$> o .: "user" + parseJSON (Object o) = UpcaseResponse + <$> o .: "user" parseJSON _ = mzero @@ -53,11 +53,11 @@ oauth2Upcase :: YesodAuth m -> AuthPlugin m oauth2Upcase clientId clientSecret = authOAuth2 "upcase" OAuth2 - { oauthClientId = encodeUtf8 clientId - , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = "http://upcase.com/oauth/authorize" + { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = "http://upcase.com/oauth/authorize" , oauthAccessTokenEndpoint = "http://upcase.com/oauth/token" - , oauthCallback = Nothing + , oauthCallback = Nothing } fetchUpcaseProfile @@ -70,9 +70,12 @@ fetchUpcaseProfile manager token = do Left err -> throwIO $ InvalidProfileResponse "upcase" err toCreds :: UpcaseUser -> Creds m -toCreds user = Creds "upcase" - (T.pack $ show $ upcaseUserId user) - [ ("first_name", upcaseUserFirstName user) - , ("last_name" , upcaseUserLastName user) - , ("email" , upcaseUserEmail user) - ] +toCreds user = Creds + { credsPlugin = "upcase" + , credsIdent = T.pack $ show $ upcaseUserId user + , credsExtra = + [ ("first_name", upcaseUserFirstName user) + , ("last_name" , upcaseUserLastName user) + , ("email" , upcaseUserEmail user) + ] + }