module Network.Google.OAuth2 (
OAuth2Client(..)
, OAuth2Scope
, OAuth2Tokens(..)
, googleScopes
, formUrl
, exchangeCode
, refreshTokens
, validateTokens
, getCachedTokens
) where
import Control.Monad (unless)
import Data.ByteString.Char8 as BS8 (ByteString, pack)
import Data.ByteString.Lazy.UTF8 (toString)
import Data.List (intercalate)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Data.Word (Word64)
import Network.Google (makeHeaderName)
import Network.HTTP.Base (urlEncode)
import Network.HTTP.Conduit (Request(..), RequestBody(..), Response(..), def, httpLbs, responseBody, withManager)
import Text.JSON (JSObject, JSValue(JSRational), Result(Ok), decode, valFromObj)
import System.Info (os)
import System.Process (rawSystem)
import System.Exit (ExitCode(..))
import System.Directory (doesFileExist, doesDirectoryExist, getAppUserDataDirectory,
createDirectory, renameFile, removeFile)
import System.FilePath ((</>),(<.>), splitExtension)
import System.Random (randomIO)
data OAuth2Client = OAuth2Client
{
clientId :: String
, clientSecret :: String
}
deriving (Read, Show)
type OAuth2Code = String
data OAuth2Tokens = OAuth2Tokens
{
accessToken :: String
, refreshToken :: String
, expiresIn :: Rational
, tokenType :: String
}
deriving (Read, Show)
type OAuth2Scope = String
googleScopes ::
[(String, OAuth2Scope)]
googleScopes =
[
("Adsense Management", "https://www.googleapis.com/auth/adsense")
, ("Google Affiliate Network", "https://www.googleapis.com/auth/gan")
, ("Analytics", "https://www.googleapis.com/auth/analytics.readonly")
, ("Google Books", "https://www.googleapis.com/auth/books")
, ("Blogger", "https://www.googleapis.com/auth/blogger")
, ("Calendar", "https://www.googleapis.com/auth/calendar")
, ("Google Cloud Storage", "https://www.googleapis.com/auth/devstorage.read_write")
, ("Contacts", "https://www.google.com/m8/feeds/")
, ("Content API for Shopping", "https://www.googleapis.com/auth/structuredcontent")
, ("Chrome Web Store", "https://www.googleapis.com/auth/chromewebstore.readonly")
, ("Fusion Tables", "https://www.googleapis.com/auth/fusiontables")
, ("Documents List", "https://docs.google.com/feeds/")
, ("Google Drive", "https://www.googleapis.com/auth/drive")
, ("Google Drive Files", "Files https://www.googleapis.com/auth/drive.file")
, ("Gmail", "https://mail.google.com/mail/feed/atom")
, ("Google+", "https://www.googleapis.com/auth/plus.me")
, ("Groups Provisioning", "https://apps-apis.google.com/a/feeds/groups/")
, ("Google Latitude", "https://www.googleapis.com/auth/latitude.all.best https://www.googleapis.com/auth/latitude.all.city")
, ("Moderator", "https://www.googleapis.com/auth/moderator")
, ("Nicknames", "Provisioning https://apps-apis.google.com/a/feeds/alias/")
, ("Orkut", "https://www.googleapis.com/auth/orkut")
, ("Picasa Web", "https://picasaweb.google.com/data/")
, ("Sites", "https://sites.google.com/feeds/")
, ("Spreadsheets", "https://spreadsheets.google.com/feeds/")
, ("Tasks", "https://www.googleapis.com/auth/tasks")
, ("URL Shortener", "https://www.googleapis.com/auth/urlshortener")
, ("Userinfo - Email", "https://www.googleapis.com/auth/userinfo.email")
, ("Userinfo - Profile", "https://www.googleapis.com/auth/userinfo.profile")
, ("User Provisioning", "https://apps-apis.google.com/a/feeds/user/")
, ("Webmaster Tools", "https://www.google.com/webmasters/tools/feeds/")
, ("YouTube", "https://gdata.youtube.com")
]
redirectUri :: String
redirectUri = "urn:ietf:wg:oauth:2.0:oob"
formUrl ::
OAuth2Client
-> [OAuth2Scope]
-> String
formUrl client scopes =
"https://accounts.google.com/o/oauth2/auth"
++ "?response_type=code"
++ "&client_id=" ++ clientId client
++ "&redirect_uri=" ++ redirectUri
++ "&scope=" ++ intercalate "+" (map urlEncode scopes)
exchangeCode ::
OAuth2Client
-> OAuth2Code
-> IO OAuth2Tokens
exchangeCode client code =
do
result <- doOAuth2 client "authorization_code" ("&redirect_uri=" ++ redirectUri ++ "&code=" ++ code)
let
(Ok result') = decodeTokens Nothing result
return result'
decodeTokens ::
Maybe OAuth2Tokens
-> JSObject JSValue
-> Result OAuth2Tokens
decodeTokens tokens value =
do
let
(!) = flip valFromObj
expiresIn' :: Rational
(Ok (JSRational _ expiresIn')) = valFromObj "expires_in" value
accessToken <- value ! "access_token"
refreshToken <- maybe (value ! "refresh_token") (Ok . refreshToken) tokens
tokenType <- value ! "token_type"
return OAuth2Tokens
{
accessToken = accessToken
, refreshToken = refreshToken
, expiresIn = expiresIn'
, tokenType = tokenType
}
refreshTokens ::
OAuth2Client
-> OAuth2Tokens
-> IO OAuth2Tokens
refreshTokens client tokens =
do
result <- doOAuth2 client "refresh_token" ("&refresh_token=" ++ refreshToken tokens)
let
(Ok result') = decodeTokens (Just tokens) result
return result'
doOAuth2 ::
OAuth2Client
-> String
-> String
-> IO (JSObject JSValue)
doOAuth2 client grantType extraBody =
do
let
request =
def {
method = BS8.pack "POST"
, secure = True
, host = BS8.pack "accounts.google.com"
, port = 443
, path = BS8.pack "/o/oauth2/token"
, requestHeaders = [
(makeHeaderName "Content-Type", BS8.pack "application/x-www-form-urlencoded")
]
, requestBody = RequestBodyBS . BS8.pack
$ "client_id=" ++ clientId client
++ "&client_secret=" ++ clientSecret client
++ "&grant_type=" ++ grantType
++ extraBody
}
response <- withManager $ httpLbs request
let
(Ok result) = decode . toString $ responseBody response
return result
validateTokens ::
OAuth2Tokens
-> IO Rational
validateTokens tokens =
do
let
request =
def {
method = BS8.pack "GET"
, secure = True
, host = BS8.pack "www.googleapis.com"
, port = 443
, path = BS8.pack "/oauth2/v1/tokeninfo"
, queryString = BS8.pack ("?access_token=" ++ accessToken tokens)
}
response <- withManager $ httpLbs request
let
(Ok result) = decode . toString $ responseBody response
expiresIn' :: Rational
(Ok (JSRational _ expiresIn')) = valFromObj "expires_in" result
return expiresIn'
getCachedTokens :: OAuth2Client
-> IO OAuth2Tokens
getCachedTokens client = do
cabalD <- getAppUserDataDirectory "cabal"
let tokenD = cabalD </> "googleAuthTokens"
tokenF = tokenD </> clientId client <.> "token"
d1 <- doesDirectoryExist cabalD
unless d1 $ createDirectory cabalD
d2 <- doesDirectoryExist tokenD
unless d2 $ createDirectory tokenD
f1 <- doesFileExist tokenF
if f1 then do
str <- readFile tokenF
case reads str of
((oldtime,toks),_):_ -> do
tagged <- checkExpiry tokenF (oldtime,toks)
return (snd tagged)
[] -> do
putStrLn$" [getCachedTokens] Could not read tokens from file: "++ tokenF
putStrLn$" [getCachedTokens] Removing tokens and re-authenticating..."
removeFile tokenF
getCachedTokens client
else do
toks <- askUser
fmap snd$ timeStampAndWrite tokenF toks
where
checkExpiry :: FilePath -> (Rational, OAuth2Tokens) -> IO (Rational, OAuth2Tokens)
checkExpiry tokenF orig@(start1,toks1) = do
t <- getCurrentTime
let nowsecs = toRational (utcTimeToPOSIXSeconds t)
expire1 = start1 + expiresIn toks1
tolerance = 15 * 60
if (expire1 < tolerance + nowsecs) then do
toks2 <- refreshTokens client toks1
timeStampAndWrite tokenF toks2
else return orig
timeStampAndWrite :: FilePath -> OAuth2Tokens -> IO (Rational, OAuth2Tokens)
timeStampAndWrite tokenF toks = do
t2 <- getCurrentTime
let tagged = (toRational (utcTimeToPOSIXSeconds t2), toks)
atomicWriteFile tokenF (show tagged)
return tagged
askUser = do
putStrLn$ " [getCachedTokens] Load this URL: "++show permissionUrl
runBrowser
putStrLn " [getCachedTokens] Then please paste the verification code and press enter:\n$ "
authcode <- getLine
tokens <- exchangeCode client authcode
putStrLn$ " [getCachedTokens] Received access token: "++show (accessToken tokens)
return tokens
permissionUrl = formUrl client ["https://www.googleapis.com/auth/fusiontables"]
runBrowser =
case os of
"linux" -> rawSystem "gnome-open" [permissionUrl]
"darwin" -> rawSystem "open" [permissionUrl]
_ -> return ExitSuccess
atomicWriteFile file str = do
suff <- randomIO :: IO Word64
let (root,ext) = splitExtension file
tmp = root ++ show suff <.> ext
writeFile tmp str
renameFile tmp file