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.3.1 +version: 0.4.1 cabal-version: >=1.6 build-type: Simple license: MIT @@ -42,11 +42,27 @@ . * DELETE Object . + For the unofficial Google Bookmarks API, the following operations are supported: + . + * List bookmarks + . + For the Google Books API, the following operations are supported: + . + * List bookshelves + . + * List books + . For the Google Contacts API, the following operations are supported: . * Downloading a full list of contacts in XML format . * Extracting and decrypting GnuPG/PGP text in contacts' Notes fields + . + For the Picasa API, the following operations are supported: + . + * Listing albums + . + * Listing photos in an album category: Network author: Brian W Bush data-dir: "" @@ -60,27 +76,29 @@ 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, text -any, time -any, unix -any, xml -any + resourcet -any, time -any, unix -any, utf8-string -any, xml -any exposed-modules: Crypto.GnuPG Crypto.MD5 Network.Google - Network.Google.Contacts Network.Google.OAuth2 + 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 exposed: True buildable: True hs-source-dirs: src - other-modules: Data.ByteString.Util Data.List.Util + 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, text -any, time -any, unix -any, xml -any + resourcet -any, time -any, unix -any, utf8-string -any, xml -any 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.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.ByteString.Util Data.List.Util + Crypto.MD5 Crypto.GnuPG Data.List.Util diff --git a/src/Crypto/GnuPG.hs b/src/Crypto/GnuPG.hs --- a/src/Crypto/GnuPG.hs +++ b/src/Crypto/GnuPG.hs @@ -24,10 +24,10 @@ ) where -import Control.Concurrent (forkIO) +import Control.Concurrent (ThreadId, forkIO) import qualified Data.ByteString.Lazy as LBS (ByteString, hGetContents, hPutStr) import System.Process (runInteractiveProcess) -import System.IO (hClose, hFlush, hGetContents, hPutStr) +import System.IO (Handle, hClose, hFlush, hGetContents, hPutStr) -- | A recipient for encryption. @@ -50,15 +50,8 @@ ] Nothing Nothing - forkIO - ( - do - hPutStr hIn input - hFlush hIn - hClose hIn - ) - output <- hGetContents hOut - return output + consumeInput hPutStr hIn input + hGetContents hOut -- | Encrypt text. @@ -82,15 +75,8 @@ ) Nothing Nothing - forkIO - ( - do - hPutStr hIn input - hFlush hIn - hClose hIn - ) - output <- hGetContents hOut - return output + consumeInput hPutStr hIn input + hGetContents hOut -- | Decrypt binary data. @@ -109,15 +95,8 @@ ] Nothing Nothing - forkIO - ( - do - LBS.hPutStr hIn input - hFlush hIn - hClose hIn - ) - output <- LBS.hGetContents hOut - return output + consumeInput LBS.hPutStr hIn input + LBS.hGetContents hOut -- | Encrypt binary data. @@ -140,12 +119,21 @@ ) Nothing Nothing - forkIO - ( - do - LBS.hPutStr hIn input - hFlush hIn - hClose hIn - ) - output <- LBS.hGetContents hOut - return output + consumeInput LBS.hPutStr hIn input + LBS.hGetContents hOut + + +-- | Consume the input stream. +consumeInput :: + (Handle -> a -> IO ()) -- ^ The function to write the data. + -> Handle -- ^ The handle for the destination. + -> a -- ^ The source data. + -> IO ThreadId -- ^ The action returning the thread ID of the process consuming the input and writing the data. +consumeInput putter hIn input = + forkIO + ( + do + putter hIn input + hFlush hIn + hClose hIn + ) diff --git a/src/Crypto/MD5.hs b/src/Crypto/MD5.hs --- a/src/Crypto/MD5.hs +++ b/src/Crypto/MD5.hs @@ -28,11 +28,10 @@ import Data.Binary as B (encode) import Data.ByteString as BS (concat) -import Data.ByteString.Char8 (unpack) -import Data.ByteString.Lazy (ByteString, toChunks) +import Data.ByteString.Char8 as BS8 (unpack) +import Data.ByteString.Lazy as LBS (ByteString, toChunks) import Data.ByteString.Base64 as B64 (encode) import Data.Digest.Pure.MD5 (MD5Digest, md5) -import Numeric (readHex) -- | MD5 checksum information. @@ -63,4 +62,4 @@ md5ToBase64 :: MD5Digest -- ^ The MD5 digest. -> MD5Base64 -- ^ The MD5 checksum in base 64 encoding. -md5ToBase64 = unpack . B64.encode . BS.concat . toChunks . B.encode +md5ToBase64 = BS8.unpack . B64.encode . BS.concat . LBS.toChunks . B.encode diff --git a/src/Data/ByteString/Util.hs b/src/Data/ByteString/Util.hs deleted file mode 100644 --- a/src/Data/ByteString/Util.hs +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Data.ByteString.Util --- Copyright : (c) 2012-13 Brian W Bush --- License : MIT --- --- Maintainer : Brian W Bush --- Stability : Stable --- Portability : Portable --- --- | Miscellaneous functions for manipulating bytestrings. --- ------------------------------------------------------------------------------ - - -module Data.ByteString.Util ( - lbsToS -, lbsToS' -, sToBs -, sToLbs' -) where - - -import qualified Data.ByteString as BS (ByteString) -import qualified Data.ByteString.Char8 as BS8 (concat, unpack) -import qualified Data.ByteString.Lazy.Char8 as LBS8 (ByteString, pack, toChunks) -import qualified Data.Text as T (pack, unpack) -import qualified Data.Text.Encoding as T (decodeUtf8, encodeUtf8) - - --- | Convert a lazy ByteString to a String, in UTF-8. -lbsToS :: - LBS8.ByteString -- ^ The bytestring to be converted. - -> String -- ^ The string corresponding to the UTF-8 decoding of the bytestring. -lbsToS = T.unpack . T.decodeUtf8 . BS8.concat . LBS8.toChunks - - --- | Convert a lazy ByteString to a String, without UTF-8. -lbsToS' :: - LBS8.ByteString -- ^ The bytestring to be converted. - -> String -- ^ The string corresponding to the bytestring, but with no UTF-8 decoding. -lbsToS' = BS8.unpack . BS8.concat . LBS8.toChunks - - --- | Convert a String to a ByteString, in UTF-8. -sToBs :: - String -- ^ The string to be converted. - -> BS.ByteString -- ^ The bytestring corresponding to the UTF-8 encoding of the string. -sToBs = T.encodeUtf8 . T.pack - - --- | Convert a String to a lazy ByteString, without UTF-8. -sToLbs' :: - String -- ^ The string to be converted. - -> LBS8.ByteString -- ^ The bytestring corresponding to the string, but with no UTF-8 encoding. -sToLbs' = LBS8.pack diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -24,14 +24,18 @@ import Control.Monad (liftM) import Data.Data(Data(..)) import qualified Data.ByteString.Lazy as LBS (readFile, writeFile) -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import Network.Google (AccessToken, toAccessToken) +import Network.Google.Bookmarks (listBookmarks) +import Network.Google.Books (listBookshelves, listBooks) import Network.Google.Contacts (extractGnuPGNotes, listContacts) import qualified Network.Google.OAuth2 as OA2 (OAuth2Client(..), OAuth2Tokens(..), exchangeCode, formUrl, googleScopes, refreshTokens) +import Network.Google.Picasa (defaultUser, listAlbums, listPhotos) import Network.Google.Storage (StorageAcl(Private), deleteObject, getBucket, getObject, headObject, putObject) import Network.Google.Storage.Encrypted (getEncryptedObject, putEncryptedObject) import Network.Google.Storage.Sync (sync) import System.Console.CmdArgs +import Text.JSON (encode) import Text.XML.Light (ppTopElement) @@ -52,19 +56,45 @@ , refresh :: String , tokens :: FilePath } + | Bookmarks { + email :: String + , password :: String + , sms :: String + , xml :: FilePath + } | Contacts { access :: String , xml :: FilePath , notes :: Maybe FilePath , encrypt :: [String] } - | SList { + | Bookshelves { access :: String + , xml :: FilePath + } + | Books { + access :: String + , shelves :: [String] + , xml :: FilePath + } + | Albums { + access :: String + , user :: String + , xml :: FilePath + } + | Photos { + access :: String + , user :: String + , album :: [String] + , xml :: FilePath + } + | GSList { + access :: String , project :: String , bucket :: String , xml :: FilePath } - | SGet { + | GSGet { access :: String , project :: String , bucket :: String @@ -72,7 +102,7 @@ , output :: FilePath , decrypt :: Bool } - | SPut { + | GSPut { access :: String , project :: String , bucket :: String @@ -81,20 +111,20 @@ , acl :: String , encrypt :: [String] } - | SDelete { + | GSDelete { access :: String , project :: String , bucket :: String , key :: String } - | SHead { + | GSHead { access :: String , project :: String , bucket :: String , key :: String , output :: FilePath } - | SSync { + | GSSync { client :: String , secret :: String , refresh :: String @@ -113,13 +143,27 @@ -- | Definition of program. hgData :: HGData hgData = - modes [oAuth2Url, oAuth2Exchange, oAuth2Refresh, contacts, slist, sget, sput, sdelete, shead, ssync] - &= summary "hgData v0.3.1, (c) 2012-13 Brian W. Bush , MIT license." + modes + [ + oAuth2Url + , oAuth2Exchange + , oAuth2Refresh + , bookmarks + , bookshelves + , books + , contacts + , albums + , photos + , gslist + , gsget + , gsput + , gsdelete + , gshead + , gssync + ] + &= summary "hgData v0.4.1, (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 ." - ) + &= help "Command-line utility for accessing Google services and APIs. Send bug reports and feature requests to ." -- | Generate an OAuth 2.0 URL. @@ -179,6 +223,22 @@ ] +-- | List Google bookmarks. +bookmarks :: HGData +bookmarks = Bookmarks + { + email = def &= typ "ADDRESS" &= help "Google e-mail address" + , password = def &= typ "PASSWORD" &= help "Google password" + , sms = def &= typ "TOKEN" &= help "Google SMS token" + , xml = def &= opt "/dev/stdout" &= typFile &= argPos 0 + } + &= help "List Google bookmarks." + &= details + [ + "Use this command to list the bookmarks, in XML format, for a Google account." + ] + + -- | Download Google Contacts. contacts :: HGData contacts = Contacts @@ -201,15 +261,84 @@ ] +-- | List bookshelves in My Library. +bookshelves :: HGData +bookshelves = Bookshelves + { + access = def &= typ "TOKEN" &= help "OAuth 2.0 access token" + , xml = def &= opt "/dev/stdout" &= typFile &= argPos 0 + } + &= help "List bookshelves in My Library." + &= details + [ + "Use this command to list the bookshelves in My Library, in JSON format, for the authenticated user." + , "" + , "An OAuth 2.0 access token can be obtained using the \"hgdata oauth2exchange\" or \"hgdata oauth2refresh\" command. A project ID can be obtained from the \"API Access\" section of the Google API Console ." + ] + + +-- | List bookshelves in My Library. +books :: HGData +books = Books + { + access = def &= typ "TOKEN" &= help "OAuth 2.0 access token" + , xml = def &= opt "/dev/stdout" &= typFile &= argPos 0 + , shelves = def &= typ "ID" &= args + } + &= help "Lists books in My Library." + &= details + [ + "Use this command to list the books in My Library, in JSON format, for the authenticated user." + , "" + , "An OAuth 2.0 access token can be obtained using the \"hgdata oauth2exchange\" or \"hgdata oauth2refresh\" command. A project ID can be obtained from the \"API Access\" section of the Google API Console ." + ] + + +-- | List Picasa albums. +albums :: HGData +albums = Albums + { + access = def &= typ "TOKEN" &= help "OAuth 2.0 access token" + , user = def &= typ "ID" &= help "Picasa user ID" + , xml = def &= opt "/dev/stdout" &= typFile &= argPos 0 + } + &= help "List Picasa albums." + &= details + [ + "Use this command to list the albums, in XML format, for a Picasa user." + , "" + , "An OAuth 2.0 access token can be obtained using the \"hgdata oauth2exchange\" or \"hgdata oauth2refresh\" command. A project ID can be obtained from the \"API Access\" section of the Google API Console ." + ] + + +-- | List Picasa photos. +photos :: HGData +photos = Photos + { + access = def &= typ "TOKEN" &= help "OAuth 2.0 access token" + , user = def &= opt defaultUser &= typ "ID" &= help "Picasa user ID" + , xml = def &= opt "/dev/stdout" &= typFile &= argPos 0 + , album = def &= opt "" &= typ "ALBUM" &= args + } + &= help "List Picasa photos." + &= details + [ + "Use this command to list the photos, in XML format, of album(s) for a Picasa user." + , "" + , "An OAuth 2.0 access token can be obtained using the \"hgdata oauth2exchange\" or \"hgdata oauth2refresh\" command. A project ID can be obtained from the \"API Access\" section of the Google API Console ." + ] + + -- | List objects in a Google Storage bucket. -slist :: HGData -slist = SList +gslist :: HGData +gslist = GSList { access = def &= typ "TOKEN" &= help "OAuth 2.0 access token" , project = def &= typ "ID" &= help "Google API project number" , bucket = def &= typ "BUCKET" &= argPos 0 , xml = def &= opt "/dev/stdout" &= typFile &= argPos 1 } + &= name "gs-list" &= help "List objects in a Google Storage bucket." &= details [ @@ -220,8 +349,8 @@ -- | Get an object from a Google Storage bucket. -sget :: HGData -sget = SGet +gsget :: HGData +gsget = GSGet { access = def &= typ "TOKEN" &= help "OAuth 2.0 access token" , project = def &= typ "ID" &= help "Google API project number" @@ -230,6 +359,7 @@ , output = def &= opt "/dev/stdout" &= typFile &= argPos 2 , decrypt = def &= help "Attempt to decrypt the object" } + &= name "gs-get" &= help "Get an object from a Google Storage bucket." &= details [ @@ -242,8 +372,8 @@ -- | Put an object into a Google Storage bucket. -sput :: HGData -sput = SPut +gsput :: HGData +gsput = GSPut { access = def &= typ "TOKEN" &= help "OAuth 2.0 access token" , project = def &= typ "ID" &= help "Google API project number" @@ -253,6 +383,7 @@ , acl = def &= opt "private" &= typ "ACL" &= argPos 3 , encrypt = def &= typ "RECIPIENT" &= help "Recipient to encrypt for" } + &= name "gs-put" &= help "Put an object into a Google Storage bucket." &= details [ @@ -267,14 +398,15 @@ -- | Delete an object from a Google Storage bucket. -sdelete :: HGData -sdelete = SDelete +gsdelete :: HGData +gsdelete = GSDelete { access = def &= typ "TOKEN" &= help "OAuth 2.0 access token" , project = def &= typ "ID" &= help "Google API project number" , bucket = def &= typ "BUCKET" &= argPos 0 , key = def &= typ "KEY" &= argPos 1 } + &= name "gs-delete" &= help "Delete an object from a Google Storage bucket." &= details [ @@ -285,8 +417,8 @@ -- | Get object metadata from a Google Storage bucket. -shead :: HGData -shead = SHead +gshead :: HGData +gshead = GSHead { access = def &= typ "TOKEN" &= help "OAuth 2.0 access token" , project = def &= typ "ID" &= help "Google API project number" @@ -294,6 +426,7 @@ , key = def &= typ "KEY" &= argPos 1 , output = def &= opt "/dev/stdout" &= typFile &= argPos 2 } + &= name "gs-head" &= help "Get object metadata from a Google Storage bucket." &= details [ @@ -304,8 +437,8 @@ -- | Synchronize a directory with a Google Storage bucket. -ssync :: HGData -ssync = SSync +gssync :: HGData +gssync = GSSync { client = def &= typ "ID" &= help "OAuth 2.0 client ID" , secret = def &= typ "SECRET" &= help "OAuth 2.0 client secret" @@ -319,6 +452,7 @@ , md5sums = def &= help "Write file \".md5sum\" in directory" , purge = def &= help "Purge non-synchronized objects from the bucket" } + &= name "gs-sync" &= help "Synchronize a directory with a Google Storage bucket." &= details [ @@ -340,9 +474,14 @@ dispatch :: HGData -> IO () dispatch (OAuth2Url clientId) = - do - putStrLn $ OA2.formUrl (OA2.OAuth2Client clientId undefined) $ - catMaybes $ map (flip lookup OA2.googleScopes) ["Google Cloud Storage", "Contacts"] + putStrLn $ OA2.formUrl (OA2.OAuth2Client clientId undefined) $ + mapMaybe (`lookup` OA2.googleScopes) + [ + "Google Cloud Storage" + , "Contacts" + , "Picasa Web" + , "Google Books" + ] dispatch (OAuth2Exchange clientId clientSecret exchangeCode tokenFile) = do @@ -354,6 +493,11 @@ tokens <- OA2.refreshTokens (OA2.OAuth2Client clientId clientSecret) (OA2.OAuth2Tokens undefined refreshToken undefined undefined) writeFile tokenFile $ show tokens +dispatch (Bookmarks email password sms xmlOutput) = + do + result <- listBookmarks email password sms + writeFile xmlOutput $ ppTopElement result + dispatch (Contacts accessToken xmlOutput passwordOutput recipients) = do contacts <- listContacts $ toAccessToken accessToken @@ -368,35 +512,60 @@ ) passwordOutput -dispatch (SList accessToken projectId bucket xmlOutput) = +dispatch (Bookshelves accessToken xmlOutput) = do + result <- listBookshelves (toAccessToken accessToken) + writeFile xmlOutput $ encode result + +dispatch (Books accessToken shelves xmlOutput) = + do + result <- listBooks (toAccessToken accessToken) shelves + writeFile xmlOutput $ encode result + +dispatch (Albums accessToken user xmlOutput) = + do + let + user' = if user == "" then defaultUser else user + result <- listAlbums (toAccessToken accessToken) user' + writeFile xmlOutput $ ppTopElement result + +dispatch (Photos accessToken user album xmlOutput) = + do + let + user' = if user == "" then defaultUser else user + album' = if not (null album) && head album == "" then [] else album + result <- listPhotos (toAccessToken accessToken) user' album' + writeFile xmlOutput $ ppTopElement result + +dispatch (GSList accessToken projectId bucket xmlOutput) = + do result <- getBucket projectId bucket (toAccessToken accessToken) writeFile xmlOutput $ ppTopElement result -dispatch (SGet accessToken projectId bucket key output decrypt) = +dispatch (GSGet accessToken projectId bucket key output decrypt) = do let getter = if decrypt then getEncryptedObject else getObject result <- getter projectId bucket key (toAccessToken accessToken) LBS.writeFile output result -dispatch (SPut accessToken projectId bucket key input acl recipients) = +dispatch (GSPut accessToken projectId bucket key input acl recipients) = do let putter = if null recipients then putObject else putEncryptedObject recipients bytes <- LBS.readFile input putter projectId (read acl) bucket key Nothing bytes Nothing (toAccessToken accessToken) return () -dispatch (SDelete accessToken projectId bucket key) = +dispatch (GSDelete accessToken projectId bucket key) = do result <- deleteObject projectId bucket key (toAccessToken accessToken) return () -dispatch (SHead accessToken projectId bucket key output) = +dispatch (GSHead accessToken projectId bucket key output) = do result <- headObject projectId bucket key (toAccessToken accessToken) writeFile output $ show result -dispatch (SSync clientId clientSecret refreshToken projectId bucket directory acl recipients exclusionFile md5sums purge) = +dispatch (GSSync clientId clientSecret refreshToken projectId bucket directory acl recipients exclusionFile md5sums purge) = do let acl' = if acl == "" then Private else read acl diff --git a/src/Network/Google.hs b/src/Network/Google.hs --- a/src/Network/Google.hs +++ b/src/Network/Google.hs @@ -27,6 +27,7 @@ , appendQuery , doManagedRequest , doRequest +, makeHeaderName , makeProjectRequest , makeRequest , makeRequestValue @@ -35,15 +36,16 @@ import Control.Exception (finally) import Control.Monad.Trans.Resource (ResourceT, runResourceT) -import Data.List (intersperse) +import Data.List (intercalate) import Data.Maybe (fromJust) -import Data.ByteString.Util (lbsToS) import Data.ByteString as BS (ByteString) -import Data.ByteString.Char8 as BS8 (ByteString, append, pack, unpack) +import Data.ByteString.Char8 as BS8 (ByteString, append, pack) import Data.ByteString.Lazy.Char8 as LBS8 (ByteString) +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 Text.JSON (JSValue, Result(Ok), decode) import Text.XML.Light (Element, parseXMLDoc) @@ -69,6 +71,7 @@ -> (String, String) -- ^ The host and path for the request. -> Request m -- ^ The HTTP request. makeRequest accessToken (apiName, apiVersion) method (host, path) = + -- TODO: In principle, we should UTF-8 encode the bytestrings packed below. def { method = BS8.pack method , secure = True @@ -132,7 +135,7 @@ doManagedRequest manager request = do result <- doManagedRequest manager request - return $ lbsToS result + return $ toString result instance DoRequest [(String, String)] where @@ -152,14 +155,24 @@ instance DoRequest Element where doManagedRequest manager request = do - result <- (doManagedRequest manager request :: IO String) + result <- doManagedRequest manager request :: IO String return $ fromJust $ parseXMLDoc result +instance DoRequest JSValue where + doManagedRequest manager request = + do + result <- doManagedRequest manager request :: IO String + let + Ok result' = decode result + return result' + + -- | Prepare a string for inclusion in a request. makeRequestValue :: String -- ^ The string. -> BS8.ByteString -- ^ The prepared string. +-- TODO: In principle, we should UTF-8 encode the bytestrings packed below. makeRequestValue = BS8.pack @@ -167,6 +180,7 @@ makeHeaderName :: String -- ^ The name. -> CI.CI BS8.ByteString -- ^ The prepared name. +-- TODO: In principle, we should UTF-8 encode the bytestrings packed below. makeHeaderName = CI.mk . BS8.pack @@ -174,6 +188,7 @@ makeHeaderValue :: String -- ^ The value. -> BS8.ByteString -- ^ The prepared value. +-- TODO: In principle, we should UTF-8 encode the bytestrings packed below. makeHeaderValue = BS8.pack @@ -213,9 +228,10 @@ makeParameter :: (String, String) -> String makeParameter (k, v) = k ++ "=" ++ urlEncode v query' :: String - query' = concat $ intersperse "&" $ map makeParameter query + query' = intercalate "&" $ map makeParameter query in request { - queryString = BS8.pack $ "?" ++ query' + -- TODO: In principle, we should UTF-8 encode the bytestrings packed below. + queryString = BS8.pack $ '?' : query' } diff --git a/src/Network/Google/Bookmarks.hs b/src/Network/Google/Bookmarks.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Bookmarks.hs @@ -0,0 +1,141 @@ +----------------------------------------------------------------------------- +-- +-- Module : Network.Google.Bookmarks +-- Copyright : (c) 2013 Brian W Bush +-- License : MIT +-- +-- Maintainer : Brian W Bush +-- Stability : Stable +-- Portability : Portable +-- +-- | Functions for accessing the unofficial Google Bookmarks API, see . +-- +----------------------------------------------------------------------------- + + +module Network.Google.Bookmarks ( +-- * Types + EMail +, Password +, SmsToken +-- * Functions +, listBookmarks +) where + + +import Control.Monad (liftM) +import Data.ByteString.Char8 as BS8 (ByteString, pack, unpack) +import Data.ByteString.Lazy.Char8 as LBS8 (ByteString, pack, unpack) +import Data.ByteString.Lazy.UTF8 (fromString, toString) +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 Text.XML.Light (Element(..), QName(..), blank_name, filterElement, findAttr, parseXMLDoc) + + +-- | Google e-mail address. +type EMail = String + + +-- | Google password. +type Password = String + + +-- | SMS authentication token. +type SmsToken = String + + +-- | List the bookmarks, see . +listBookmarks :: + EMail -- ^ The Google e-mail address. + -> Password -- ^ The Google password. + -> SmsToken -- ^ The SMS authentication token. + -> IO Element -- ^ The action returning the bookmarks in XML format. +listBookmarks email password smsToken = + do + now <- getCurrentTime + withManager $ \manager -> do + requestGet1 <- parseUrl $ "https://accounts.google.com/Login?continue=" ++ listingUrl ++ "&hl=en&service=bookmarks&authuser=0" + 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 + requestPost1 = + cookieInserter cookieJarGet1 $ + (accountsPostRequest "/ServiceLoginAuth") { + requestBody = RequestBodyBS $ BS8.pack $ + "continue=" ++ listingUrl + ++ "&service=bookmarks" + ++ "&dsh=" ++ extractValue "dsh" bodyGet1 + ++ "&GALX=" ++ extractValue "GALX" bodyGet1 + ++ "&bgresponse=js_disabled" + ++ "&Email=" ++ encode email + ++ "&Passwd=" ++ encode password + ++ "&PersistentCookie=yes" + , redirectCount = 0 + , checkStatus = \_ _ -> Nothing + } + responsePost1 <- httpLbs requestPost1 manager + let + (cookieJarPost1, _) = updateCookieJar responsePost1 requestPost1 now cookieJarGet1 + requestPost2 = + cookieInserter cookieJarPost1 $ + (accountsPostRequest "/SmsAuth") { + queryString = BS8.pack $ "?continue=" ++ listingUrl ++ "&service=bookmarks" + , requestBody = RequestBodyBS $ BS8.pack $ + "continue=" ++ listingUrl + ++ "&service=bookmarks" + ++ "&exp=smsauthnojs" + ++ "&smsUserPin=" ++ encode smsToken + ++ "&PersistentCookie=yes" + , redirectCount = 0 + , checkStatus = \_ _ -> Nothing + } + responsePost2 <- httpLbs requestPost2 manager + let + bodyPost2 = responseXml responsePost2 + (cookieJarPost2, _) = updateCookieJar responsePost2 requestPost2 now cookieJarPost1 + requestPost3 = + cookieInserter cookieJarPost2 $ + (accountsPostRequest "/ServiceLoginAuth") { + queryString = BS8.pack $ "?continue=" ++ listingUrl + , requestBody = RequestBodyBS $ BS8.pack $ + "continue=" ++ listingUrl + ++ "&smsToken=" ++ extractValue "smsToken" bodyPost2 + ++ "&GALX=" ++ extractValue "GALX" bodyGet1 + ++ "&bgresponse=js_disabled" + } + responsePost3 <- httpLbs requestPost3 manager + return $ responseXml responsePost3 + + +accountsPostRequest :: String -> Request m +accountsPostRequest path = + appendHeaders [("Content-Type", "application/x-www-form-urlencoded")] $ + def { + method = BS8.pack "POST" + , secure = True + , host = BS8.pack "accounts.google.com" + , port = 443 + , path = BS8.pack path + } + + +listingUrl :: String +listingUrl = "https%3A%2F%2Fwww.google.com%2Fbookmarks%2F%3Foutput%3Dxml%26num%3D100000" + + +extractValue :: String -> Element -> String +extractValue value root = + fromJust $ do + let + inputElement = blank_name {qName = "input"} + nameAttribute = blank_name {qName = "name"} + valueAttribute = blank_name {qName = "value"} + filter element = elName element == inputElement && findAttr nameAttribute element == Just value + element <- filterElement filter root + findAttr valueAttribute element diff --git a/src/Network/Google/Books.hs b/src/Network/Google/Books.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Books.hs @@ -0,0 +1,106 @@ +----------------------------------------------------------------------------- +-- +-- Module : Network.Google.Books +-- Copyright : (c) 2012-13 Brian W Bush +-- License : MIT +-- +-- Maintainer : Brian W Bush +-- Stability : Stable +-- Portability : +-- +-- | Functions for the Google Books API, see . +-- +----------------------------------------------------------------------------- + + +module Network.Google.Books ( +-- * Types + ShelfId +-- * Functions +, listBooks +, listBookshelves +) where + + +import Network.Google (AccessToken, doRequest, makeRequest) +import Network.HTTP.Conduit (Request) +import Text.JSON (JSObject, JSValue(..), Result(Ok), decode, valFromObj) + + +-- | The host for API access. +booksHost :: String +booksHost = "www.googleapis.com" + + +-- | The API version used here. +booksApi :: (String, String) +booksApi = ("Gdata-version", "2") + + +-- | Bookshelf ID. +type ShelfId = String + + +-- | List the bookshelves, see . +listBookshelves :: + AccessToken -- ^ The OAuth 2.0 access token. + -> IO JSValue -- ^ The action returning the bookshelves' metadata in JSON format. +listBookshelves accessToken = + doRequest $ booksRequest accessToken Nothing + + +-- | List the bookshelf IDs, see . +listBookshelfIds :: + AccessToken -- ^ The OAuth 2.0 access token. + -> IO [String] -- ^ The action returning list of bookshelf IDs. +listBookshelfIds accessToken = + do + JSObject result <- listBookshelves accessToken + let + extractId :: JSValue -> String + extractId (JSObject x) = + let + y :: Rational + Ok (JSRational _ y) = valFromObj "id" x + in + show (round y :: Int) + items :: [JSValue] + Ok (JSArray items) = valFromObj "items" result + return $ map extractId items + + +-- | List the books, see . +listBooks :: + AccessToken -- ^ The OAuth 2.0 access token. + -> [ShelfId] -- ^ The bookshelf IDs. + -> IO JSValue -- ^ The action returning the books' metadata in JSON format. +listBooks accessToken shelves = + do + shelves' <- + if null shelves + then listBookshelfIds accessToken + else return shelves + results <- mapM (listShelfBooks accessToken) shelves' + return $ JSArray results + + +-- | List the books in a shelf, see . +listShelfBooks :: + AccessToken -- ^ The OAuth 2.0 access token. + -> ShelfId -- ^ The bookshelf ID. + -> IO JSValue -- ^ The action returning the books' metadata in JSON format. +listShelfBooks accessToken shelf = + doRequest $ booksRequest accessToken (Just shelf) + + +-- | Make an HTTP request for Google Books. +booksRequest :: + AccessToken -- ^ The OAuth 2.0 access token. + -> Maybe ShelfId -- ^ The bookshelf ID. + -> Request m -- ^ The request. +booksRequest accessToken shelf = + makeRequest accessToken booksApi "GET" + ( + booksHost + , "/books/v1/mylibrary/bookshelves" ++ maybe "" (\x -> "/" ++ x ++ "/volumes") shelf + ) 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 @@ -6,7 +6,7 @@ -- -- Maintainer : Brian W Bush -- Stability : Stable --- Portability : Portable. +-- Portability : Portable -- -- | Functions for accessing the Google Contacts API, see . -- @@ -22,9 +22,8 @@ import Control.Monad ((<=<), (>>), liftM) import Crypto.GnuPG (Recipient, decrypt, encrypt) -import Data.ByteString.Util (lbsToS) import Data.List (stripPrefix) -import Data.Maybe (catMaybes, fromJust) +import Data.Maybe (fromJust, 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) @@ -74,7 +73,7 @@ replacePassword (t, o, p) = do p' <- decrypt p - return $ unlines $ ["-----", "", t, o, "", p'] + return $ unlines ["-----", "", t, o, "", p'] passwords' <- mapM replacePassword passwords (if null recipients then return . id else encrypt recipients) $ unlines passwords' @@ -103,4 +102,4 @@ p <- getPGP x return (t, o, p) in - catMaybes $ map getEntry $ elChildren xml + mapMaybe getEntry $ elChildren xml 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 @@ -28,9 +28,9 @@ import Data.ByteString.Char8 as BS8 (ByteString, pack) -import Data.ByteString.Util (lbsToS) -import Data.CaseInsensitive as CI (CI(..), mk) +import Data.ByteString.Lazy.UTF8 (toString) import Data.List (intercalate) +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) @@ -81,7 +81,7 @@ , ("Chrome Web Store", "https://www.googleapis.com/auth/chromewebstore.readonly") , ("Documents List", "https://docs.google.com/feeds/") , ("Google Drive", "https://www.googleapis.com/auth/drive") - , ("Google Drive", "Files https://www.googleapis.com/auth/drive.file") + , ("Google Drive Files", "Files https://www.googleapis.com/auth/drive.file") , ("Gmail", "https://mail.google.com/mail/feed/atom") , ("Google+", "https://www.googleapis.com/auth/plus.me") , ("Groups Provisioning", "https://apps-apis.google.com/a/feeds/groups/") @@ -117,7 +117,7 @@ ++ "?response_type=code" ++ "&client_id=" ++ clientId client ++ "&redirect_uri=" ++ redirectUri - ++ "&scope=" ++ (intercalate "+" $ map urlEncode scopes) + ++ "&scope=" ++ intercalate "+" (map urlEncode scopes) -- | Exchange an authorization code for tokens, see . @@ -129,23 +129,24 @@ do result <- doOAuth2 client "authorization_code" ("&redirect_uri=" ++ redirectUri ++ "&code=" ++ code) let - (Ok result') = decodeTokens result + (Ok result') = decodeTokens Nothing result return result' --- | Parse OAuth 2.0 tokens. +-- | Refresh OAuth 2.0 tokens from JSON data. decodeTokens :: - JSObject JSValue -- ^ The JSON value. - -> Result OAuth2Tokens -- ^ The OAuth 2.0 tokens. -decodeTokens value = + Maybe OAuth2Tokens -- ^ The original tokens, if any. + -> JSObject JSValue -- ^ The JSON value. + -> Result OAuth2Tokens -- ^ The refreshed tokens. +decodeTokens tokens value = do let (!) = flip valFromObj + -- TODO: There should be a more straightforward way to do this. expiresIn' :: Rational (Ok (JSRational _ expiresIn')) = valFromObj "expires_in" value accessToken <- value ! "access_token" - refreshToken <- value ! "refresh_token" - -- expiresIn <- value ! "expires_in" + refreshToken <- maybe (value ! "refresh_token") (Ok . refreshToken) tokens tokenType <- value ! "token_type" return OAuth2Tokens { @@ -165,39 +166,20 @@ do result <- doOAuth2 client "refresh_token" ("&refresh_token=" ++ refreshToken tokens) let - (Ok result') = decodeTokens' tokens result + (Ok result') = decodeTokens (Just tokens) result return result' --- | Refresh OAuth 2.0 tokens from JSON refresh data. -decodeTokens' :: - OAuth2Tokens -- ^ The original tokens. - -> JSObject JSValue -- ^ The JSON value. - -> Result OAuth2Tokens -- ^ The refreshed tokens. -decodeTokens' tokens value = - do - let - (!) = flip valFromObj - expiresIn' :: Rational - (Ok (JSRational _ expiresIn')) = valFromObj "expires_in" value - accessToken <- value ! "access_token" - -- expiresIn <- value ! "expires_in" - tokenType <- value ! "token_type" - return tokens - { - accessToken = accessToken - , expiresIn = expiresIn' - , tokenType = tokenType - } - - -- | Peform OAuth 2.0 authentication, see . -doOAuth2 :: OAuth2Client -> String -> String -> IO (JSObject JSValue) +doOAuth2 :: + OAuth2Client -- ^ The client. + -> String -- ^ The grant type. + -> String -- ^ The + -> IO (JSObject JSValue) -- ^ The action returing the JSON response from making the request. doOAuth2 client grantType extraBody = do let - makeHeaderName :: String -> CI.CI BS8.ByteString - makeHeaderName = CI.mk . BS8.pack + -- TODO: In principle, we should UTF-8 encode the bytestrings packed below. request = def { method = BS8.pack "POST" @@ -216,8 +198,8 @@ } response <- withManager $ httpLbs request let - (Ok result) = decode . lbsToS $ responseBody response - return $ result + (Ok result) = decode . toString $ responseBody response + return result -- | Validate OAuth 2.0 tokens, see . @@ -227,8 +209,6 @@ validateTokens tokens = do let - makeHeaderName :: String -> CI.CI BS8.ByteString - makeHeaderName = CI.mk . BS8.pack request = def { method = BS8.pack "GET" @@ -240,7 +220,7 @@ } response <- withManager $ httpLbs request let - (Ok result) = decode . lbsToS $ responseBody response + (Ok result) = decode . toString $ responseBody response expiresIn' :: Rational (Ok (JSRational _ expiresIn')) = valFromObj "expires_in" result return expiresIn' diff --git a/src/Network/Google/Picasa.hs b/src/Network/Google/Picasa.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Picasa.hs @@ -0,0 +1,120 @@ +----------------------------------------------------------------------------- +-- +-- Module : Network.Google.Picasa +-- Copyright : (c) 2013 Brian W Bush +-- License : MIT +-- +-- Maintainer : Brian W Bush +-- Stability : Stable +-- Portability : Portable +-- +-- | Functions for accessing the Picasa API, see . +-- +----------------------------------------------------------------------------- + + +module Network.Google.Picasa ( +-- * Types + UserId +, defaultUser +, AlbumId +-- * Functions +, listAlbums +, listPhotos +) where + + +import Control.Monad (liftM) +import Data.Maybe (mapMaybe) +import Network.Google (AccessToken, ProjectId, doRequest, makeRequest) +import Network.HTTP.Conduit (Request) +import Text.XML.Light (Element(elContent), QName(..), filterChildrenName, findChild, strContent) + + +-- | The host for API access. +picasaHost :: String +picasaHost = "picasaweb.google.com" + + +-- | The API version used here. +picasaApi :: (String, String) +picasaApi = ("Gdata-version", "2") + + +-- | Picasa user ID. +type UserId = String + + +-- | Default Picasa user ID +defaultUser :: UserId +defaultUser = "default" + + +-- | Picasa album ID. +type AlbumId = String + + +-- | List the albums, see . +listAlbums :: + AccessToken -- ^ The OAuth 2.0 access token. + -> UserId -- ^ The user ID for the photos. + -> IO Element -- ^ The action returning the albums metadata in XML format. +listAlbums accessToken userId = + doRequest $ picasaFeedRequest accessToken userId Nothing + + +-- | Extract the album IDs from the list of albums. +extractAlbumIds :: + Element -- ^ The root element of the list of albums. + -> [AlbumId] -- ^ The list of album IDs. +extractAlbumIds root = + let + idQname = QName {qName = "id", qURI = Just "http://schemas.google.com/photos/2007", qPrefix = Just "gphoto"} + entries :: [Element] + entries = filterChildrenName ((== "entry") . qName) root + extractAlbumId :: Element -> Maybe String + extractAlbumId = liftM strContent . findChild idQname + in + mapMaybe extractAlbumId entries + + +-- | List the photos in albums, see . +listPhotos :: + AccessToken -- ^ The OAuth 2.0 access token. + -> UserId -- ^ The user ID for the photos. + -> [AlbumId] -- ^ The album ID for the photos, or all photos if null. + -> IO Element -- ^ The action returning the photo metadata in XML format. +listPhotos accessToken userId albumIds = + do + albumIds' <- + if null albumIds + then liftM extractAlbumIds $ listAlbums accessToken userId + else return albumIds + results <- mapM (listAlbumPhotos accessToken userId) albumIds' + let + root = head results + return $ root {elContent = concatMap elContent results} + + +-- | List the photos in an album, see . +listAlbumPhotos :: + AccessToken -- ^ The OAuth 2.0 access token. + -> UserId -- ^ The user ID for the photos. + -> AlbumId -- ^ The album ID for the photos. + -> IO Element -- ^ The action returning the contacts in XML format. +listAlbumPhotos accessToken userId albumId = + doRequest $ picasaFeedRequest accessToken userId (Just albumId) + + +-- | Make an HTTP request for a Picasa feed. +picasaFeedRequest :: + AccessToken -- ^ The OAuth 2.0 access token. + -> UserId -- ^ The user ID for the photos. + -> Maybe AlbumId -- ^ The album ID for the photos. + -> Request m -- ^ The request. +picasaFeedRequest accessToken userId albumId = + makeRequest accessToken picasaApi "GET" + ( + picasaHost + , "/data/feed/api/user/" ++ userId ++ maybe "" ("/albumid/" ++) albumId + ) 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 @@ -45,9 +45,9 @@ import Control.Monad.Trans.Resource (ResourceT) import Crypto.MD5 (MD5Info, md5Base64) import Data.ByteString.Char8 (unpack) +import Data.ByteString.UTF8 (fromString) import Data.ByteString.Lazy (ByteString) -import Data.ByteString.Util (sToBs) -import Data.List (intersperse, stripPrefix) +import Data.List (intercalate, stripPrefix) import Data.List.Util (separate) import Data.Maybe (fromJust, isNothing, maybe) import Network.Google (AccessToken, ProjectId, appendBody, appendHeaders, appendQuery, doManagedRequest, doRequest, makeProjectRequest) @@ -118,7 +118,8 @@ makePath :: String -- ^ The unencoded path. -> String -- ^ The URL-encoded path. -makePath = ('/' :) . concat . intersperse "/" . map (urlEncode . unpack . sToBs) . separate '/' +-- 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 '/' -- | List all of the buckets in a specified project. This performs the \"GET Service\" request, see . @@ -222,7 +223,7 @@ results <- getBucketImpl' doer Nothing projectId bucket accessToken let root = head results - return $ root {elContent = concat $ map elContent results} + return $ root {elContent = concatMap elContent results} -- | Lists the objects that are in a bucket. This performs the \"GET Bucket\" request, see . @@ -317,7 +318,7 @@ getObjectImpl doer projectId bucket key accessToken = do let - request = (makeProjectRequest projectId accessToken storageApi "GET" (makeHost bucket, makePath key)) + request = makeProjectRequest projectId accessToken storageApi "GET" (makeHost bucket, makePath key) doer request @@ -415,7 +416,7 @@ headObjectImpl doer projectId bucket key accessToken = do let - request = (makeProjectRequest projectId accessToken storageApi "HEAD" (makeHost bucket, makePath key)) + request = makeProjectRequest projectId accessToken storageApi "HEAD" (makeHost bucket, makePath key) doer request @@ -451,5 +452,5 @@ deleteObjectImpl doer projectId bucket key accessToken = do let - request = (makeProjectRequest projectId accessToken storageApi "DELETE" (makeHost bucket, makePath key)) + request = makeProjectRequest projectId accessToken storageApi "DELETE" (makeHost bucket, makePath key) doer request diff --git a/src/Network/Google/Storage/Encrypted.hs b/src/Network/Google/Storage/Encrypted.hs --- a/src/Network/Google/Storage/Encrypted.hs +++ b/src/Network/Google/Storage/Encrypted.hs @@ -62,7 +62,7 @@ getEncryptedObjectImpl getter projectId bucket key accessToken = do bytes <- getter projectId bucket key accessToken - decryptLbs $ bytes + decryptLbs bytes -- | Encrypt an object and upload it. 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 @@ -23,13 +23,13 @@ import Control.Exception (SomeException, finally, handle) -import Control.Monad (filterM, liftM) +import Control.Monad (filterM, liftM, when) import Crypto.GnuPG (Recipient) import Crypto.MD5 (MD5Info, md5Base64) -import qualified Data.ByteString.Lazy as LBS(ByteString, readFile) +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.Maybe (catMaybes, fromJust) +import Data.Maybe (fromJust, mapMaybe) import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Time.Format (parseTime) @@ -145,13 +145,12 @@ makeExcluder :: [RegexExclusion] -- ^ The regular expressions. -> Excluder -- ^ The function for excluding objects. -makeExcluder exclusions = - \(ObjectMetadata candidate _ _ _) -> - let - match :: String -> Bool - match exclusion = candidate =~ exclusion - in - not $ or $ map match exclusions +makeExcluder exclusions (ObjectMetadata candidate _ _ _) = + let + match :: String -> Bool + match exclusion = candidate =~ exclusion + in + not $ any match exclusions -- | Synchronize a filesystem directory with a Google Storage bucket. @@ -172,7 +171,7 @@ putStr "LOCAL " hFlush stdout local <- walkDirectories directory - putStrLn $ show $ length local + print $ length local now <- getCurrentTime tokenClock@(_, tokens') <- checkExpiration client (addUTCTime (-60) now, tokens) putStr "REMOTE " @@ -180,7 +179,7 @@ remote' <- lister $ toAccessToken $ accessToken tokens' let remote = parseMetadata remote' - putStrLn $ show $ length remote + print $ length remote let tolerance = 300 sameKey :: ObjectMetadata -> ObjectMetadata -> Bool @@ -188,31 +187,30 @@ 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 " + earlierTime (ObjectMetadata key _ _ time) (ObjectMetadata key' eTag' _ time') = key == key' && time > addUTCTime tolerance time' + putStr "EXCLUDED " hFlush stdout let local' = filter excluder local - putStrLn $ show (length local - length local') - putStr $ "PUTS " + print $ length local - length local' + putStr "PUTS " hFlush stdout let changedObjects = deleteFirstsBy (if byETag then sameETag else earlierTime) local' remote - putStrLn $ show (length changedObjects) - putStr $ "DELETES " + print $ length changedObjects + putStr "DELETES " hFlush stdout let deletedObjects = deleteFirstsBy sameKey remote local' - putStrLn $ show (length deletedObjects) + print $ length deletedObjects tokenClock' <- walkPutter client tokenClock directory putter changedObjects tokenClock'' <- if purge then walkDeleter client tokenClock' deleter deletedObjects else return tokenClock' - if md5sums - then writeFile (directory ++ "/.md5sum") $ unlines $ map (\x -> (fst . eTag) x ++ " ./" ++ key x) local' - else return () + when md5sums $ + writeFile (directory ++ "/.md5sum") $ unlines $ map (\x -> (fst . eTag) x ++ " ./" ++ key x) local' -- | Put a list of objects. @@ -299,7 +297,7 @@ lastModified <- finder "LastModified" element return $ ObjectMetadata key (tail . init $ eTag, undefined) (read size) (fromJust $ parseTime defaultTimeLocale "%FT%T%QZ" lastModified) in - catMaybes $ map makeMetadata $ filterChildrenName (("Contents" ==) . qName) root + mapMaybe makeMetadata $ filterChildrenName (("Contents" ==) . qName) root -- | Gather file metadata from the file system. @@ -344,8 +342,7 @@ let !x = fst eTag let !y = snd eTag return $ ObjectMetadata key eTag size lastTime - files <- liftM (map ((y ++ [pathSeparator]) ++)) - $ liftM ( \\ [".", ".."]) + files <- liftM (map ((y ++ [pathSeparator]) ++) . ( \\ [".", ".."])) $ getDirectoryContents (directory ++ y) y' <- filterM (doesDirectoryExist . (directory ++)) files x' <- mapM makeMetadata $ files \\ y'