handa-gdata 0.3.1 → 0.4.1
raw patch · 14 files changed
+704/−226 lines, 14 filesdep +utf8-stringdep −textPVP ok
version bump matches the API change (PVP)
Dependencies added: utf8-string
Dependencies removed: text
API changes (from Hackage documentation)
+ Network.Google: instance DoRequest JSValue
+ Network.Google: makeHeaderName :: String -> CI ByteString
+ Network.Google.Bookmarks: listBookmarks :: EMail -> Password -> SmsToken -> IO Element
+ Network.Google.Bookmarks: type EMail = String
+ Network.Google.Bookmarks: type Password = String
+ Network.Google.Bookmarks: type SmsToken = String
+ Network.Google.Books: listBooks :: AccessToken -> [ShelfId] -> IO JSValue
+ Network.Google.Books: listBookshelves :: AccessToken -> IO JSValue
+ Network.Google.Books: type ShelfId = String
+ Network.Google.Picasa: defaultUser :: UserId
+ Network.Google.Picasa: listAlbums :: AccessToken -> UserId -> IO Element
+ Network.Google.Picasa: listPhotos :: AccessToken -> UserId -> [AlbumId] -> IO Element
+ Network.Google.Picasa: type AlbumId = String
+ Network.Google.Picasa: type UserId = String
Files
- handa-gdata.cabal +25/−7
- src/Crypto/GnuPG.hs +26/−38
- src/Crypto/MD5.hs +3/−4
- src/Data/ByteString/Util.hs +0/−56
- src/Main.hs +203/−34
- src/Network/Google.hs +23/−7
- src/Network/Google/Bookmarks.hs +141/−0
- src/Network/Google/Books.hs +106/−0
- src/Network/Google/Contacts.hs +4/−5
- src/Network/Google/OAuth2.hs +22/−42
- src/Network/Google/Picasa.hs +120/−0
- src/Network/Google/Storage.hs +8/−7
- src/Network/Google/Storage/Encrypted.hs +1/−1
- src/Network/Google/Storage/Sync.hs +22/−25
handa-gdata.cabal view
@@ -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 <b.w.bush@acm.org> 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
src/Crypto/GnuPG.hs view
@@ -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+ )
src/Crypto/MD5.hs view
@@ -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
− src/Data/ByteString/Util.hs
@@ -1,56 +0,0 @@------------------------------------------------------------------------------------ Module : Data.ByteString.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 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
src/Main.hs view
@@ -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 <b.w.bush@acm.org>, 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 <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>."- )+ &= 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>." -- | 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 <https://code.google.com/apis/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 <https://code.google.com/apis/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 <https://code.google.com/apis/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 <https://code.google.com/apis/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
src/Network/Google.hs view
@@ -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' }
+ src/Network/Google/Bookmarks.hs view
@@ -0,0 +1,141 @@+-----------------------------------------------------------------------------+--+-- Module : Network.Google.Bookmarks+-- Copyright : (c) 2013 Brian W Bush+-- License : MIT+--+-- Maintainer : Brian W Bush <b.w.bush@acm.org>+-- Stability : Stable+-- Portability : Portable+--+-- | Functions for accessing the unofficial Google Bookmarks API, see <http://www.mmartins.com/mmartins/googlebookmarksapi/>.+--+-----------------------------------------------------------------------------+++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 <http://www.mmartins.com/mmartins/googlebookmarksapi/>.+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
+ src/Network/Google/Books.hs view
@@ -0,0 +1,106 @@+-----------------------------------------------------------------------------+--+-- Module : Network.Google.Books+-- Copyright : (c) 2012-13 Brian W Bush+-- License : MIT+--+-- Maintainer : Brian W Bush <b.w.bush@acm.org>+-- Stability : Stable+-- Portability :+--+-- | Functions for the Google Books API, see <https://developers.google.com/books/docs/v1/using#WorkingMyBookshelves>.+--+-----------------------------------------------------------------------------+++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 <https://developers.google.com/books/docs/v1/using#RetrievingMyBookshelves>.+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 <https://developers.google.com/books/docs/v1/using#RetrievingMyBookshelves>.+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 <https://developers.google.com/books/docs/v1/using#RetrievingMyBookshelfVolumes>.+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 <https://developers.google.com/books/docs/v1/using#RetrievingMyBookshelfVolumes>.+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+ )
src/Network/Google/Contacts.hs view
@@ -6,7 +6,7 @@ -- -- Maintainer : Brian W Bush <b.w.bush@acm.org> -- Stability : Stable--- Portability : Portable.+-- Portability : Portable -- -- | Functions for accessing the Google Contacts API, see <https://developers.google.com/google-apps/contacts/v3/>. --@@ -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
src/Network/Google/OAuth2.hs view
@@ -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 <https://developers.google.com/accounts/docs/OAuth2InstalledApp#handlingtheresponse>.@@ -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 <https://developers.google.com/accounts/docs/OAuth2InstalledApp#handlingtheresponse>.-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 <https://developers.google.com/accounts/docs/OAuth2Login#validatingtoken>.@@ -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'
+ src/Network/Google/Picasa.hs view
@@ -0,0 +1,120 @@+-----------------------------------------------------------------------------+--+-- Module : Network.Google.Picasa+-- Copyright : (c) 2013 Brian W Bush+-- License : MIT+--+-- Maintainer : Brian W Bush <b.w.bush@acm.org>+-- Stability : Stable+-- Portability : Portable+--+-- | Functions for accessing the Picasa API, see <https://developers.google.com/picasa-web/docs/2.0/developers_guide_protocol>.+--+-----------------------------------------------------------------------------+++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 <https://developers.google.com/picasa-web/docs/2.0/developers_guide_protocol#ListAlbums>.+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 <https://developers.google.com/picasa-web/docs/2.0/developers_guide_protocol#ListAlbumPhotos>.+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 <https://developers.google.com/picasa-web/docs/2.0/developers_guide_protocol#ListAlbumPhotos>.+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+ )
src/Network/Google/Storage.hs view
@@ -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 <https://developers.google.com/storage/docs/reference-methods#getservice>.@@ -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 <https://developers.google.com/storage/docs/reference-methods#getbucket>.@@ -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
src/Network/Google/Storage/Encrypted.hs view
@@ -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.
src/Network/Google/Storage/Sync.hs view
@@ -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'