Added means to fetch user's Google profile

The existing GoogleEmail2 auth did that:
  - Acquire user access token with offline access
  - Use token to acquire user's profile
  - Build `Creds` with user's email as `ident` and the other profile
    details as stringy key-value pairs in `credsExtra`

This wasn't enough for me, for several reasons:
  - Access token was not saved after authentication. If we request 'offline'
    token why not to have a way of using it later.
  - Stringy key-value profile is not nice and `credsExtra` can be accessed
    only from `getAuthId`
  - I might want to request the profile after authentication process

So I've added the needed features.
  - The access token is saved in a session
  - There is a `Person` type with `FromJSON` instance and `getPerson`
    can be used to acquire it from `HandlerT`

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -22,22 +22,43 @@
 --
 -- Since 1.3.1
 module Yesod.Auth.GoogleEmail2
-    ( authGoogleEmail
+    ( -- * Authentication handler
+      authGoogleEmail
     , forwardUrl
+    -- * User authentication token
+    , Token(..)
+    , getUserAccessToken
+    -- * Person
+    , 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)
+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,
-                                           withObject)
+                                           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
@@ -45,7 +66,7 @@ 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)
+                                           responseBody, urlEncodedBody, Manager)
 import           Network.HTTP.Conduit     (http)
 import           Network.HTTP.Types       (renderQueryText)
 import           Network.Mail.Mime        (randomString)
@@ -75,6 +96,14 @@ csrfKey = "_GOOGLE_CSRF_TOKEN"
 getCsrfToken :: MonadHandler m => m (Maybe Text)
 getCsrfToken = lookupSession csrfKey
 
+accessTokenKey :: Text
+accessTokenKey = "_GOOGLE_ACCESS_TOKEN"
+
+-- | Get user's access token from the session. Returns Nothing if it's not found
+--   (probably because the user is not logged in via 'Yesod.Auth.GoogleEmail2')
+getUserAccessToken :: MonadHandler m => m (Maybe Token)
+getUserAccessToken = fmap (\t -> Token t "Bearer") <$> lookupSession accessTokenKey
+
 getCreateCsrfToken :: MonadHandler m => m Text
 getCreateCsrfToken = do
     mtoken <- getCsrfToken
@@ -155,55 +184,315 @@ authGoogleEmail clientID clientSecret =
         manager <- liftM authHttpManager $ lift getYesod
         res <- http req manager
         value <- responseBody res $$+- sinkParser json'
-        Tokens accessToken tokenType <-
+        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
+        unless (tokenType' == "Bearer") $ error $ "Unknown token type: " ++ show tokenType'
 
-        req2' <- liftIO $ parseUrl "https://www.googleapis.com/plus/v1/people/me"
+        -- User's access token is saved for further access to API
-        let req2 = req2'
+        setSession accessTokenKey accessToken'
-                { requestHeaders =
+
-                    [ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken)
+        personValue <- lift $ getPersonValue manager token
-                    ]
+        person <- case parseEither parseJSON personValue of
-                }
-        res2 <- http req2 manager
-        value2 <- responseBody res2 $$+- sinkParser json'
-        Person emails <-
-            case parseEither parseJSON value2 of
                 Left e -> error e
                 Right x -> return x
+
         email <-
-            case map emailValue $ filter (\e -> emailType e == "account") emails of
+            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 value2
+        lift $ setCredsRedirect $ Creds pid email $ allPersonInfo personValue
 
     dispatch _ _ = notFound
 
-data Tokens = Tokens Text Text
+-- | Allows to fetch information about a user from Google's API.
-instance FromJSON Tokens where
+--   In case of parsing error returns 'Nothing'.
-    parseJSON = withObject "Tokens" $ \o -> Tokens
+--   Will throw 'HttpException' in case of network problems or error response code.
+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
+
+--------------------------------------------------------------------------------
+-- | An authentication token which was acquired from OAuth callback.
+--   The token gets saved into the session storage, from where it can be
+--   acquired which 'getUserAccessToken'.
+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 Person = Person [Email]
+--------------------------------------------------------------------------------
-instance FromJSON Person where
+-- | Gender of the person
-    parseJSON = withObject "Person" $ \o -> Person
+data Gender = Male | Female | OtherGender deriving (Show, Eq)
-        <$> o .: "emails"
 
