Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
137 lines (121 sloc) 4.58 KB
module GoogleOAuth2
( AccessToken (..)
, GoogleOAuth2Settings (..)
, forwardR
, callbackR
, getGoogleCreds
, googleOAuth2
, revokeAccessToken
) where
import Prelude
import Yesod
import Yesod.Auth
import Control.Arrow (second)
import Network.HTTP.Conduit
import Network.HTTP.Types
import Data.Conduit (runResourceT)
import Data.ByteString ()
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Text as T
import Data.Aeson
import Data.Text (Text, unpack)
import Data.Monoid ((<>))
import Control.Applicative ((<$>), (<*>))
import qualified Google.Oauth2.V2 as Oauth2
import qualified Google.Oauth2.V2.Types as Oauth2T
import Data.Maybe (catMaybes)
import Helpers (conduitAeson)
import Control.Monad (void)
data GoogleOAuth2Settings = GoogleOAuth2Settings
{ googleOAuth2ClientId :: Text
, googleOAuth2ClientSecret :: Text
, googleOAuth2BrowserId :: Text
} deriving (Eq, Show, Read)
instance FromJSON GoogleOAuth2Settings where
parseJSON (Object o) = GoogleOAuth2Settings
<$> o .: "client_id"
<*> o .: "client_secret"
<*> o .: "browser_id"
parseJSON _ = fail "google authentication information must be an object"
newtype AccessToken = AccessToken { unAccessToken :: Text } deriving (Eq, Show, Read, FromJSON)
data GoogleToken = GoogleToken
{ googleTokenType :: Maybe Text
, googleAccessToken :: AccessToken
, googleRefreshToken :: Text
} deriving (Eq, Show, Read)
instance FromJSON GoogleToken where
parseJSON (Object o) = GoogleToken
<$> o .:? "token_type"
<*> o .: "access_token"
<*> o .: "refresh_token"
parseJSON _ = fail "expected an object"
name :: Text
name = "google-oauth2"
forwardR, callbackR :: Route Auth
forwardR = PluginR name ["forward"]
callbackR = PluginR name ["callback"]
-- | Performs the second step of the OAuth2 procedure.
getGoogleCreds :: (YesodAuth m)
=> GoogleOAuth2Settings
-> Route m -- ^ Redirect URI
-> Text -- ^ Code (given as a query parameter in the callback)
-> GHandler s m (Creds m)
getGoogleCreds gOAuth redirR code = do
app <- getYesod
render <- getUrlRender
req <- liftIO $ parseUrl "https://accounts.google.com/o/oauth2/token"
let redirectUri = render $ redirR
params =
[ ("redirect_uri", UTF8.fromString $ T.unpack redirectUri)
, ("code", UTF8.fromString $ T.unpack code)
, ("client_id", UTF8.fromString $ T.unpack $ googleOAuth2ClientId gOAuth)
, ("client_secret", UTF8.fromString $ T.unpack $ googleOAuth2ClientSecret gOAuth)
, ("grant_type", "authorization_code")
]
req' = urlEncodedBody params $ req { method = "POST" }
token <- runResourceT $ do
res <- http req' (authHttpManager app)
conduitAeson $ responseBody res
let userinfoParams = def
{ Oauth2.parameterOauth_token = Just (unAccessToken $ googleAccessToken token)
, Oauth2.parameterFields = Just "id"
}
userinfo <- liftIO $ Oauth2.getUserinfo userinfoParams
let userId = maybe "" id $ Oauth2T.userinfoId $ responseBody userinfo
return $ Creds name userId
[ ("access_token", unAccessToken $ googleAccessToken token)
, ("refresh_token", googleRefreshToken token)
]
googleOAuth2 :: (YesodAuth m)
=> GoogleOAuth2Settings
-> [Text] -- ^ Auth scopes
-> AuthPlugin m
googleOAuth2 gOAuth scopes = AuthPlugin name dispatch login
where
dispatch "GET" ["forward"] = do
render <- getUrlRender
tm <- getRouteToMaster
let redirectUri = render $ tm callbackR
params = map (second Just)
[ ("redirect_uri", UTF8.fromString $ T.unpack redirectUri)
, ("response_type", "code")
, ("client_id", UTF8.fromString $ T.unpack $ googleOAuth2ClientId gOAuth)
, ("scope", UTF8.fromString $ unwords $ map unpack scopes)
, ("access_type", "offline")
, ("approval_prompt", "force")
]
authUrl = "https://accounts.google.com/o/oauth2/auth" <> renderQuery True params
redirect $ UTF8.toString authUrl
dispatch "GET" ["callback"] = do
mcode <- lookupGetParam "code"
code <- maybe notFound return mcode
tm <- getRouteToMaster
creds <- getGoogleCreds gOAuth (tm callbackR) code
setCreds True creds
dispatch _ _ = notFound
login tm = do
render <- lift getUrlRender
[whamlet|<p><a href="#{render $ tm forwardR}">Log in with Google</a>|]
revokeAccessToken :: AccessToken -> IO ()
revokeAccessToken (AccessToken at) = void $ simpleHttp $ unpack url
where url = "https://accounts.google.com/o/oauth2/revoke?token=" <> at