handa-gdata 0.4.1 → 0.6.0

raw patch · 10 files changed

+424/−108 lines, 10 filesdep +GenericPrettydep +prettydep +randomPVP ok

version bump matches the API change (PVP)

Dependencies added: GenericPretty, pretty, random, split

API changes (from Hackage documentation)

Files

• handa-gdata.cabal +14/−9
• src/Crypto/MD5.hs +13/−3
• src/Data/List/Util.hs +0/−34
• src/Main.hs +4/−1
• src/Network/Google/Bookmarks.hs +9/−10
• src/Network/Google/Contacts.hs +4/−3
• src/Network/Google/FusionTables.hs +189/−0
• src/Network/Google/OAuth2.hs +121/−0
• src/Network/Google/Storage.hs +2/−2
• src/Network/Google/Storage/Sync.hs +68/−46

@@ -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  

@@ -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

@@ -1,34 +0,0 @@------------------------------------------------------------------------------------ Module      :  Data.List.Util--- Copyright   :  (c) 2012-13 Brian W Bush--- License     :  MIT------ Maintainer  :  Brian W Bush <b.w.bush@acm.org>--- 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''

@@ -161,7 +161,7 @@     , gshead     , gssync     ]-    &= summary "hgData v0.4.1, (c) 2012-13 Brian W. Bush <b.w.bush@acm.org>, MIT license."+    &= summary "hgData v0.6.0, (c) 2012-13 Brian W. Bush <b.w.bush@acm.org>, MIT license."     &= program "hgdata"     &= help "Command-line utility for accessing Google services and APIs. Send bug reports and feature requests to <http://code.google.com/p/hgdata/issues/entry>." @@ -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       [

@@ -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

@@ -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

@@ -0,0 +1,189 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DeriveGeneric #-}+-----------------------------------------------------------------------------+--+-- Module      :  Network.Google.FusionTables+-- Copyright   :  (c) 2013 Ryan Newton+-- License     :  MIT+--+-- Maintainer  :  Ryan Newton <ryan.newton@alum.mit.edu>+-- Stability   :  Stable+-- Portability :  Portable+--+-- | Functions for accessing the Fusion Tables API, see+--   <https://developers.google.com/fusiontables/>.+--+--   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 <https://developers.google.com/fusiontables/docs/v1/reference/table#resource>+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 <https://developers.google.com/fusiontables/docs/v1/reference/table/list>.+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 <https://developers.google.com/fusiontables/docs/v1/reference/column/list>.+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"

@@ -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 +-- <https://code.google.com/apis/console>.+--+-- @+-- 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 <https://developers.google.com/accounts/docs/OAuth2InstalledApp>.@@ -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+

@@ -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 <https://developers.google.com/storage/docs/reference-methods#getservice>.

@@ -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)     )