+instance FromJSON Gender where
+    parseJSON = withText "Gender" $ \t -> return $ case t of
+                                                "male"   -> Male
+                                                "female" -> Female
+                                                _        -> OtherGender
+
+--------------------------------------------------------------------------------
+-- | URIs specified in the person's profile
+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"
+
+--------------------------------------------------------------------------------
+-- | The type of URI
+data PersonURIType = OtherProfile       -- ^ URI for another profile
+                   | Contributor        -- ^ URI to a site for which this person is a contributor
+                   | Website            -- ^ URI for this Google+ Page's primary website
+                   | OtherURI           -- ^ Other URL
+                   | PersonURIType Text -- ^ Something else
+                   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
+
+--------------------------------------------------------------------------------
+-- | Current or past organizations with which this person is associated
+data Organization =
+    Organization { orgName  :: Maybe Text
+                   -- ^ The person's job title or role within the organization
+                 , orgTitle :: Maybe Text
+                 , orgType  :: Maybe OrganizationType
+                   -- ^ The date that the person joined this organization.
+                 , orgStartDate :: Maybe Text
+                   -- ^ The date that the person left this organization.
+                 , orgEndDate   :: Maybe Text
+                   -- ^ If @True@, indicates this organization is the person's
+                   -- ^ primary one, which is typically interpreted as the current one.
+                 , 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"
+
+--------------------------------------------------------------------------------
+-- | The type of an organization
+data OrganizationType = Work
+                      | School
+                      | OrganizationType Text -- ^ Something else
+                      deriving (Show, Eq)
+instance FromJSON OrganizationType where
+    parseJSON = withText "OrganizationType" $ \t -> return $ case t of
+                                                "work"   -> Work
+                                                "school" -> School
+                                                _        -> OrganizationType t
+
+--------------------------------------------------------------------------------
+-- | A place where the person has lived or is living at the moment.
+data Place =
+    Place { -- | A place where this person has lived. For example: "Seattle, WA", "Near Toronto".
+            placeValue :: Maybe Text
+            -- | If @True@, this place of residence is this person's primary residence.
+          , placePrimary :: Maybe Bool
+          } deriving (Show, Eq)
+
+instance FromJSON Place where
+    parseJSON = withObject "Place" $ \o -> Place <$> (o .:? "value") <*> (o .:? "primary")
+
+--------------------------------------------------------------------------------
+-- | Individual components of a name
+data Name =
+    Name { -- | The full name of this person, including middle names, suffixes, etc
+           nameFormatted :: Maybe Text
+           -- | The family name (last name) of this person
+         , nameFamily    :: Maybe Text
+           -- | The given name (first name) of this person
+         , nameGiven     :: Maybe Text
+           -- | The middle name of this person.
+         , nameMiddle    :: Maybe Text
+           -- | The honorific prefixes (such as "Dr." or "Mrs.") for this person
+         , nameHonorificPrefix :: Maybe Text
+           -- | The honorific suffixes (such as "Jr.") for this person
+         , 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"
+
+--------------------------------------------------------------------------------
+-- | The person's relationship status.
+data RelationshipStatus = Single              -- ^ Person is single
+                        | InRelationship      -- ^ Person is in a relationship
+                        | Engaged             -- ^ Person is engaged
+                        | Married             -- ^ Person is married
+                        | Complicated         -- ^ The relationship is complicated
+                        | OpenRelationship    -- ^ Person is in an open relationship
+                        | Widowed             -- ^ Person is widowed
+                        | DomesticPartnership -- ^ Person is in a domestic partnership
+                        | CivilUnion          -- ^ Person is in a civil union
+                        | RelationshipStatus Text -- ^ Something else
+                        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
+
+--------------------------------------------------------------------------------
+-- | The URI of the person's profile photo.
+newtype PersonImage = PersonImage { imageUri :: Text } deriving (Show, Eq)
+
+instance FromJSON PersonImage where
+    parseJSON = withObject "PersonImage" $ \o -> PersonImage <$> o .: "url"
+
+-- | @resizePersonImage img 30@ would set query part to @?sz=30@ which would resize
+--   the image under the URI. If for some reason you need to modify the query
+--   part, you should do it after resizing.
+resizePersonImage :: PersonImage -> Int -> PersonImage
+resizePersonImage (PersonImage uri) size =
+    PersonImage $ uri `mappend` "?sz=" `mappend` T.pack (show size)
+
+--------------------------------------------------------------------------------
+-- | Information about the user
+--   Full description of the resource https://developers.google.com/+/api/latest/people
+data Person = Person
+    { personId           :: Text
+      -- | The name of this person, which is suitable for display
+    , personDisplayName        :: Maybe Text
+    , personName               :: Maybe Name
+    , personNickname           :: Maybe Text
+    , personBirthday           :: Maybe Text -- ^ Birthday formatted as YYYY-MM-DD
+    , personGender             :: Maybe Gender
+    , personProfileUri         :: Maybe Text -- ^ The URI of this person's profile
+    , personImage              :: Maybe PersonImage
+    , personAboutMe            :: Maybe Text -- ^ A short biography for this person
+    , personRelationshipStatus :: Maybe RelationshipStatus
+    , personUris               :: [PersonURI]
+    , personOrganizations      :: [Organization]
+    , personPlacesLived        :: [Place]
+    -- | The brief description of this person
+    , personTagline            :: Maybe Text
+    -- | Whether this user has signed up for Google+
+    , personIsPlusUser         :: Maybe Bool
+    -- | The "bragging rights" line of this person
+    , personBraggingRights     :: Maybe Text
+    -- | if a Google+ page, the number of people who have +1'd this page
+    , personPlusOneCount       :: Maybe Int
+    -- | For followers who are visible, the number of people who have added
+    --   this person or page to a circle.
+    , personCircledByCount     :: Maybe Int
+    -- | Whether the person or Google+ Page has been verified. This is used only
+    --   for pages with a higher risk of being impersonated or similar. This
+    --   flag will not be present on most profiles.
+    , personVerified           :: Maybe Bool
+    -- | The user's preferred language for rendering.
+    , personLanguage           :: Maybe Text
+    , personEmails             :: [Email]
+    , personDomain             :: Maybe Text
+    , personOccupation         :: Maybe Text -- ^ The occupation of this person
+    , personSkills             :: Maybe Text -- ^ The person's skills
+    } 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"
+
+--------------------------------------------------------------------------------
+-- | Person's email
 data Email = Email
     { emailValue :: Text
-    , emailType  :: Text
+    , emailType  :: EmailType
     }
-    deriving Show
+    deriving (Show, Eq)
+
 instance FromJSON Email where
     parseJSON = withObject "Email" $ \o -> Email
         <$> o .: "value"
         <*> o .: "type"
 
+--------------------------------------------------------------------------------
+-- | Type of email
+data EmailType = EmailAccount   -- ^ Google account email address
+               | EmailHome      -- ^ Home email address
+               | EmailWork      -- ^ Work email adress
+               | EmailOther     -- ^ Other email address
+               | EmailType Text -- ^ Something else
+               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)