module Yesod.Auth.GoogleEmail2
(
authGoogleEmail
, authGoogleEmailSaveToken
, forwardUrl
, Token(..)
, getUserAccessToken
, getPerson
, Person(..)
, Name(..)
, Gender(..)
, PersonImage(..)
, resizePersonImage
, RelationshipStatus(..)
, PersonURI(..)
, PersonURIType(..)
, Organization(..)
, OrganizationType(..)
, Place(..)
, Email(..)
, EmailType(..)
) where
import Blaze.ByteString.Builder (fromByteString, toByteString)
import Control.Applicative ((<$>), (<*>))
import Control.Arrow (second)
import Control.Monad (liftM, unless, when)
import Data.Aeson ((.:?))
import qualified Data.Aeson as A
import qualified Data.Aeson.Encode as A
import Data.Aeson.Parser (json')
import Data.Aeson.Types (FromJSON (parseJSON), parseEither,
parseMaybe, withObject, withText)
import Data.Conduit (($$+-))
import Data.Conduit.Attoparsec (sinkParser)
import qualified Data.HashMap.Strict as M
import Data.Maybe (fromMaybe)
import Data.Monoid (mappend)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TL
import Network.HTTP.Client (parseUrl, requestHeaders,
responseBody, urlEncodedBody, Manager)
import Network.HTTP.Conduit (http)
import Network.HTTP.Types (renderQueryText)
import Network.Mail.Mime (randomString)
import System.Random (newStdGen)
import Yesod.Auth (Auth, AuthPlugin (AuthPlugin),
AuthRoute, Creds (Creds),
Route (PluginR), YesodAuth,
authHttpManager, setCredsRedirect)
import qualified Yesod.Auth.Message as Msg
import Yesod.Core (HandlerSite, MonadHandler,
getRouteToParent, getUrlRender,
getYesod, invalidArgs, lift,
lookupGetParam,
lookupSession, notFound, redirect,
setSession, whamlet, (.:),
TypedContent, HandlerT, liftIO)
pid :: Text
pid = "googleemail2"
forwardUrl :: AuthRoute
forwardUrl = PluginR pid ["forward"]
csrfKey :: Text
csrfKey = "_GOOGLE_CSRF_TOKEN"
getCsrfToken :: MonadHandler m => m (Maybe Text)
getCsrfToken = lookupSession csrfKey
accessTokenKey :: Text
accessTokenKey = "_GOOGLE_ACCESS_TOKEN"
getUserAccessToken :: MonadHandler m => m (Maybe Token)
getUserAccessToken = fmap (\t -> Token t "Bearer") <$> lookupSession accessTokenKey
getCreateCsrfToken :: MonadHandler m => m Text
getCreateCsrfToken = do
mtoken <- getCsrfToken
case mtoken of
Just token -> return token
Nothing -> do
stdgen <- liftIO newStdGen
let token = T.pack $ fst $ randomString 10 stdgen
setSession csrfKey token
return token
authGoogleEmail :: YesodAuth m
=> Text
-> Text
-> AuthPlugin m
authGoogleEmail = authPlugin False
authGoogleEmailSaveToken :: YesodAuth m
=> Text
-> Text
-> AuthPlugin m
authGoogleEmailSaveToken = authPlugin True
authPlugin :: YesodAuth m
=> Bool
-> Text
-> Text
-> AuthPlugin m
authPlugin storeToken clientID clientSecret =
AuthPlugin pid dispatch login
where
complete = PluginR pid ["complete"]
getDest :: MonadHandler m
=> (Route Auth -> Route (HandlerSite m))
-> m Text
getDest tm = do
csrf <- getCreateCsrfToken
render <- getUrlRender
let qs = map (second Just)
[ ("scope", "email")
, ("state", csrf)
, ("redirect_uri", render $ tm complete)
, ("response_type", "code")
, ("client_id", clientID)
, ("access_type", "offline")
]
return $ decodeUtf8
$ toByteString
$ fromByteString "https://accounts.google.com/o/oauth2/auth"
`mappend` renderQueryText True qs
login tm = do
[whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]
dispatch :: YesodAuth site
=> Text
-> [Text]
-> HandlerT Auth (HandlerT site IO) TypedContent
dispatch "GET" ["forward"] = do
tm <- getRouteToParent
lift (getDest tm) >>= redirect
dispatch "GET" ["complete"] = do
mstate <- lookupGetParam "state"
case mstate of
Nothing -> invalidArgs ["CSRF state from Google is missing"]
Just state -> do
mtoken <- getCsrfToken
unless (Just state == mtoken) $ invalidArgs ["Invalid CSRF token from Google"]
mcode <- lookupGetParam "code"
code <-
case mcode of
Nothing -> invalidArgs ["Missing code paramter"]
Just c -> return c
render <- getUrlRender
req' <- liftIO $ parseUrl "https://accounts.google.com/o/oauth2/token"
let req =
urlEncodedBody
[ ("code", encodeUtf8 code)
, ("client_id", encodeUtf8 clientID)
, ("client_secret", encodeUtf8 clientSecret)
, ("redirect_uri", encodeUtf8 $ render complete)
, ("grant_type", "authorization_code")
]
req'
{ requestHeaders = []
}
manager <- liftM authHttpManager $ lift getYesod
res <- http req manager
value <- responseBody res $$+- sinkParser json'
token@(Token accessToken' tokenType') <-
case parseEither parseJSON value of
Left e -> error e
Right t -> return t
unless (tokenType' == "Bearer") $ error $ "Unknown token type: " ++ show tokenType'
when storeToken $ setSession accessTokenKey accessToken'
personValue <- lift $ getPersonValue manager token
person <- case parseEither parseJSON personValue of
Left e -> error e
Right x -> return x
email <-
case map emailValue $ filter (\e -> emailType e == EmailAccount) $ personEmails person of
[e] -> return e
[] -> error "No account email"
x -> error $ "Too many account emails: " ++ show x
lift $ setCredsRedirect $ Creds pid email $ allPersonInfo personValue
dispatch _ _ = notFound
getPerson :: Manager -> Token -> HandlerT site IO (Maybe Person)
getPerson manager token = parseMaybe parseJSON <$> getPersonValue manager token
getPersonValue :: Manager -> Token -> HandlerT site IO A.Value
getPersonValue manager token = do
req2' <- liftIO $ parseUrl "https://www.googleapis.com/plus/v1/people/me"
let req2 = req2'
{ requestHeaders =
[ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token)
]
}
res2 <- http req2 manager
val <- responseBody res2 $$+- sinkParser json'
return val
data Token = Token { accessToken :: Text
, tokenType :: Text
} deriving (Show, Eq)
instance FromJSON Token where
parseJSON = withObject "Tokens" $ \o -> Token
<$> o .: "access_token"
<*> o .: "token_type"
data Gender = Male | Female | OtherGender deriving (Show, Eq)
instance FromJSON Gender where
parseJSON = withText "Gender" $ \t -> return $ case t of
"male" -> Male
"female" -> Female
_ -> OtherGender
data PersonURI =
PersonURI { uriLabel :: Maybe Text
, uriValue :: Maybe Text
, uriType :: Maybe PersonURIType
} deriving (Show, Eq)
instance FromJSON PersonURI where
parseJSON = withObject "PersonURI" $ \o -> PersonURI <$> o .:? "label"
<*> o .:? "value"
<*> o .:? "type"
data PersonURIType = OtherProfile
| Contributor
| Website
| OtherURI
| PersonURIType Text
deriving (Show, Eq)
instance FromJSON PersonURIType where
parseJSON = withText "PersonURIType" $ \t -> return $ case t of
"otherProfile" -> OtherProfile
"contributor" -> Contributor
"website" -> Website
"other" -> OtherURI
_ -> PersonURIType t
data Organization =
Organization { orgName :: Maybe Text
, orgTitle :: Maybe Text
, orgType :: Maybe OrganizationType
, orgStartDate :: Maybe Text
, orgEndDate :: Maybe Text
, orgPrimary :: Maybe Bool
} deriving (Show, Eq)
instance FromJSON Organization where
parseJSON = withObject "Organization" $ \o ->
Organization <$> o .:? "name"
<*> o .:? "title"
<*> o .:? "type"
<*> o .:? "startDate"
<*> o .:? "endDate"
<*> o .:? "primary"
data OrganizationType = Work
| School
| OrganizationType Text
deriving (Show, Eq)
instance FromJSON OrganizationType where
parseJSON = withText "OrganizationType" $ \t -> return $ case t of
"work" -> Work
"school" -> School
_ -> OrganizationType t
data Place =
Place {
placeValue :: Maybe Text
, placePrimary :: Maybe Bool
} deriving (Show, Eq)
instance FromJSON Place where
parseJSON = withObject "Place" $ \o -> Place <$> (o .:? "value") <*> (o .:? "primary")
data Name =
Name {
nameFormatted :: Maybe Text
, nameFamily :: Maybe Text
, nameGiven :: Maybe Text
, nameMiddle :: Maybe Text
, nameHonorificPrefix :: Maybe Text
, nameHonorificSuffix :: Maybe Text
} deriving (Show, Eq)
instance FromJSON Name where
parseJSON = withObject "Name" $ \o -> Name <$> o .:? "formatted"
<*> o .:? "familyName"
<*> o .:? "givenName"
<*> o .:? "middleName"
<*> o .:? "honorificPrefix"
<*> o .:? "honorificSuffix"
data RelationshipStatus = Single
| InRelationship
| Engaged
| Married
| Complicated
| OpenRelationship
| Widowed
| DomesticPartnership
| CivilUnion
| RelationshipStatus Text
deriving (Show, Eq)
instance FromJSON RelationshipStatus where
parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of
"single" -> Single
"in_a_relationship" -> InRelationship
"engaged" -> Engaged
"married" -> Married
"its_complicated" -> Complicated
"open_relationship" -> OpenRelationship
"widowed" -> Widowed
"in_domestic_partnership" -> DomesticPartnership
"in_civil_union" -> CivilUnion
_ -> RelationshipStatus t
newtype PersonImage = PersonImage { imageUri :: Text } deriving (Show, Eq)
instance FromJSON PersonImage where
parseJSON = withObject "PersonImage" $ \o -> PersonImage <$> o .: "url"
resizePersonImage :: PersonImage -> Int -> PersonImage
resizePersonImage (PersonImage uri) size =
PersonImage $ uri `mappend` "?sz=" `mappend` T.pack (show size)
data Person = Person
{ personId :: Text
, personDisplayName :: Maybe Text
, personName :: Maybe Name
, personNickname :: Maybe Text
, personBirthday :: Maybe Text
, personGender :: Maybe Gender
, personProfileUri :: Maybe Text
, personImage :: Maybe PersonImage
, personAboutMe :: Maybe Text
, personRelationshipStatus :: Maybe RelationshipStatus
, personUris :: [PersonURI]
, personOrganizations :: [Organization]
, personPlacesLived :: [Place]
, personTagline :: Maybe Text
, personIsPlusUser :: Maybe Bool
, personBraggingRights :: Maybe Text
, personPlusOneCount :: Maybe Int
, personCircledByCount :: Maybe Int
, personVerified :: Maybe Bool
, personLanguage :: Maybe Text
, personEmails :: [Email]
, personDomain :: Maybe Text
, personOccupation :: Maybe Text
, personSkills :: Maybe Text
} deriving (Show, Eq)
instance FromJSON Person where
parseJSON = withObject "Person" $ \o ->
Person <$> o .: "id"
<*> o .: "displayName"
<*> o .:? "name"
<*> o .:? "nickname"
<*> o .:? "birthday"
<*> o .:? "gender"
<*> (o .:? "url")
<*> o .:? "image"
<*> o .:? "aboutMe"
<*> o .:? "relationshipStatus"
<*> ((fromMaybe []) <$> (o .:? "urls"))
<*> ((fromMaybe []) <$> (o .:? "organizations"))
<*> ((fromMaybe []) <$> (o .:? "placesLived"))
<*> o .:? "tagline"
<*> o .:? "isPlusUser"
<*> o .:? "braggingRights"
<*> o .:? "plusOneCount"
<*> o .:? "circledByCount"
<*> o .:? "verified"
<*> o .:? "language"
<*> ((fromMaybe []) <$> (o .:? "emails"))
<*> o .:? "domain"
<*> o .:? "occupation"
<*> o .:? "skills"
data Email = Email
{ emailValue :: Text
, emailType :: EmailType
}
deriving (Show, Eq)
instance FromJSON Email where
parseJSON = withObject "Email" $ \o -> Email
<$> o .: "value"
<*> o .: "type"
data EmailType = EmailAccount
| EmailHome
| EmailWork
| EmailOther
| EmailType Text
deriving (Show, Eq)
instance FromJSON EmailType where
parseJSON = withText "EmailType" $ \t -> return $ case t of
"account" -> EmailAccount
"home" -> EmailHome
"work" -> EmailWork
"other" -> EmailOther
_ -> EmailType t
allPersonInfo :: A.Value -> [(Text, Text)]
allPersonInfo (A.Object o) = map enc $ M.toList o
where enc (key, A.String s) = (key, s)
enc (key, v) = (key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)
allPersonInfo _ = []