haskell/yesod-auth-oauth2
1
0
Fork 0
mirror of https://github.com/freckle/yesod-auth-oauth2.git synced 2026-04-30 14:44:54 +02:00
Code Issues Actions Packages Projects Releases Wiki Activity

Use consistent style throughout project

Browse Source 
- Alphabetize imports
- Place qualified imports separate and last
- BL for ByteString.Lazy
- Don't align tokens in tuple lists or record assignments
- Two-space indent for where keyword
- Use record syntax for Creds
- Break before operators in Applicative expressions
- Consistent whitespace throughout

Resolves #19
This commit is contained in:
patrick brisbin 2015-03-25 16:24:30 -04:00
parent 029122f662
commit 0b0e6c179d
No known key found for this signature in database
GPG Key ID: DB04E2CE780A17DE
4 changed files with 148 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
Yesod/Auth/OAuth2.hs
View File

@ -23,17 +23,17 @@ import Data.Text (Text, pack)
import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Data.Typeable import Data.Typeable
import Network.HTTP.Conduit (Manager)
import Network.OAuth.OAuth2 import Network.OAuth.OAuth2
import Network.HTTP.Conduit(Manager)
import System.Random import System.Random
import Yesod.Auth import Yesod.Auth
import Yesod.Core import Yesod.Core
import Yesod.Form import Yesod.Form
import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy as BL
-- | Provider name and Aeson parse error -- | Provider name and Aeson parse error
data YesodOAuth2Exception = InvalidProfileResponse Text BSL.ByteString data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString
deriving (Show, Typeable) deriving (Show, Typeable)
instance Exception YesodOAuth2Exception instance Exception YesodOAuth2Exception
@ -52,52 +52,52 @@ authOAuth2 :: YesodAuth m
-> AuthPlugin m -> AuthPlugin m
authOAuth2 name oauth getCreds = AuthPlugin name dispatch login authOAuth2 name oauth getCreds = AuthPlugin name dispatch login
where where
url = PluginR name ["callback"] url = PluginR name ["callback"]
withCallback csrfToken = do withCallback csrfToken = do
tm <- getRouteToParent tm <- getRouteToParent
render <- lift getUrlRender render <- lift getUrlRender
return oauth return oauth
{ oauthCallback = Just $ encodeUtf8 $ render $ tm url { oauthCallback = Just $ encodeUtf8 $ render $ tm url
, oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth , oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth
<> "&state=" <> encodeUtf8 csrfToken <> "&state=" <> encodeUtf8 csrfToken
} }
dispatch "GET" ["forward"] = do dispatch "GET" ["forward"] = do
csrfToken <- liftIO generateToken csrfToken <- liftIO generateToken
setSession tokenSessionKey csrfToken setSession tokenSessionKey csrfToken
authUrl <- bsToText . authorizationUrl <$> withCallback csrfToken authUrl <- bsToText . authorizationUrl <$> withCallback csrfToken
lift $ redirect authUrl lift $ redirect authUrl
dispatch "GET" ["callback"] = do dispatch "GET" ["callback"] = do
newToken <- lookupGetParam "state" newToken <- lookupGetParam "state"
oldToken <- lookupSession tokenSessionKey oldToken <- lookupSession tokenSessionKey
deleteSession tokenSessionKey deleteSession tokenSessionKey
case newToken of case newToken of
Just csrfToken | newToken == oldToken -> do Just csrfToken | newToken == oldToken -> do
code <- lift $ runInputGet $ ireq textField "code" code <- lift $ runInputGet $ ireq textField "code"
oauth' <- withCallback csrfToken oauth' <- withCallback csrfToken
master <- lift getYesod master <- lift getYesod
result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (encodeUtf8 code) result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (encodeUtf8 code)
case result of case result of
Left _ -> permissionDenied "Unable to retreive OAuth2 token" Left _ -> permissionDenied "Unable to retreive OAuth2 token"
Right token -> do Right token -> do
creds <- liftIO $ getCreds (authHttpManager master) token creds <- liftIO $ getCreds (authHttpManager master) token
lift $ setCredsRedirect creds lift $ setCredsRedirect creds
_ -> _ ->
permissionDenied "Invalid OAuth2 state token" 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 :: Text
tokenSessionKey = "_yesod_oauth2_" <> name tokenSessionKey = "_yesod_oauth2_" <> name
login tm = [whamlet| login tm = [whamlet|
<a href=@{tm $ oauth2Url name}>Login via #{name} <a href=@{tm $ oauth2Url name}>Login via #{name}
|] |]
bsToText :: ByteString -> Text bsToText :: ByteString -> Text
bsToText = decodeUtf8With lenientDecode bsToText = decodeUtf8With lenientDecode

