diff --git a/handa-gdata.cabal b/handa-gdata.cabal --- a/handa-gdata.cabal +++ b/handa-gdata.cabal @@ -1,22 +1,16 @@ name: handa-gdata -version: 0.6.2 +version: 0.6.3 cabal-version: >=1.6 - --- CHANGELOG: --- 0.6.2: Improve getCachedTokens --- - build-type: Simple license: MIT license-file: LICENSE copyright: (c) 2012-13 Brian W Bush, Ryan Newton -maintainer: Brian W Bush , Ryan Newton +maintainer: Brian W Bush stability: Stable homepage: http://code.google.com/p/hgdata 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: @@ -80,36 +74,83 @@ location: https://code.google.com/p/hgdata/ library - build-depends: HTTP -any, base <6, base64-bytestring -any, - binary -any, bytestring -any, case-insensitive -any, cmdargs -any, - directory -any, filepath -any, split -any, http-conduit, - json -any, old-locale -any, process -any, pureMD5 -any, - regex-posix -any, resourcet -any, time -any, unix -any, - utf8-string -any, xml -any, random -any, pretty -any, GenericPretty -any - exposed-modules: Crypto.GnuPG Crypto.MD5 Network.Google - Network.Google.Bookmarks Network.Google.Books - Network.Google.Contacts Network.Google.OAuth2 Network.Google.Picasa - Network.Google.Storage Network.Google.Storage.Encrypted - Network.Google.Storage.Sync + build-depends: base >= 4 && < 5 + , base64-bytestring >= 0.9.1.4 + , binary >= 0.5.1.1 + , bytestring >= 0.10.0.2 + , case-insensitive >= 0.2 + , directory -any + , filepath -any + , GenericPretty >= 1.0.0 + , HTTP >= 4000.2.5 + , http-conduit >= 1.9.0 + , json >= 0.5 + , old-locale -any + , pretty -any + , process >= 1.1.0.2 + , pureMD5 >= 2.1.2.1 + , random -any + , regex-posix >= 0.95.2 + , resourcet >= 0.3 + , split >= 0.2.0.0 + , time -any + , unix -any + , utf8-string -any + , xml >= 1.2.6 + exposed-modules: Crypto.GnuPG + Crypto.MD5 + Network.Google + Network.Google.Bookmarks + Network.Google.Books + Network.Google.Contacts Network.Google.FusionTables + Network.Google.OAuth2 + Network.Google.Picasa + Network.Google.Storage + Network.Google.Storage.Encrypted + Network.Google.Storage.Sync exposed: True buildable: True hs-source-dirs: src executable hgdata - build-depends: HTTP -any, base <6, base64-bytestring -any, - binary -any, bytestring -any, case-insensitive -any, cmdargs -any, - directory -any, filepath -any, split -any, http-conduit, - json -any, old-locale -any, process -any, pureMD5 -any, - regex-posix -any, resourcet -any, time -any, unix -any, - utf8-string -any, xml -any, random -any, pretty -any, GenericPretty -any + build-depends: base >= 4 && < 5 + , base64-bytestring >= 0.9.1.4 + , binary >= 0.5.1.1 + , bytestring >= 0.10.0.2 + , case-insensitive >= 0.2 + , directory -any + , filepath -any + , cmdargs >= 0.9.4 + , GenericPretty >= 1.0.0 + , HTTP >= 4000.2.5 + , http-conduit >= 1.9.0 + , json >= 0.5 + , old-locale -any + , pretty -any + , process >= 1.1.0.2 + , pureMD5 >= 2.1.2.1 + , random -any + , regex-posix >= 0.95.2 + , resourcet >= 0.3 + , split >= 0.2.0.0 + , time -any + , unix -any + , utf8-string -any + , xml >= 1.2.6 main-is: Main.hs buildable: True hs-source-dirs: src - other-modules: Network.Google Network.Google.Contacts - Network.Google.Storage Network.Google.OAuth2 Network.Google.Picasa - Network.Google.Bookmarks Network.Google.Books - Network.Google.Storage.Encrypted Network.Google.Storage.Sync + other-modules: Crypto.GnuPG + Crypto.MD5 + Network.Google + Network.Google.Bookmarks + Network.Google.Books + Network.Google.Contacts Network.Google.FusionTables - Crypto.MD5 Crypto.GnuPG + Network.Google.OAuth2 + Network.Google.Picasa + Network.Google.Storage + Network.Google.Storage.Encrypted + Network.Google.Storage.Sync 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, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} module Network.Google ( @@ -27,7 +27,6 @@ , appendQuery , doManagedRequest , doRequest --- , retryIORequest , makeHeaderName , makeProjectRequest , makeRequest @@ -35,8 +34,7 @@ ) where -import qualified Control.Exception as E -import Control.Concurrent (threadDelay) +import Control.Exception (finally) import Control.Monad.Trans.Resource (ResourceT, runResourceT) import Data.List (intercalate) import Data.Maybe (fromJust) @@ -46,8 +44,7 @@ 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(..), HttpException, - closeManager, def, httpLbs, newManager, responseBody) +import Network.HTTP.Conduit (Manager, Request(..), RequestBody(..), Response(..), closeManager, def, httpLbs, newManager, responseBody) import Text.JSON (JSValue, Result(Ok), decode) import Text.XML.Light (Element, parseXMLDoc) @@ -118,7 +115,7 @@ doManagedRequest manager request --} manager <- newManager def - E.finally + finally (doManagedRequest manager request) (closeManager manager) doManagedRequest :: @@ -238,24 +235,3 @@ -- 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,8 +135,7 @@ do resp <- doRequest req case parseTables resp of Ok x -> return x - Error err -> error$ "listTables: failed to parse JSON response, error was:\n " - ++err++"\nJSON response was:\n "++show resp + Error err -> error$ "listTables: failed to parse JSON response:\n"++err 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,8 +85,6 @@ 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) @@ -95,8 +93,7 @@ import System.Info (os) import System.Process (rawSystem) import System.Exit (ExitCode(..)) -import System.Directory (doesFileExist, doesDirectoryExist, getAppUserDataDirectory, - createDirectory, renameFile, removeFile) +import System.Directory (doesFileExist, doesDirectoryExist, getAppUserDataDirectory, createDirectory, renameFile) import System.FilePath ((),(<.>), splitExtension) import System.Random (randomIO) @@ -298,68 +295,42 @@ -- 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 - 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 + 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 else do toks <- askUser - 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 - + atomicWriteFile tokenF (show toks) + return toks + where + -- TODO: Convert relative time to absolute UTF time for the tokens: + timestamp toks = + return toks + -- This is the part where we require user interaction: askUser = do - putStrLn$ " [getCachedTokens] Load this URL: "++show permissionUrl + putStrLn$ "Load this URL: "++show permissionUrl runBrowser - putStrLn " [getCachedTokens] Then please paste the verification code and press enter:\n$ " + putStrLn "Then please paste the verification code and press enter:\n$ " authcode <- getLine tokens <- exchangeCode client authcode - putStrLn$ " [getCachedTokens] Received access token: "++show (accessToken tokens) + putStrLn$ "Received access token: "++show (accessToken tokens) return tokens permissionUrl = formUrl client ["https://www.googleapis.com/auth/fusiontables"]