diff --git a/handa-gdata.cabal b/handa-gdata.cabal --- a/handa-gdata.cabal +++ b/handa-gdata.cabal @@ -1,5 +1,5 @@ name: handa-gdata -version: 0.4.1 +version: 0.6.0 cabal-version: >=1.6 build-type: Simple license: MIT @@ -42,6 +42,8 @@ . * DELETE Object . + Operations in the Google Fusion Tables API are also supported. + . For the unofficial Google Bookmarks API, the following operations are supported: . * List bookmarks @@ -74,25 +76,27 @@ library build-depends: HTTP -any, base <6, base64-bytestring -any, binary -any, bytestring -any, case-insensitive -any, cmdargs -any, - directory -any, filepath -any, http-conduit -any, json -any, - old-locale -any, process -any, pureMD5 -any, regex-posix -any, - resourcet -any, time -any, unix -any, utf8-string -any, xml -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 + Network.Google.FusionTables exposed: True buildable: True hs-source-dirs: src - other-modules: Data.List.Util executable hgdata build-depends: HTTP -any, base <6, base64-bytestring -any, binary -any, bytestring -any, case-insensitive -any, cmdargs -any, - directory -any, filepath -any, http-conduit -any, json -any, - old-locale -any, process -any, pureMD5 -any, regex-posix -any, - resourcet -any, time -any, unix -any, utf8-string -any, xml -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 main-is: Main.hs buildable: True hs-source-dirs: src @@ -100,5 +104,6 @@ Network.Google.Storage Network.Google.OAuth2 Network.Google.Picasa Network.Google.Bookmarks Network.Google.Books Network.Google.Storage.Encrypted Network.Google.Storage.Sync - Crypto.MD5 Crypto.GnuPG Data.List.Util + Network.Google.FusionTables + Crypto.MD5 Crypto.GnuPG diff --git a/src/Crypto/MD5.hs b/src/Crypto/MD5.hs --- a/src/Crypto/MD5.hs +++ b/src/Crypto/MD5.hs @@ -13,6 +13,9 @@ ----------------------------------------------------------------------------- +{-# LANGUAGE BangPatterns #-} + + module Crypto.MD5 ( -- * Types MD5Info @@ -23,13 +26,14 @@ , md5 , md5Base64 , md5ToBase64 +, md5Empty ) where import Data.Binary as B (encode) import Data.ByteString as BS (concat) import Data.ByteString.Char8 as BS8 (unpack) -import Data.ByteString.Lazy as LBS (ByteString, toChunks) +import Data.ByteString.Lazy as LBS (ByteString, empty, toChunks) import Data.ByteString.Base64 as B64 (encode) import Data.Digest.Pure.MD5 (MD5Digest, md5) @@ -52,8 +56,8 @@ -> MD5Info -- ^ The MD5 sum. md5Base64 x = let - y = md5 x - z = md5ToBase64 y + !y = md5 x + !z = md5ToBase64 y in (show y, z) @@ -63,3 +67,9 @@ MD5Digest -- ^ The MD5 digest. -> MD5Base64 -- ^ The MD5 checksum in base 64 encoding. md5ToBase64 = BS8.unpack . B64.encode . BS.concat . LBS.toChunks . B.encode + + + +-- | The MD5 info for an empty string. +md5Empty :: MD5Info +md5Empty = md5Base64 empty diff --git a/src/Data/List/Util.hs b/src/Data/List/Util.hs deleted file mode 100644 --- a/src/Data/List/Util.hs +++ /dev/null @@ -1,34 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Data.List.Util --- Copyright : (c) 2012-13 Brian W Bush --- License : MIT --- --- Maintainer : Brian W Bush --- Stability : Stable --- Portability : Portable --- --- | Miscellaneous functions for manipulating lists. --- ------------------------------------------------------------------------------ - - -module Data.List.Util ( - separate -) where - - --- | The 'separate' function splits a list into fragments separated by a given element. -separate :: Eq a => - a -- ^ The separating element - -> [a] -- ^ The list to be separated - -> [[a]] -- ^ The lists between the separating element -separate _ [] = [] -separate a s = - let - (l, s') = break (== a) s - in - l : case s' of - [] -> [] - [a] -> [[]] - (_:s'') -> separate a s'' diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -161,7 +161,7 @@ , gshead , gssync ] - &= summary "hgData v0.4.1, (c) 2012-13 Brian W. Bush , MIT license." + &= summary "hgData v0.6.0, (c) 2012-13 Brian W. Bush , MIT license." &= program "hgdata" &= help "Command-line utility for accessing Google services and APIs. Send bug reports and feature requests to ." @@ -172,6 +172,7 @@ { client = def &= typ "ID" &= help "Client ID" } + &= name "oauth2-url" &= help "Generate an OAuth 2.0 URL." &= details [ @@ -192,6 +193,7 @@ , code = def &= typ "CODE" &= argPos 0 , tokens = def &= opt "/dev/stdout" &= typFile &= argPos 1 } + &= name "oauth2-exchange" &= help "Exchange an OAuth 2.0 code for tokens." &= details [ @@ -212,6 +214,7 @@ , refresh = def &= typ "TOKEN" &= help "OAuth 2.0 refresh token" , tokens = def &= opt "/dev/stdout" &= typFile &= argPos 0 } + &= name "oauth2-refresh" &= help "Refresh OAuth 2.0 tokens." &= details [ diff --git a/src/Network/Google/Bookmarks.hs b/src/Network/Google/Bookmarks.hs --- a/src/Network/Google/Bookmarks.hs +++ b/src/Network/Google/Bookmarks.hs @@ -30,7 +30,7 @@ import Data.Maybe (fromJust) import Data.Time.Clock (getCurrentTime) import Network.Google (appendHeaders) -import Network.HTTP.Conduit (Request(..), RequestBody(..), Response(..), def, httpLbs, insertCookiesIntoRequest, parseUrl, updateCookieJar, withManager) +import Network.HTTP.Conduit (CookieJar, Request(..), RequestBody(..), Response(..), def, httpLbs, parseUrl, withManager) import Text.XML.Light (Element(..), QName(..), blank_name, filterElement, findAttr, parseXMLDoc) @@ -60,12 +60,10 @@ responseGet1 <- httpLbs requestGet1 manager let encode = LBS8.unpack . fromString - cookieInserter cookieJar request = fst $ insertCookiesIntoRequest request cookieJar now responseXml = fromJust . parseXMLDoc . toString . responseBody bodyGet1 = responseXml responseGet1 - (cookieJarGet1, _) = updateCookieJar responseGet1 requestGet1 now def + cookieJarGet1 = responseCookieJar responseGet1 requestPost1 = - cookieInserter cookieJarGet1 $ (accountsPostRequest "/ServiceLoginAuth") { requestBody = RequestBodyBS $ BS8.pack $ "continue=" ++ listingUrl @@ -76,14 +74,14 @@ ++ "&Email=" ++ encode email ++ "&Passwd=" ++ encode password ++ "&PersistentCookie=yes" + , cookieJar = Just cookieJarGet1 , redirectCount = 0 - , checkStatus = \_ _ -> Nothing + , checkStatus = \_ _ _ -> Nothing } responsePost1 <- httpLbs requestPost1 manager let - (cookieJarPost1, _) = updateCookieJar responsePost1 requestPost1 now cookieJarGet1 + cookieJarPost1 = responseCookieJar responsePost1 requestPost2 = - cookieInserter cookieJarPost1 $ (accountsPostRequest "/SmsAuth") { queryString = BS8.pack $ "?continue=" ++ listingUrl ++ "&service=bookmarks" , requestBody = RequestBodyBS $ BS8.pack $ @@ -92,15 +90,15 @@ ++ "&exp=smsauthnojs" ++ "&smsUserPin=" ++ encode smsToken ++ "&PersistentCookie=yes" + , cookieJar = Just cookieJarPost1 , redirectCount = 0 - , checkStatus = \_ _ -> Nothing + , checkStatus = \_ _ _ -> Nothing } responsePost2 <- httpLbs requestPost2 manager let bodyPost2 = responseXml responsePost2 - (cookieJarPost2, _) = updateCookieJar responsePost2 requestPost2 now cookieJarPost1 + cookieJarPost2 = responseCookieJar responsePost2 requestPost3 = - cookieInserter cookieJarPost2 $ (accountsPostRequest "/ServiceLoginAuth") { queryString = BS8.pack $ "?continue=" ++ listingUrl , requestBody = RequestBodyBS $ BS8.pack $ @@ -108,6 +106,7 @@ ++ "&smsToken=" ++ extractValue "smsToken" bodyPost2 ++ "&GALX=" ++ extractValue "GALX" bodyGet1 ++ "&bgresponse=js_disabled" + , cookieJar = Just cookieJarPost2 } responsePost3 <- httpLbs requestPost3 manager return $ responseXml responsePost3 diff --git a/src/Network/Google/Contacts.hs b/src/Network/Google/Contacts.hs --- a/src/Network/Google/Contacts.hs +++ b/src/Network/Google/Contacts.hs @@ -23,7 +23,7 @@ import Control.Monad ((<=<), (>>), liftM) import Crypto.GnuPG (Recipient, decrypt, encrypt) import Data.List (stripPrefix) -import Data.Maybe (fromJust, mapMaybe) +import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Network.Google (AccessToken, doRequest, makeRequest, makeRequestValue) import Network.HTTP.Conduit (Request(..), def, httpLbs, responseBody, withManager) import Text.XML.Light (Element, elChildren, filterChildName, parseXMLDoc, qName, strContent) @@ -97,8 +97,9 @@ getEntry :: Element -> Maybe (String, String, String) getEntry x = do - t <- getTitle x - o <- getOrganization x + let + t = fromMaybe "" $ getTitle x + o = fromMaybe "" $ getOrganization x p <- getPGP x return (t, o, p) in diff --git a/src/Network/Google/FusionTables.hs b/src/Network/Google/FusionTables.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/FusionTables.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DeriveGeneric #-} +----------------------------------------------------------------------------- +-- +-- Module : Network.Google.FusionTables +-- Copyright : (c) 2013 Ryan Newton +-- License : MIT +-- +-- Maintainer : Ryan Newton +-- Stability : Stable +-- Portability : Portable +-- +-- | Functions for accessing the Fusion Tables API, see +-- . +-- +-- This provides a very limited subset of the complete (v1) API at present. +----------------------------------------------------------------------------- + + +module Network.Google.FusionTables ( + -- * Types + TableId, TableMetadata(..), ColumnMetadata(..) + + -- * Raw API routines, returning raw JSON + , listTables, listColumns +-- , sqlQuery + + -- * Parsing result of raw API routines + , parseTables, parseColumns + + -- * Higher level interface to common SQL queries + , insertRows + -- , filterRows +) where + +import Control.Monad (liftM) +import Data.Maybe (mapMaybe) +import Data.List as L +import qualified Data.ByteString.Char8 as B +import Network.Google (AccessToken, ProjectId, doRequest, makeRequest) +import Network.HTTP.Conduit (Request(..)) +import qualified Network.HTTP as H +import Text.XML.Light (Element(elContent), QName(..), filterChildrenName, findChild, strContent) + +-- TODO: Ideally this dependency wouldn't exist here and the user could select their +-- own JSON parsing lib (e.g. Aeson). +import Text.JSON (JSObject(..), JSValue(..), Result(Ok,Error), decode, valFromObj) + +-- For easy pretty printing: +import Text.PrettyPrint.GenericPretty (Out(doc,docPrec), Generic) +import Text.PrettyPrint.HughesPJ (text) + +-------------------------------------------------------------------------------- +-- Haskell Types corresponding to JSON responses + +-- This could include non-ASCII characters: +-- TODO: Use Data.Text +-- type FTString = B.ByteString +type FTString = String + +-- | An incomplete representation of +data TableMetadata = + TableMetadata + { tab_name :: FTString + , tab_tableId :: FTString + , tab_columns :: [ColumnMetadata] + } deriving (Eq, Show, Read, Ord, Generic) + +data ColumnMetadata = + ColumnMetadata + { col_columnId :: Int + , col_name :: FTString + , col_type :: FTString + } deriving (Eq, Show, Read, Ord, Generic) + +-- TODO: Use Data.Aeson.TH + +instance Out TableMetadata +instance Out ColumnMetadata +-- instance Out B.ByteString where docPrec _ = text . B.unpack; doc = docPrec 0 + +-- | ID for a specific fusion table +type TableId = FTString + +-------------------------------------------------------------------------------- + +-- | The host for API access. +fusiontableHost :: String +-- fusiontableHost = "https://www.googleapis.com/fusiontables/v1" +fusiontableHost = "www.googleapis.com" + +-- | The API version used here. +fusiontableApi :: (String, String) +fusiontableApi = ("Gdata-version", "2") +-- RRN: Is there documentation for what this means? It seems like "Gdata" might be +-- deprecated with the new google APIs? + + +-- | List all tables belonging to a user. +-- See . +listTables :: AccessToken -- ^ The OAuth 2.0 access token. + -> IO JSValue +listTables accessToken = doRequest req + where + req = makeRequest accessToken fusiontableApi "GET" + ( fusiontableHost, "fusiontables/v1/tables" ) + + +-- | Construct a simple Haskell representation of the result of `listTables`. +parseTables :: JSValue -> Result [TableMetadata] +parseTables (JSObject ob) = do + JSArray allTables <- valFromObj "items" ob + mapM parseTab allTables + where + parseTab :: JSValue -> Result TableMetadata + parseTab (JSObject ob) = do + tab_name <- valFromObj "name" ob + tab_tableId <- valFromObj "tableId" ob + tab_columns <- mapM parseColumn =<< valFromObj "columns" ob + return TableMetadata {tab_name, tab_tableId, tab_columns} + parseTab oth = Error$ "parseTable: Expected JSObject, got "++show oth + +parseColumn :: JSValue -> Result ColumnMetadata +parseColumn (JSObject ob) = do + col_name <- valFromObj "name" ob + col_columnId <- valFromObj "columnId" ob + col_type <- valFromObj "type" ob + return ColumnMetadata {col_name, col_type, col_columnId} +parseColumn oth = Error$ "parseColumn: Expected JSObject, got "++show oth + +-- | List the columns within a specific table. +-- See . +listColumns :: AccessToken -- ^ The OAuth 2.0 access token. + -> TableId -- ^ which table + -> IO JSValue +listColumns accessToken tid = doRequest req + where + req = makeRequest accessToken fusiontableApi "GET" + ( fusiontableHost, "fusiontables/v1/tables/"++tid++"/columns" ) + +-- | Parse the output of `listColumns`. +parseColumns :: JSValue -> Result [ColumnMetadata] +parseColumns (JSObject ob) = do + JSArray cols <- valFromObj "items" ob + mapM parseColumn cols + +-------------------------------------------------------------------------------- + +sqlQuery = error "sqlQuery" + +-- | Insert one or more rows into a table. Rows are represented as lists of strings. +-- The columns being written are passed in as a separate list. The length of all +-- rows must match eachother and must match the list of column names. +-- +insertRows :: AccessToken -> TableId + -> [FTString] -- ^ Which columns to write. + -> [[FTString]] -- ^ Rows + -> IO () +insertRows tok tid cols rows = + do putStrLn$"DOING REQUEST "++show req + putStrLn$ "VALS before encode "++ show vals + doRequest req + where + req = (makeRequest tok fusiontableApi "GET" + (fusiontableHost, "fusiontables/v1/query" )) + { + method = B.pack "POST", + queryString = B.pack$ H.urlEncodeVars [("sql",query)] + } + query = concat $ L.intersperse ";\n" $ + map (("INSERT INTO "++tid++" "++ colstr ++" VALUES ")++) vals + numcols = length cols + colstr = parens$ concat$ L.intersperse ", " cols + vals = map fn rows + fn row = + if length row == numcols + then parens$ concat$ L.intersperse ", " $ map singQuote row + else error$ "insertRows: got a row with an incorrect number of arguments, expected " + ++ show numcols ++": "++ show row + + parens s = "(" ++ s ++ ")" + singQuote x = "'"++x++"'" + + +-- Implement a larger quantity of rows, but with the caveat that the number and order +-- of columns must exactly match the schema of the fusion table on the server. +bulkImportRows = error "implement bulkImportRows" + +filterRows = error "implement filterRows" 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 @@ -10,6 +10,59 @@ -- -- | Functions for OAuth 2.0 authentication for Google APIs. -- +-- If you are new to Google web API's, bear in mind that there are /three/ different +-- methods for accessing APIs (installed applications, web apps, service-to-service), +-- and this library is most useful for \"installed applications\". +-- +-- Installed applications need the user to grant permission in a browser at least +-- once (see `formUrl`). However, while the resulting `accessToken` expires quickly, +-- the `refreshToken` can be used indefinitely for retrieving new access tokens. +-- Thus this approach can be suitable for long running or periodic programs that +-- access Google data. +-- +-- Below is a quick-start program which will list any Google Fusion tables the user +-- possesses. It requires the client ID and secret retrieved from +-- . +-- +-- @ +-- import Control.Monad (unless) +-- import System.Info (os) +-- import System.Process (system, rawSystem) +-- import System.Exit (ExitCode(..)) +-- import System.Directory (doesFileExist) +-- import Network.Google.OAuth2 (formUrl, exchangeCode, refreshTokens, +-- OAuth2Client(..), OAuth2Tokens(..)) +-- import Network.Google (makeRequest, doRequest) +-- import Network.HTTP.Conduit (simpleHttp) +-- -- +-- cid = \"INSTALLED_APP_CLIENT_ID\" +-- secret = \"INSTALLED_APP_SECRET_HERE\" +-- file = \"./tokens.txt\" +-- -- +-- main = do +-- -- Ask for permission to read/write your fusion tables: +-- let client = OAuth2Client { clientId = cid, clientSecret = secret } +-- permissionUrl = formUrl client [\"https://www.googleapis.com/auth/fusiontables\"] +-- b <- doesFileExist file +-- unless b $ do +-- putStrLn$ \"Load this URL: \"++show permissionUrl +-- case os of +-- \"linux\" -> rawSystem \"gnome-open\" [permissionUrl] +-- \"darwin\" -> rawSystem \"open\" [permissionUrl] +-- _ -> return ExitSuccess +-- putStrLn \"Please paste the verification code: \" +-- authcode <- getLine +-- tokens <- exchangeCode client authcode +-- putStrLn$ \"Received access token: \"++show (accessToken tokens) +-- tokens2 <- refreshTokens client tokens +-- putStrLn$ \"As a test, refreshed token: \"++show (accessToken tokens2) +-- writeFile file (show tokens2) +-- accessTok <- fmap (accessToken . read) (readFile file) +-- putStrLn \"As a test, list the users tables:\" +-- response <- simpleHttp (\"https://www.googleapis.com/fusiontables/v1/tables?access_token=\"++accessTok) +-- putStrLn$ BL.unpack response +-- @ + ----------------------------------------------------------------------------- @@ -24,16 +77,25 @@ , 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.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) +import System.FilePath ((),(<.>), splitExtension) +import System.Random (randomIO) -- An OAuth 2.0 client for an installed application, see . @@ -79,6 +141,7 @@ , ("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") @@ -224,3 +287,61 @@ expiresIn' :: Rational (Ok (JSRational _ expiresIn')) = valFromObj "expires_in" result return expiresIn' + + +-- | Provide a hassle-free way to retrieve and refresh tokens from a users home +-- directory, OR ask the user for permission. +-- +-- 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. +-- +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" + 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 + atomicWriteFile tokenF (show toks2) + return toks2 + else do + toks <- askUser + atomicWriteFile tokenF (show toks) + return toks + where + -- This is the part where we require user interaction: + askUser = do + putStrLn$ "Load this URL: "++show permissionUrl + runBrowser + putStrLn "Then please paste the verification code and press enter:\n$ " + authcode <- getLine + tokens <- exchangeCode client authcode + putStrLn$ "Received access token: "++show (accessToken tokens) + return tokens + + permissionUrl = formUrl client ["https://www.googleapis.com/auth/fusiontables"] + + -- This is hackish and incomplete + 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 makes this atomic: + renameFile tmp file + diff --git a/src/Network/Google/Storage.hs b/src/Network/Google/Storage.hs --- a/src/Network/Google/Storage.hs +++ b/src/Network/Google/Storage.hs @@ -48,7 +48,7 @@ import Data.ByteString.UTF8 (fromString) import Data.ByteString.Lazy (ByteString) import Data.List (intercalate, stripPrefix) -import Data.List.Util (separate) +import Data.List.Split (splitOn) import Data.Maybe (fromJust, isNothing, maybe) import Network.Google (AccessToken, ProjectId, appendBody, appendHeaders, appendQuery, doManagedRequest, doRequest, makeProjectRequest) import Network.HTTP.Base (urlEncode) @@ -119,7 +119,7 @@ String -- ^ The unencoded path. -> String -- ^ The URL-encoded path. -- TODO: Review whether the sequence of UTF-8 encoding and URL encoding is correct. This works correctly with tests of exotic unicode sequences, however. -makePath = ('/' :) . intercalate "/" . map (urlEncode . unpack . fromString) . separate '/' +makePath = ('/' :) . intercalate "/" . map (urlEncode . unpack . fromString) . splitOn "/" -- | List all of the buckets in a specified project. This performs the \"GET Service\" request, see . diff --git a/src/Network/Google/Storage/Sync.hs b/src/Network/Google/Storage/Sync.hs --- a/src/Network/Google/Storage/Sync.hs +++ b/src/Network/Google/Storage/Sync.hs @@ -25,10 +25,10 @@ import Control.Exception (SomeException, finally, handle) import Control.Monad (filterM, liftM, when) import Crypto.GnuPG (Recipient) -import Crypto.MD5 (MD5Info, md5Base64) +import Crypto.MD5 (MD5Info, md5Base64, md5Empty) import qualified Data.ByteString.Lazy as LBS (ByteString, readFile) import qualified Data.Digest.Pure.MD5 as MD5 (md5) -import Data.List ((\\), deleteFirstsBy, intersectBy) +import Data.List ((\\), sort) import Data.Maybe (fromJust, mapMaybe) import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) @@ -66,11 +66,22 @@ -> IO () -- ^ The IO action for the synchronization. sync projectId acl bucket client tokens directory recipients exclusions md5sums purge = do - manager <- newManager def putStrLn $ "DIRECTORY " ++ directory putStrLn $ "PROJECT " ++ projectId putStrLn $ "BUCKET " ++ bucket putStrLn $ "ACCESS " ++ show acl + putStr "LOCAL " + hFlush stdout + let + byETag = null recipients && md5sums + local <- liftM sort $ walkDirectories byETag directory + print $ length local + putStr "EXCLUDED " + hFlush stdout + let + local' = filter (makeExcluder exclusions) local + print $ length local - length local' + manager <- newManager def finally ( sync' @@ -78,8 +89,8 @@ ((if null recipients then putObjectUsingManager manager else putEncryptedObjectUsingManager manager recipients) projectId acl bucket) (deleteObjectUsingManager manager projectId bucket) client tokens directory - (null recipients) - (makeExcluder exclusions) + byETag + local' md5sums purge )( @@ -155,30 +166,26 @@ -- | Synchronize a filesystem directory with a Google Storage bucket. sync' :: - Lister -- ^ The bucket listing function. - -> Putter -- ^ The object putting function. - -> Deleter -- ^ The object deletion function. - -> OAuth2Client -- ^ The OAuth 2.0 client information. - -> OAuth2Tokens -- ^ The OAuth 2.0 tokens. - -> FilePath -- ^ The directory to be synchronized. - -> Bool -- ^ Whether to use ETags in comparing object metadata. - -> Excluder -- ^ The function for excluding objects. - -> Bool -- ^ Whether to write a file \".md5sum\" of MD5 sums of synchronized files into the root directory. - -> Bool -- ^ Whether to delete keys from the bucket that do not correspond to files on the filesystem. - -> IO () -- ^ The IO action for the synchronization. -sync' lister putter deleter client tokens directory byETag excluder md5sums purge = + Lister -- ^ The bucket listing function. + -> Putter -- ^ The object putting function. + -> Deleter -- ^ The object deletion function. + -> OAuth2Client -- ^ The OAuth 2.0 client information. + -> OAuth2Tokens -- ^ The OAuth 2.0 tokens. + -> FilePath -- ^ The directory to be synchronized. + -> Bool -- ^ Whether to use ETags in comparing object metadata. + -> [ObjectMetadata] -- ^ The local file system objects to be synchronized. + -> Bool -- ^ Whether to write a file \".md5sum\" of MD5 sums of synchronized files into the root directory. + -> Bool -- ^ Whether to delete keys from the bucket that do not correspond to files on the filesystem. + -> IO () -- ^ The IO action for the synchronization. +sync' lister putter deleter client tokens directory byETag local md5sums purge = do - putStr "LOCAL " - hFlush stdout - local <- walkDirectories directory - print $ length local now <- getCurrentTime tokenClock@(_, tokens') <- checkExpiration client (addUTCTime (-60) now, tokens) putStr "REMOTE " hFlush stdout remote' <- lister $ toAccessToken $ accessToken tokens' let - remote = parseMetadata remote' + remote = sort $ parseMetadata remote' print $ length remote let tolerance = 300 @@ -187,21 +194,16 @@ sameETag :: ObjectMetadata -> ObjectMetadata -> Bool sameETag (ObjectMetadata key eTag _ _) (ObjectMetadata key' eTag' _ _) = key == key' && fst eTag == fst eTag' earlierTime :: ObjectMetadata -> ObjectMetadata -> Bool - earlierTime (ObjectMetadata key _ _ time) (ObjectMetadata key' eTag' _ time') = key == key' && time > addUTCTime tolerance time' - putStr "EXCLUDED " - hFlush stdout - let - local' = filter excluder local - print $ length local - length local' + earlierTime (ObjectMetadata key _ _ time) (ObjectMetadata key' _ _ time') = key == key' && addUTCTime tolerance time < time' putStr "PUTS " hFlush stdout let - changedObjects = deleteFirstsBy (if byETag then sameETag else earlierTime) local' remote + changedObjects = deleteFirstsBy' (if byETag then sameETag else earlierTime) local remote print $ length changedObjects putStr "DELETES " hFlush stdout let - deletedObjects = deleteFirstsBy sameKey remote local' + deletedObjects = deleteFirstsBy' sameKey remote local print $ length deletedObjects tokenClock' <- walkPutter client tokenClock directory putter changedObjects tokenClock'' <- if purge @@ -210,9 +212,23 @@ else return tokenClock' when md5sums $ - writeFile (directory ++ "/.md5sum") $ unlines $ map (\x -> (fst . eTag) x ++ " ./" ++ key x) local' + writeFile (directory ++ "/.md5sum") $ unlines $ map (\x -> (fst . eTag) x ++ " ./" ++ key x) local +-- | Delete the first occurrence of items in the second list from the first list, assuming both lists are sorted. +deleteFirstsBy' :: Ord a => + (a -> a -> Bool) -- ^ The equality function. + -> [a] -- ^ The first list, which must have been sorted. + -> [a] -- ^ The second list, which must have been sorted. + -> [a] -- ^ The items in the first list not appearing in the second list. +deleteFirstsBy' _ [] _ = [] +deleteFirstsBy' _ xx [] = xx +deleteFirstsBy' equal xx@(x : xs) yy@(y : ys) + | equal x y = deleteFirstsBy' equal xs ys + | x > y = deleteFirstsBy' equal xx ys + | otherwise = x : deleteFirstsBy' equal xs yy + + -- | Put a list of objects. walkPutter :: OAuth2Client -- ^ The OAuth 2.0 client information. @@ -232,8 +248,10 @@ handler ( do + let + eTag' x = if eTag x == md5Empty then Nothing else Just $ eTag x bytes <- LBS.readFile $ directory ++ [pathSeparator] ++ key' - putter key' Nothing bytes (Just $ eTag x) (toAccessToken $ accessToken tokens') + putter key' Nothing bytes (eTag' x) (toAccessToken $ accessToken tokens') return () ) walkPutter client tokenClock' directory putter xs @@ -278,7 +296,13 @@ } deriving (Show) +instance Ord ObjectMetadata where + compare (ObjectMetadata key _ _ _) (ObjectMetadata key' _ _ _) = compare key key' +instance Eq ObjectMetadata where + (ObjectMetadata key _ _ _) == (ObjectMetadata key' _ _ _) = key == key' + + -- | Parse XML metadata into object descriptions. parseMetadata :: Element -- ^ The XML metadata. @@ -302,25 +326,27 @@ -- | Gather file metadata from the file system. walkDirectories :: - FilePath -- ^ The directory to be synchronized. + Bool -- ^ Whether to compute MD5 sums. + -> FilePath -- ^ The directory to be synchronized. -> IO [ObjectMetadata] -- ^ Action returning file descriptions. -walkDirectories directory = walkDirectories' (directory ++ [pathSeparator]) [""] +walkDirectories eTags directory = walkDirectories' eTags (directory ++ [pathSeparator]) [""] -- | Gather file metadata from the file system. walkDirectories' :: - FilePath -- ^ The directory to be synchronized. + Bool -- ^ Whether to compute MD5 sums. + -> FilePath -- ^ The directory to be synchronized. -> [FilePath] -- ^ The subdirectories still remaining to be described. -> IO [ObjectMetadata] -- ^ Action returning file descriptions. -walkDirectories' _ [] = return [] -walkDirectories' directory (y : ys) = +walkDirectories' _ _ [] = return [] +walkDirectories' eTags directory (y : ys) = handle (( \exception -> do putStrLn $ " LIST " ++ y putStrLn $ " FAIL " ++ show exception - walkDirectories' directory ys + walkDirectories' eTags directory ys ) :: SomeException -> IO [ObjectMetadata]) ( do @@ -334,17 +360,13 @@ bytes <- LBS.readFile path status <- getFileStatus path let - lastTime :: UTCTime - lastTime = posixSecondsToUTCTime $ realToFrac $ modificationTime status - size :: Int - size = fromIntegral $ fileSize status - let !eTag = md5Base64 bytes - let !x = fst eTag - let !y = snd eTag + !lastTime = posixSecondsToUTCTime $ realToFrac $ modificationTime status + !size = fromIntegral $ fileSize status + !eTag = if eTags then md5Base64 bytes else md5Empty return $ ObjectMetadata key eTag size lastTime files <- liftM (map ((y ++ [pathSeparator]) ++) . ( \\ [".", ".."])) $ getDirectoryContents (directory ++ y) y' <- filterM (doesDirectoryExist . (directory ++)) files x' <- mapM makeMetadata $ files \\ y' - liftM (x' ++) $ walkDirectories' directory (y' ++ ys) + liftM (x' ++) $ walkDirectories' eTags directory (y' ++ ys) )