64
Yesod/Auth/OAuth2/Github.hs
View File

@ -17,27 +17,28 @@ import Control.Applicative ((<$>), (<*>))
import Control.Exception.Lifted import Control.Exception.Lifted
import Control.Monad (mzero) import Control.Monad (mzero)
import Data.Aeson import Data.Aeson
import Data.Text (Text)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Network.HTTP.Conduit (Manager)
import Yesod.Auth import Yesod.Auth
import Yesod.Auth.OAuth2 import Yesod.Auth.OAuth2
import Network.HTTP.Conduit(Manager)
import qualified Data.Text as T import qualified Data.Text as T
data GithubUser = GithubUser data GithubUser = GithubUser
{ githubUserId :: Int { githubUserId :: Int
, githubUserName :: Maybe Text , githubUserName :: Maybe Text
, githubUserLogin :: Text , githubUserLogin :: Text
, githubUserAvatarUrl :: Text , githubUserAvatarUrl :: Text
} }
instance FromJSON GithubUser where instance FromJSON GithubUser where
parseJSON (Object o) = parseJSON (Object o) = GithubUser
GithubUser <$> o .: "id" <$> o .: "id"
<*> o .:? "name" <*> o .:? "name"
<*> o .: "login" <*> o .: "login"
<*> o .: "avatar_url" <*> o .: "avatar_url"
parseJSON _ = mzero parseJSON _ = mzero
@ -46,8 +47,8 @@ data GithubUserEmail = GithubUserEmail
} }
instance FromJSON GithubUserEmail where instance FromJSON GithubUserEmail where
parseJSON (Object o) = parseJSON (Object o) = GithubUserEmail
GithubUserEmail <$> o .: "email" <$> o .: "email"
parseJSON _ = mzero parseJSON _ = mzero
@ -63,14 +64,14 @@ oauth2GithubScoped :: YesodAuth m
-> [Text] -- ^ List of scopes to request -> [Text] -- ^ List of scopes to request
-> AuthPlugin m -> AuthPlugin m
oauth2GithubScoped clientId clientSecret scopes = authOAuth2 "github" oauth fetchGithubProfile oauth2GithubScoped clientId clientSecret scopes = authOAuth2 "github" oauth fetchGithubProfile
where where
oauth = OAuth2 oauth = OAuth2
{ oauthClientId = encodeUtf8 clientId { oauthClientId = encodeUtf8 clientId
, oauthClientSecret = encodeUtf8 clientSecret , oauthClientSecret = encodeUtf8 clientSecret
, oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scope=" <> T.intercalate "," scopes , oauthOAuthorizeEndpoint = encodeUtf8 $ "https://github.com/login/oauth/authorize?scope=" <> T.intercalate "," scopes
, oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token" , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token"
, oauthCallback = Nothing , oauthCallback = Nothing
} }
fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m) fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m)
fetchGithubProfile manager token = do fetchGithubProfile manager token = do
@ -84,14 +85,17 @@ fetchGithubProfile manager token = do
(_, Left err) -> throwIO $ InvalidProfileResponse "github" err (_, Left err) -> throwIO $ InvalidProfileResponse "github" err
toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m
toCreds user userMail token = Creds "github" toCreds user userMail token = Creds
(T.pack $ show $ githubUserId user) { credsPlugin = "github"
cExtra , credsIdent = T.pack $ show $ githubUserId user
where , credsExtra =
cExtra = [ ("email", githubUserEmail $ head userMail) [ ("email", githubUserEmail $ head userMail)
, ("login", githubUserLogin user) , ("login", githubUserLogin user)
, ("avatar_url", githubUserAvatarUrl user) , ("avatar_url", githubUserAvatarUrl user)
, ("access_token", decodeUtf8 $ accessToken token) , ("access_token", decodeUtf8 $ accessToken token)
] ++ (maybeName $ githubUserName user) ] ++ maybeName (githubUserName user)
maybeName Nothing = [] }
maybeName (Just name) = [("name", name)]
where
maybeName Nothing = []
maybeName (Just name) = [("name", name)]

94
Yesod/Auth/OAuth2/Spotify.hs
View File

