hoauth2-1.3.0: example/Google/test.hs

{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}

{-

This is basically very manual test. Check following link for details.

Google web oauth: https://developers.google.com/accounts/docs/OAuth2WebServer

Google OAuth 2.0 playround: https://developers.google.com/oauthplayground/

-}

module Main where

import           Data.Aeson
import           Data.Aeson.Types
import qualified Data.ByteString.Char8         as BS
import qualified Data.ByteString.Lazy.Internal as BL
import           Data.Text                     (Text)
import qualified Data.Text                     as T
import           GHC.Generics
import           Network.HTTP.Conduit
import           Prelude                       hiding (id)
import           System.Environment            (getArgs)
import           URI.ByteString
import           URI.ByteString.QQ

import           Keys                          (googleKey)
import           Network.OAuth.OAuth2

data Errors =
  SomeRandomError
  deriving (Show, Eq, Generic)

instance FromJSON Errors where
  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelTo2 '_', allNullaryToStringTag = True }

--------------------------------------------------

data Token = Token { issuedTo   :: Text
                   , audience   :: Text
                   , userId     :: Maybe Text
                   , scope      :: Text
                   , expiresIn  :: Integer
                   , accessType :: Text
                   } deriving (Show, Generic)


data User = User { id         :: Text
                 , name       :: Text
                 , givenName  :: Text
                 , familyName :: Text
                 , link       :: Text
                 , picture    :: Text
                 , gender     :: Text
                 , locale     :: Text
                 } deriving (Show, Generic)

instance FromJSON Token where
    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }

instance ToJSON Token where
    toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' }

instance FromJSON User where
    parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }

instance ToJSON User where
    toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelTo2 '_' }

--------------------------------------------------

main :: IO ()
main = do
    xs <- getArgs
    mgr <- newManager tlsManagerSettings
    case xs of
        ["offline"] -> offlineCase mgr
        _           -> normalCase mgr

offlineCase :: Manager -> IO ()
offlineCase mgr = do
    BS.putStrLn $ serializeURIRef' $ appendQueryParams (googleScopeEmail ++ googleAccessOffline) $ authorizationUrl googleKey
    putStrLn "offline mode: visit the url and paste code here: "
    code <- getLine
    (Right token) <- fetchAccessToken mgr googleKey $ ExchangeToken $ T.pack code
    f (accessToken token)
    --
    -- obtain a new access token with refresh token, which turns out only in response at first time.
    -- Revoke Access https://www.google.com/settings/security
    --
    case refreshToken token of
        Nothing -> putStrLn "Failed to fetch refresh token"
        Just tk -> do
            (Right token') <- fetchRefreshToken mgr googleKey tk
            f (accessToken token')
            --validateToken accessToken >>= print
            --(validateToken' accessToken :: IO (OAuth2Result Token)) >>= print
    where f token = do
            print token
            validateToken mgr token >>= print
            (validateToken' mgr token :: IO (OAuth2Result (OAuth2Error Errors) Token)) >>= print

normalCase :: Manager -> IO ()
normalCase mgr = do
    -- try an invalid token
    putStr "Trying invalid token..."
    validateToken mgr (AccessToken "invalid") >>= print
    BS.putStrLn $ serializeURIRef' $ appendQueryParams googleScopeUserInfo (authorizationUrl googleKey)
    putStrLn "normal mode: visit the url and paste code here: "
    code <- fmap (ExchangeToken . T.pack) getLine
    maybeToken <- fetchAccessToken mgr googleKey code
    print maybeToken
    (Right token) <- return maybeToken
    putStr "AccessToken: " >> print token
    -- get response in ByteString
    validateToken mgr (accessToken token) >>= print
    -- get response in JSON
    (validateToken' mgr (accessToken token):: IO (OAuth2Result (OAuth2Error Errors) Token)) >>= print
    -- get response in ByteString
    userinfo mgr (accessToken token) >>= print
    -- get response in JSON
    (userinfo' mgr (accessToken token) :: IO (OAuth2Result (OAuth2Error Errors) User)) >>= print

--------------------------------------------------
-- Google API

-- | This is special for google Gain read-only access to the user's email address.
googleScopeEmail :: QueryParams
googleScopeEmail = [("scope", "https://www.googleapis.com/auth/userinfo.email")]

-- | Gain read-only access to basic profile information, including a
googleScopeUserInfo :: QueryParams
googleScopeUserInfo = [("scope", "https://www.googleapis.com/auth/userinfo.profile")]

-- | Access offline
googleAccessOffline :: QueryParams
googleAccessOffline = [("access_type", "offline")
                      ,("approval_prompt", "force")]

-- | Token Validation
validateToken :: Manager
                 -> AccessToken
                 -> IO (OAuth2Result (OAuth2Error Errors) BL.ByteString)
validateToken mgr token =
   authGetBS' mgr token url
   where url = [uri|https://www.googleapis.com/oauth2/v1/tokeninfo|]

validateToken' :: FromJSON a
                  => Manager
                  -> AccessToken
                  -> IO (OAuth2Result (OAuth2Error Errors) a)
validateToken' mgr token = parseResponseJSON <$> validateToken mgr token

-- | fetch user email.
--   for more information, please check the playround site.
--
userinfo :: Manager
            -> AccessToken
            -> IO (OAuth2Result (OAuth2Error Errors) BL.ByteString)
userinfo mgr token = authGetBS mgr token [uri|https://www.googleapis.com/oauth2/v2/userinfo|]

userinfo' :: FromJSON a
             => Manager
             -> AccessToken
             -> IO (OAuth2Result (OAuth2Error Errors) a)
userinfo' mgr token = authGetJSON mgr token [uri|https://www.googleapis.com/oauth2/v2/userinfo|]