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)
+ ]
+ }