diff --git a/handa-gdata.cabal b/handa-gdata.cabal --- a/handa-gdata.cabal +++ b/handa-gdata.cabal @@ -1,6 +1,11 @@ name: handa-gdata -version: 0.6.1 +version: 0.6.2 cabal-version: >=1.6 + +-- CHANGELOG: +-- 0.6.2: Improve getCachedTokens +-- + build-type: Simple license: MIT license-file: LICENSE @@ -11,6 +16,7 @@ package-url: http://code.google.com/p/hgdata/downloads/list bug-reports: http://code.google.com/p/hgdata/issues/entry synopsis: Library and command-line utility for accessing Google services and APIs. + description: This project provides a Haskell library and command-line interface for Google services such as Google Storage, Contacts, Books, etc. . For OAuth 2.0, the following operations are supported: diff --git a/src/Network/Google.hs b/src/Network/Google.hs --- a/src/Network/Google.hs +++ b/src/Network/Google.hs @@ -13,7 +13,7 @@ ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, ScopedTypeVariables #-} module Network.Google ( @@ -27,6 +27,7 @@ , appendQuery , doManagedRequest , doRequest +-- , retryIORequest , makeHeaderName , makeProjectRequest , makeRequest @@ -34,7 +35,8 @@ ) where -import Control.Exception (finally) +import qualified Control.Exception as E +import Control.Concurrent (threadDelay) import Control.Monad.Trans.Resource (ResourceT, runResourceT) import Data.List (intercalate) import Data.Maybe (fromJust) @@ -44,7 +46,8 @@ import Data.ByteString.Lazy.UTF8 (toString) import Data.CaseInsensitive as CI (CI(..), mk) import Network.HTTP.Base (urlEncode) -import Network.HTTP.Conduit (Manager, Request(..), RequestBody(..), Response(..), closeManager, def, httpLbs, newManager, responseBody) +import Network.HTTP.Conduit (Manager, Request(..), RequestBody(..), Response(..), HttpException, + closeManager, def, httpLbs, newManager, responseBody) import Text.JSON (JSValue, Result(Ok), decode) import Text.XML.Light (Element, parseXMLDoc) @@ -115,7 +118,7 @@ doManagedRequest manager request --} manager <- newManager def - finally + E.finally (doManagedRequest manager request) (closeManager manager) doManagedRequest :: @@ -235,3 +238,24 @@ -- TODO: In principle, we should UTF-8 encode the bytestrings packed below. queryString = BS8.pack $ '?' : query' } + + +-- | Takes an idempotent IO action that includes a network request. Catches +-- `HttpException`s and tries a gain a certain number of times. The second argument +-- is a callback to invoke every time a retry occurs. +-- +-- Takes a list of *seconds* to wait between retries. A null list means no retries, +-- an infinite list will retry indefinitely. The user can choose whatever temporal +-- pattern they desire (e.g. exponential backoff). +-- +-- Once the retry list runs out, the last attempt may throw `HttpException` +-- exceptions that escape this function. +retryIORequest :: IO a -> (HttpException -> IO ()) -> [Double] -> IO a +retryIORequest req retryHook times = loop times + where + loop [] = req + loop (delay:tl) = + E.catch req $ \ (exn::HttpException) -> do + retryHook exn + threadDelay (round$ delay * 1000 * 1000) -- Microseconds + loop tl diff --git a/src/Network/Google/FusionTables.hs b/src/Network/Google/FusionTables.hs --- a/src/Network/Google/FusionTables.hs +++ b/src/Network/Google/FusionTables.hs @@ -135,7 +135,8 @@ do resp <- doRequest req case parseTables resp of Ok x -> return x - Error err -> error$ "listTables: failed to parse JSON response:\n"++err + Error err -> error$ "listTables: failed to parse JSON response, error was:\n " + ++err++"\nJSON response was:\n "++show resp where req = makeRequest accessToken fusiontableApi "GET" ( fusiontableHost, "fusiontables/v1/tables" ) diff --git a/src/Network/Google/OAuth2.hs b/src/Network/Google/OAuth2.hs --- a/src/Network/Google/OAuth2.hs +++ b/src/Network/Google/OAuth2.hs @@ -85,6 +85,8 @@ 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) @@ -93,7 +95,8 @@ import System.Info (os) import System.Process (rawSystem) import System.Exit (ExitCode(..)) -import System.Directory (doesFileExist, doesDirectoryExist, getAppUserDataDirectory, createDirectory, renameFile) +import System.Directory (doesFileExist, doesDirectoryExist, getAppUserDataDirectory, + createDirectory, renameFile, removeFile) import System.FilePath ((),(<.>), splitExtension) import System.Random (randomIO) @@ -295,42 +298,68 @@ -- The first time it is called, this may open a web-browser, and/or request the user -- enter data on the command line. Subsequently, invocations on the same machine -- should not communicate with the user. --- +-- +-- If the tokens do not expire until more than 15 minutes in the future, this +-- procedure will skip the refresh step. Whether or not it refreshes should be +-- immaterial to the clients subsequent actions, because all clients should handle +-- authentication errors (and all 5xx errors) and call `refreshToken` as necessary. getCachedTokens :: OAuth2Client -- ^ The client is the \"key\" for token lookup. -> IO OAuth2Tokens getCachedTokens client = do cabalD <- getAppUserDataDirectory "cabal" - let tokenD = cabalD "googleAuthTokens" - tokenF = tokenD clientId client <.> "token" + let tokenD = cabalD "googleAuthTokens" + tokenF = tokenD clientId client <.> "token" d1 <- doesDirectoryExist cabalD unless d1 $ createDirectory cabalD -- Race. d2 <- doesDirectoryExist tokenD unless d2 $ createDirectory tokenD -- Race. f1 <- doesFileExist tokenF - if f1 then do - toks <- fmap read (readFile tokenF) - -- Our policy is to *always* refresh: - toks2 <- refreshTokens client toks - toks3 <- timestamp toks2 - atomicWriteFile tokenF (show toks3) - return toks3 + if f1 then do + str <- readFile tokenF + case reads str of + -- Here's our approach to versioning! If we can't read it, we remove it. + ((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 - atomicWriteFile tokenF (show toks) - return toks - where - -- TODO: Convert relative time to absolute UTF time for the tokens: - timestamp toks = - return toks - + fmap snd$ timeStampAndWrite tokenF toks + where + -- Tokens store a relative time, which is rather silly (relative to what?). This + -- routine tags a token with the time it was issued, so as to enable figuring out + -- the absolute expiration time. Also, as a side effect, this is where we refresh + -- the token if it is already expired or expiring soon. + 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 -- Skip refresh if token is good for at least 15 min. + 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 + -- This is the part where we require user interaction: askUser = do - putStrLn$ "Load this URL: "++show permissionUrl + putStrLn$ " [getCachedTokens] Load this URL: "++show permissionUrl runBrowser - putStrLn "Then please paste the verification code and press enter:\n$ " + putStrLn " [getCachedTokens] Then please paste the verification code and press enter:\n$ " authcode <- getLine tokens <- exchangeCode client authcode - putStrLn$ "Received access token: "++show (accessToken tokens) + putStrLn$ " [getCachedTokens] Received access token: "++show (accessToken tokens) return tokens permissionUrl = formUrl client ["https://www.googleapis.com/auth/fusiontables"]