handa-gdata 0.6.1 → 0.6.2
raw patch · 4 files changed
+87/−27 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- handa-gdata.cabal +7/−1
- src/Network/Google.hs +28/−4
- src/Network/Google/FusionTables.hs +2/−1
- src/Network/Google/OAuth2.hs +50/−21
handa-gdata.cabal view
@@ -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:
src/Network/Google.hs view
@@ -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
src/Network/Google/FusionTables.hs view
@@ -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" )
src/Network/Google/OAuth2.hs view
@@ -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"]