@ -1,5 +1,8 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-- |
--
-- OAuth2 plugin for http://spotify.com
--
module Yesod.Auth.OAuth2.Spotify module Yesod.Auth.OAuth2.Spotify
( oauth2Spotify ( oauth2Spotify
, module Yesod.Auth.OAuth2 , module Yesod.Auth.OAuth2
@ -16,6 +19,7 @@ import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Conduit(Manager) import Network.HTTP.Conduit(Manager)
import Yesod.Auth import Yesod.Auth
import Yesod.Auth.OAuth2 import Yesod.Auth.OAuth2
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.Text as T import qualified Data.Text as T
@ -26,49 +30,50 @@ data SpotifyUserImage = SpotifyUserImage
} }
instance FromJSON SpotifyUserImage where instance FromJSON SpotifyUserImage where
parseJSON (Object v) = SpotifyUserImage <$> parseJSON (Object v) = SpotifyUserImage
v .: "height" <*> <$> v .: "height"
v .: "width" <*> <*> v .: "width"
v .: "url" <*> v .: "url"
parseJSON _ = mzero parseJSON _ = mzero
data SpotifyUser = SpotifyUser data SpotifyUser = SpotifyUser
{ spotifyUserId :: Text { spotifyUserId :: Text
, spotifyUserHref :: Text , spotifyUserHref :: Text
, spotifyUserUri :: Text , spotifyUserUri :: Text
, spotifyUserDisplayName :: Maybe Text , spotifyUserDisplayName :: Maybe Text
, spotifyUserProduct :: Maybe Text , spotifyUserProduct :: Maybe Text
, spotifyUserCountry :: Maybe Text , spotifyUserCountry :: Maybe Text
, spotifyUserEmail :: Maybe Text , spotifyUserEmail :: Maybe Text
, spotifyUserImages :: Maybe [SpotifyUserImage] , spotifyUserImages :: Maybe [SpotifyUserImage]
} }
instance FromJSON SpotifyUser where instance FromJSON SpotifyUser where
parseJSON (Object v) = SpotifyUser <$> parseJSON (Object v) = SpotifyUser
v .: "id" <*> <$> v .: "id"
v .: "href" <*> <*> v .: "href"
v .: "uri" <*> <*> v .: "uri"
v .:? "display_name" <*> <*> v .:? "display_name"
v .:? "product" <*> <*> v .:? "product"
v .:? "country" <*> <*> v .:? "country"
v .:? "email" <*> <*> v .:? "email"
v .:? "images" <*> v .:? "images"
parseJSON _ = mzero parseJSON _ = mzero
oauth2Spotify :: YesodAuth m oauth2Spotify :: YesodAuth m
=> Text -- ^ Client ID => Text -- ^ Client ID
-> Text -- ^ Client Secret -> Text -- ^ Client Secret
-> [ByteString] -- ^ Scopes -> [ByteString] -- ^ Scopes
-> AuthPlugin m -> AuthPlugin m
oauth2Spotify clientId clientSecret scope = authOAuth2 "spotify" oauth2Spotify clientId clientSecret scope = authOAuth2 "spotify"
(OAuth2 OAuth2
{ oauthClientId = encodeUtf8 clientId { oauthClientId = encodeUtf8 clientId
, oauthClientSecret = encodeUtf8 clientSecret , oauthClientSecret = encodeUtf8 clientSecret
, oauthOAuthorizeEndpoint = B.append "https://accounts.spotify.com/authorize?scope=" (B.intercalate "%20" scope) , oauthOAuthorizeEndpoint = B.append "https://accounts.spotify.com/authorize?scope=" (B.intercalate "%20" scope)
, oauthAccessTokenEndpoint = "https://accounts.spotify.com/api/token" , oauthAccessTokenEndpoint = "https://accounts.spotify.com/api/token"
, oauthCallback = Nothing , oauthCallback = Nothing
}) }
fetchSpotifyProfile fetchSpotifyProfile
fetchSpotifyProfile :: Manager -> AccessToken -> IO (Creds m) fetchSpotifyProfile :: Manager -> AccessToken -> IO (Creds m)
@ -79,9 +84,11 @@ fetchSpotifyProfile manager token = do
Left err -> throwIO $ InvalidProfileResponse "spotify" err Left err -> throwIO $ InvalidProfileResponse "spotify" err
toCreds :: SpotifyUser -> Creds m toCreds :: SpotifyUser -> Creds m
toCreds user = Creds "spotify" toCreds user = Creds
(spotifyUserId user) { credsPlugin = "spotify"
(mapMaybe getExtra extrasTemplate) , credsIdent = spotifyUserId user
, credsExtra = mapMaybe getExtra extrasTemplate
}
where where
userImage :: Maybe SpotifyUserImage userImage :: Maybe SpotifyUserImage
@ -90,18 +97,15 @@ toCreds user = Creds "spotify"
userImagePart :: (SpotifyUserImage -> Maybe a) -> Maybe a userImagePart :: (SpotifyUserImage -> Maybe a) -> Maybe a
userImagePart getter = userImage >>= getter userImagePart getter = userImage >>= getter
extrasTemplate = [ ("href" , Just $ spotifyUserHref user) extrasTemplate = [ ("href", Just $ spotifyUserHref user)
, ("uri" , Just $ spotifyUserUri user) , ("uri", Just $ spotifyUserUri user)
, ("display_name", spotifyUserDisplayName user) , ("display_name", spotifyUserDisplayName user)
, ("product" , spotifyUserProduct user) , ("product", spotifyUserProduct user)
, ("country" , spotifyUserCountry user) , ("country", spotifyUserCountry user)
, ("email" , spotifyUserEmail user) , ("email", spotifyUserEmail user)
, ("image_url" , userImage >>= , ("image_url", spotifyUserImageUrl <$> userImage)
return . spotifyUserImageUrl) , ("image_height", T.pack . show <$> userImagePart spotifyUserImageHeight)
, ("image_height", userImagePart spotifyUserImageHeight >>= , ("image_width", T.pack . show <$> userImagePart spotifyUserImageWidth)
return . T.pack . show)
, ("image_width" , userImagePart spotifyUserImageWidth >>=
return . T.pack . show)
] ]
getExtra :: (Text, Maybe Text) -> Maybe (Text, Text) getExtra :: (Text, Maybe Text) -> Maybe (Text, Text)

43
Yesod/Auth/OAuth2/Upcase.hs
View File

@ -24,26 +24,26 @@ import Network.HTTP.Conduit(Manager)
import qualified Data.Text as T import qualified Data.Text as T
data UpcaseUser = UpcaseUser data UpcaseUser = UpcaseUser
{ upcaseUserId :: Int { upcaseUserId :: Int
, upcaseUserFirstName :: Text , upcaseUserFirstName :: Text
, upcaseUserLastName :: Text , upcaseUserLastName :: Text
, upcaseUserEmail :: Text , upcaseUserEmail :: Text
} }
instance FromJSON UpcaseUser where instance FromJSON UpcaseUser where
parseJSON (Object o) = parseJSON (Object o) = UpcaseUser
UpcaseUser <$> o .: "id" <$> o .: "id"
<*> o .: "first_name" <*> o .: "first_name"
<*> o .: "last_name" <*> o .: "last_name"
<*> o .: "email" <*> o .: "email"
parseJSON _ = mzero parseJSON _ = mzero
data UpcaseResponse = UpcaseResponse UpcaseUser data UpcaseResponse = UpcaseResponse UpcaseUser
instance FromJSON UpcaseResponse where instance FromJSON UpcaseResponse where
parseJSON (Object o) = parseJSON (Object o) = UpcaseResponse
UpcaseResponse <$> o .: "user" <$> o .: "user"
parseJSON _ = mzero parseJSON _ = mzero
@ -53,11 +53,11 @@ oauth2Upcase :: YesodAuth m
-> AuthPlugin m -> AuthPlugin m
oauth2Upcase clientId clientSecret = authOAuth2 "upcase" oauth2Upcase clientId clientSecret = authOAuth2 "upcase"
OAuth2 OAuth2
{ oauthClientId = encodeUtf8 clientId { oauthClientId = encodeUtf8 clientId
, oauthClientSecret = encodeUtf8 clientSecret , oauthClientSecret = encodeUtf8 clientSecret
, oauthOAuthorizeEndpoint = "http://upcase.com/oauth/authorize" , oauthOAuthorizeEndpoint = "http://upcase.com/oauth/authorize"
, oauthAccessTokenEndpoint = "http://upcase.com/oauth/token" , oauthAccessTokenEndpoint = "http://upcase.com/oauth/token"
, oauthCallback = Nothing , oauthCallback = Nothing
} }
fetchUpcaseProfile fetchUpcaseProfile
@ -70,9 +70,12 @@ fetchUpcaseProfile manager token = do
Left err -> throwIO $ InvalidProfileResponse "upcase" err Left err -> throwIO $ InvalidProfileResponse "upcase" err
toCreds :: UpcaseUser -> Creds m toCreds :: UpcaseUser -> Creds m
toCreds user = Creds "upcase" toCreds user = Creds
(T.pack $ show $ upcaseUserId user) { credsPlugin = "upcase"
[ ("first_name", upcaseUserFirstName user) , credsIdent = T.pack $ show $ upcaseUserId user
, ("last_name" , upcaseUserLastName user) , credsExtra =
, ("email" , upcaseUserEmail user) [ ("first_name", upcaseUserFirstName user)
] , ("last_name" , upcaseUserLastName user)
, ("email" , upcaseUserEmail user)
]
}