handa-gdata (empty) → 0.3.1
raw patch · 14 files changed
+2323/−0 lines, 14 filesdep +HTTPdep +basedep +base64-bytestringsetup-changed
Dependencies added: HTTP, base, base64-bytestring, binary, bytestring, case-insensitive, cmdargs, directory, filepath, http-conduit, json, old-locale, process, pureMD5, regex-posix, resourcet, text, time, unix, xml
Files
- LICENSE +8/−0
- Setup.lhs +6/−0
- handa-gdata.cabal +86/−0
- src/Crypto/GnuPG.hs +151/−0
- src/Crypto/MD5.hs +66/−0
- src/Data/ByteString/Util.hs +56/−0
- src/Data/List/Util.hs +34/−0
- src/Main.hs +422/−0
- src/Network/Google.hs +221/−0
- src/Network/Google/Contacts.hs +106/−0
- src/Network/Google/OAuth2.hs +246/−0
- src/Network/Google/Storage.hs +455/−0
- src/Network/Google/Storage/Encrypted.hs +113/−0
- src/Network/Google/Storage/Sync.hs +353/−0
+ LICENSE view
@@ -0,0 +1,8 @@+HGData+Copyright (c) 2012-13 Brian W Bush++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ handa-gdata.cabal view
@@ -0,0 +1,86 @@+name: handa-gdata+version: 0.3.1+cabal-version: >=1.6+build-type: Simple+license: MIT+license-file: LICENSE+copyright: (c) 2012-13 Brian W Bush+maintainer: Brian W Bush <b.w.bush@acm.org>+stability: Stable+homepage: http://code.google.com/p/hgdata+package-url: http://code.google.com/p/hgdata/downloads/list+bug-reports: http://code.google.com/p/hgdata/issues/entry+synopsis: Library and command-line utility for accessing Google services and APIs.+description: This project provides a Haskell library and command-line interface for Google services such as Google Storage, Contacts, Books, etc.+ .+ For OAuth 2.0, the following operations are supported:+ .+ * Forming a URL for authorizing one or more Google APIs+ .+ * Exchanging an authorization code for tokens+ .+ * Refreshing tokens+ .+ * Validating tokens+ .+ .+ For the Google Storage API, the following operations are supported:+ .+ * GET Service+ .+ * PUT Bucket+ .+ * GET Bucket+ .+ * DELETE Bucket+ .+ * GET Object+ .+ * PUT Object+ .+ * HEAD Object+ .+ * DELETE Object+ .+ 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+category: Network+author: Brian W Bush <b.w.bush@acm.org>+data-dir: ""+ +source-repository head+ type: mercurial+ location: https://code.google.com/p/hgdata/+ +library+ build-depends: HTTP -any, base <6, base64-bytestring -any,+ binary -any, bytestring -any, case-insensitive -any, cmdargs -any,+ directory -any, filepath -any, 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+ exposed-modules: Crypto.GnuPG Crypto.MD5 Network.Google+ Network.Google.Contacts Network.Google.OAuth2+ 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+ +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+ 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.Encrypted Network.Google.Storage.Sync+ Crypto.MD5 Crypto.GnuPG Data.ByteString.Util Data.List.Util+
+ src/Crypto/GnuPG.hs view
@@ -0,0 +1,151 @@+-----------------------------------------------------------------------------+--+-- Module : Crypto.GnuPG+-- Copyright : (c) 2012-13 Brian W Bush+-- License : MIT+--+-- Maintainer : Brian W Bush <b.w.bush@acm.org>+-- Stability : Stable+-- Portability : Linux+--+-- | Interface to GnuPG. The GnuPG program \"gpg\" must be on the PATH.+--+-----------------------------------------------------------------------------+++module Crypto.GnuPG (+-- * Types+ Recipient+-- * Functions+, decrypt+, decryptLbs+, encrypt+, encryptLbs+) where+++import Control.Concurrent (forkIO)+import qualified Data.ByteString.Lazy as LBS (ByteString, hGetContents, hPutStr)+import System.Process (runInteractiveProcess)+import System.IO (hClose, hFlush, hGetContents, hPutStr)+++-- | A recipient for encryption.+type Recipient = String+++-- | Decrypt text.+decrypt ::+ String -- ^ The encrypted text.+ -> IO String -- ^ The plain text.+decrypt input =+ do+ (hIn, hOut, _, _) <- runInteractiveProcess+ "gpg"+ [+ "--decrypt"+ , "--no-mdc-warning"+ , "--quiet"+ , "--batch"+ ]+ Nothing+ Nothing+ forkIO+ (+ do+ hPutStr hIn input+ hFlush hIn+ hClose hIn+ )+ output <- hGetContents hOut+ return output+++-- | Encrypt text.+encrypt ::+ [Recipient] -- ^ The recipients for encryption.+ -> String -- ^ The plain text.+ -> IO String -- ^ The encrypted text.+encrypt recipients input =+ do+ (hIn, hOut, _, _) <- runInteractiveProcess+ "gpg"+ (+ [+ "--encrypt"+ , "--armor"+ , "--quiet"+ , "--batch"+ ]+ +++ concatMap (\r -> ["--recipient", r]) recipients+ )+ Nothing+ Nothing+ forkIO+ (+ do+ hPutStr hIn input+ hFlush hIn+ hClose hIn+ )+ output <- hGetContents hOut+ return output+++-- | Decrypt binary data.+decryptLbs ::+ LBS.ByteString -- ^ The encrypted data.+ -> IO LBS.ByteString -- ^ The plain data.+decryptLbs input =+ do+ (hIn, hOut, _, _) <- runInteractiveProcess+ "gpg"+ [+ "--decrypt"+ , "--no-mdc-warning"+ , "--quiet"+ , "--batch"+ ]+ Nothing+ Nothing+ forkIO+ (+ do+ LBS.hPutStr hIn input+ hFlush hIn+ hClose hIn+ )+ output <- LBS.hGetContents hOut+ return output+++-- | Encrypt binary data.+encryptLbs ::+ [Recipient] -- ^ The recipients for encryption.+ -> LBS.ByteString -- ^ The plain data.+ -> IO LBS.ByteString -- ^ The encrypted data.+encryptLbs recipients input =+ do+ (hIn, hOut, _, _) <- runInteractiveProcess+ "gpg"+ (+ [+ "--encrypt"+ , "--quiet"+ , "--batch"+ ]+ +++ concatMap (\r -> ["--recipient", r]) recipients+ )+ Nothing+ Nothing+ forkIO+ (+ do+ LBS.hPutStr hIn input+ hFlush hIn+ hClose hIn+ )+ output <- LBS.hGetContents hOut+ return output
+ src/Crypto/MD5.hs view
@@ -0,0 +1,66 @@+-----------------------------------------------------------------------------+--+-- Module : Crypto.MD5+-- 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 MD5 checksums.+--+-----------------------------------------------------------------------------+++module Crypto.MD5 (+-- * Types+ MD5Info+, MD5String+, MD5Base64+, MD5Digest+-- * Functions+, md5+, md5Base64+, md5ToBase64+) where+++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.Base64 as B64 (encode)+import Data.Digest.Pure.MD5 (MD5Digest, md5)+import Numeric (readHex)+++-- | MD5 checksum information.+type MD5Info = (MD5String, MD5Base64)+++-- | An MD5 checksum represented as a character string.+type MD5String = String+++-- | An MD5 checksum represented in base 64 encoding.+type MD5Base64 = String+++-- | Compute an MD5 checksum.+md5Base64 ::+ ByteString -- ^ The data.+ -> MD5Info -- ^ The MD5 sum.+md5Base64 x =+ let+ y = md5 x+ z = md5ToBase64 y+ in+ (show y, z)+++-- | Convert an MD5 digest into a base-64-encoded string.+md5ToBase64 ::+ MD5Digest -- ^ The MD5 digest.+ -> MD5Base64 -- ^ The MD5 checksum in base 64 encoding.+md5ToBase64 = unpack . B64.encode . BS.concat . toChunks . B.encode
+ src/Data/ByteString/Util.hs view
@@ -0,0 +1,56 @@+-----------------------------------------------------------------------------+--+-- 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/Data/List/Util.hs view
@@ -0,0 +1,34 @@+-----------------------------------------------------------------------------+--+-- Module : Data.List.Util+-- Copyright : (c) 2012-13 Brian W Bush+-- License : MIT+--+-- Maintainer : Brian W Bush <b.w.bush@acm.org>+-- Stability : Stable+-- Portability : Portable+--+-- | Miscellaneous functions for manipulating lists.+--+-----------------------------------------------------------------------------+++module Data.List.Util (+ separate+) where+++-- | The 'separate' function splits a list into fragments separated by a given element. +separate :: Eq a => + a -- ^ The separating element + -> [a] -- ^ The list to be separated + -> [[a]] -- ^ The lists between the separating element +separate _ [] = [] +separate a s = + let + (l, s') = break (== a) s + in + l : case s' of + [] -> [] + [a] -> [[]] + (_:s'') -> separate a s''
+ src/Main.hs view
@@ -0,0 +1,422 @@+-----------------------------------------------------------------------------+--+-- Module : Main+-- Copyright : (c) 2012-13 Brian W Bush+-- License : MIT+--+-- Maintainer : Brian W Bush <b.w.bush@acm.org>+-- Stability : Stable+-- Portability : Linux+--+-- | Command-line access to Google APIs.+--+-----------------------------------------------------------------------------+++{-# LANGUAGE DeriveDataTypeable #-}+++module Main (+ main+) where+++import Control.Monad (liftM)+import Data.Data(Data(..))+import qualified Data.ByteString.Lazy as LBS (readFile, writeFile)+import Data.Maybe (catMaybes)+import Network.Google (AccessToken, toAccessToken)+import Network.Google.Contacts (extractGnuPGNotes, listContacts)+import qualified Network.Google.OAuth2 as OA2 (OAuth2Client(..), OAuth2Tokens(..), exchangeCode, formUrl, googleScopes, refreshTokens)+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.XML.Light (ppTopElement)+++-- | Definition of command-line parameters.+data HGData =+ OAuth2Url {+ client :: String+ }+ | OAuth2Exchange {+ client :: String+ , secret :: String+ , code :: String+ , tokens :: FilePath+ }+ | OAuth2Refresh {+ client :: String+ , secret :: String+ , refresh :: String+ , tokens :: FilePath+ }+ | Contacts {+ access :: String+ , xml :: FilePath+ , notes :: Maybe FilePath+ , encrypt :: [String]+ }+ | SList {+ access :: String+ , project :: String+ , bucket :: String+ , xml :: FilePath+ }+ | SGet {+ access :: String+ , project :: String+ , bucket :: String+ , key :: String+ , output :: FilePath+ , decrypt :: Bool+ }+ | SPut {+ access :: String+ , project :: String+ , bucket :: String+ , key :: String+ , input :: FilePath+ , acl :: String+ , encrypt :: [String]+ }+ | SDelete {+ access :: String+ , project :: String+ , bucket :: String+ , key :: String+ }+ | SHead {+ access :: String+ , project :: String+ , bucket :: String+ , key :: String+ , output :: FilePath+ }+ | SSync {+ client :: String+ , secret :: String+ , refresh :: String+ , project :: String+ , bucket :: String+ , directory :: FilePath+ , acl :: String+ , encrypt :: [String]+ , exclusions :: Maybe FilePath+ , md5sums :: Bool+ , purge :: Bool+ }+ deriving (Show, Data, Typeable)+++-- | 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."+ &= 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>."+ )+++-- | Generate an OAuth 2.0 URL.+oAuth2Url :: HGData+oAuth2Url = OAuth2Url+ {+ client = def &= typ "ID" &= help "Client ID"+ }+ &= help "Generate an OAuth 2.0 URL."+ &= details+ [+ "Use this command to generate a URL for OAuth 2.0 authentication of this client program with Google APIs."+ , ""+ , "Visit the URL generated by the command and authorize the application to obtain an OAuth 2.0 authorization code the can be exchanged for tokens with the \"hgdata oauth2exchange\" command."+ , ""+ , "A \"Client ID for installed applications\" can be obtained from the \"API Access\" section of the Google API Console <https://code.google.com/apis/console/>."+ ]+++-- | Exchange an OAuth 2.0 code for tokens.+oAuth2Exchange :: HGData+oAuth2Exchange = OAuth2Exchange+ {+ client = def &= typ "ID" &= help "OAuth 2.0 client ID"+ , secret = def &= typ "SECRET" &= help "OAuth 2.0 client secret"+ , code = def &= typ "CODE" &= argPos 0+ , tokens = def &= opt "/dev/stdout" &= typFile &= argPos 1+ }+ &= help "Exchange an OAuth 2.0 code for tokens."+ &= details+ [+ "Use this command to exchange an OAuth 2.0 authentication code for an access and refresh token."+ , ""+ , "An OAuth 2.0 authentication code can be obtain by visiting the URL generated by the \"hgdata oauth2url\" command."+ , ""+ , "A \"Client ID for installed applications\" and client secret can be obtained from the \"API Access\" section of the Google API Console <https://code.google.com/apis/console/>."+ ]+++-- | Refresh OAuth 2.0 tokens.+oAuth2Refresh :: HGData+oAuth2Refresh = OAuth2Refresh+ {+ client = def &= typ "ID" &= help "OAuth 2.0 client ID"+ , secret = def &= typ "SECRET" &= help "OAuth 2.0 client secret"+ , refresh = def &= typ "TOKEN" &= help "OAuth 2.0 refresh token"+ , tokens = def &= opt "/dev/stdout" &= typFile &= argPos 0+ }+ &= help "Refresh OAuth 2.0 tokens."+ &= details+ [+ "Use this command to refresh an OAuth 2.0 access token."+ , ""+ , "An OAuth 2.0 refresh token can be obtained using the \"hgdata oauth2exchange\" command."+ , ""+ , "A \"Client ID for installed applications\" and client secret can be obtained from the \"API Access\" section of the Google API Console <https://code.google.com/apis/console/>."+ ]+++-- | Download Google Contacts.+contacts :: HGData+contacts = Contacts+ {+ access = def &= typ "TOKEN" &= help "OAuth 2.0 access token"+ , xml = def &= opt "/dev/stdout" &= typFile &= argPos 0+ , notes = def &= typFile &= help "Output for GnuPG/PGP data from \"Notes\" field"+ , encrypt = def &= typ "RECIPIENT" &= help "recipient to encrypt passwords for"+ }+ &= help "Download Google Contacts."+ &= details+ [+ "Use this command to download an XML file of Google Contacts."+ , ""+ , "If the \"--notes\" flag is specified, then any GnuPG or PGP data in the Contacts' \"Notes\" field will be decrypted to the file specified. If one or more \"--encrypt\" flags are also specified, then the decrypted notes fields will be re-encrypted to the recipients specified. The GnuPG executable \"gnupg\" must be on the command-line PATH."+ , ""+ , "An OAuth 2.0 access token can be obtained using the \"hgdata oauth2exchange\" or \"hgdata oauth2refresh\" command."+ , ""+ , "A \"Client ID for installed applications\" and client secret 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+ {+ 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+ }+ &= help "List objects in a Google Storage bucket."+ &= details+ [+ "Use this command to list the contents, in XML format, of a Google Storage bucket."+ , ""+ , "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/>."+ ]+++-- | Get an object from a Google Storage bucket.+sget :: HGData+sget = SGet+ {+ 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+ , output = def &= opt "/dev/stdout" &= typFile &= argPos 2+ , decrypt = def &= help "Attempt to decrypt the object"+ }+ &= help "Get an object from a Google Storage bucket."+ &= details+ [+ "Use this command to download an object from Google Storage."+ , ""+ , "In order for decryption to work, the GnuPG executable \"gnupg\" must be on the command-line PATH."+ , ""+ , "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/>."+ ]+++-- | Put an object into a Google Storage bucket.+sput :: HGData+sput = SPut+ {+ 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+ , input = def &= opt "/dev/stdin" &= typFile &= argPos 2+ , acl = def &= opt "private" &= typ "ACL" &= argPos 3+ , encrypt = def &= typ "RECIPIENT" &= help "Recipient to encrypt for"+ }+ &= help "Put an object into a Google Storage bucket."+ &= details+ [+ "Use this command to upload an object to Google Storage."+ , ""+ , "The pre-canned ACL must be one of the following: private (the default), public-read, public-read-write, authenticated-read, bucket-owner-read, bucket-owner-full-control."+ , ""+ , "In order for encryption to work, the GnuPG executable \"gnupg\" must be on the command-line PATH."+ , ""+ , "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/>."+ ]+++-- | Delete an object from a Google Storage bucket.+sdelete :: HGData+sdelete = SDelete+ {+ 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+ }+ &= help "Delete an object from a Google Storage bucket."+ &= details+ [+ "Use this command to delete an object from Google Storage."+ , ""+ , "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/>."+ ]+++-- | Get object metadata from a Google Storage bucket.+shead :: HGData+shead = SHead+ {+ 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+ , output = def &= opt "/dev/stdout" &= typFile &= argPos 2+ }+ &= help "Get object metadata from a Google Storage bucket."+ &= details+ [+ "Use this command to list information about an object in Google Storage."+ , ""+ , "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/>."+ ]+++-- | Synchronize a directory with a Google Storage bucket.+ssync :: HGData+ssync = SSync+ {+ client = def &= typ "ID" &= help "OAuth 2.0 client ID"+ , secret = def &= typ "SECRET" &= help "OAuth 2.0 client secret"+ , refresh = def &= typ "TOKEN" &= help "OAuth 2.0 refresh token"+ , project = def &= typ "ID" &= help "Google API project number"+ , bucket = def &= typ "BUCKET" &= argPos 0+ , directory = def &= typ "DIRECTORY" &= argPos 1+ , acl = def &= opt "private" &= typ "ACL" &= argPos 2+ , encrypt = def &= typ "RECIPIENT" &= help "Recipient to encrypt for"+ , exclusions = def &= typFile &= help "File of regex exclusions"+ , md5sums = def &= help "Write file \".md5sum\" in directory"+ , purge = def &= help "Purge non-synchronized objects from the bucket"+ }+ &= help "Synchronize a directory with a Google Storage bucket."+ &= details+ [+ "Use this command to synchronize a directory to a Google Storage bucket."+ , ""+ , "The pre-canned ACL must be one of the following: private (the default), public-read, public-read-write, authenticated-read, bucket-owner-read, bucket-owner-full-control."+ , ""+ , "In order for encryption to work, the GnuPG executable \"gnupg\" must be on the command-line PATH."+ , ""+ , "The exclusion files consists on regular expressions, one per line, of paths to be excluded from the synchronization."+ , ""+ , "The \".md5sum\" file will contain the MD5 sums and filenames of the synchronized files in a format that can be used to check MD5 sums with the \"md5sum -c\" command or with \"md5deep\"."+ , ""+ , "An OAuth 2.0 refresh token can be obtained using the \"hgdata oauth2exchange\" command. A \"Client ID for installed applications\" and client secret can be obtained from the \"API Access\" section of the Google API Console <https://code.google.com/apis/console/>. A project ID can be obtained from the \"API Access\" section of the Google API Console <https://code.google.com/apis/console/>."+ ]+++-- | Dispatch a command-line request.+dispatch :: HGData -> IO ()++dispatch (OAuth2Url clientId) =+ do+ putStrLn $ OA2.formUrl (OA2.OAuth2Client clientId undefined) $+ catMaybes $ map (flip lookup OA2.googleScopes) ["Google Cloud Storage", "Contacts"]++dispatch (OAuth2Exchange clientId clientSecret exchangeCode tokenFile) =+ do+ tokens <- OA2.exchangeCode (OA2.OAuth2Client clientId clientSecret) exchangeCode+ writeFile tokenFile $ show tokens++dispatch (OAuth2Refresh clientId clientSecret refreshToken tokenFile) =+ do+ tokens <- OA2.refreshTokens (OA2.OAuth2Client clientId clientSecret) (OA2.OAuth2Tokens undefined refreshToken undefined undefined)+ writeFile tokenFile $ show tokens++dispatch (Contacts accessToken xmlOutput passwordOutput recipients) =+ do+ contacts <- listContacts $ toAccessToken accessToken+ writeFile xmlOutput $ ppTopElement contacts+ maybe+ (return ())+ (+ \x ->+ do+ passwords <- extractGnuPGNotes recipients contacts+ writeFile x passwords+ )+ passwordOutput++dispatch (SList accessToken projectId bucket xmlOutput) =+ do+ result <- getBucket projectId bucket (toAccessToken accessToken)+ writeFile xmlOutput $ ppTopElement result++dispatch (SGet 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) =+ 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) =+ do+ result <- deleteObject projectId bucket key (toAccessToken accessToken)+ return ()++dispatch (SHead 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) =+ do+ let+ acl' = if acl == "" then Private else read acl+ exclusions <- liftM lines $ maybe (return "") readFile exclusionFile+ sync+ projectId+ acl'+ bucket+ (OA2.OAuth2Client clientId clientSecret)+ (OA2.OAuth2Tokens undefined refreshToken undefined undefined)+ directory+ recipients+ exclusions+ md5sums+ purge+++-- | Main entry point.+main :: IO ()+main =+ do+ command <- cmdArgs hgData+ dispatch command
+ src/Network/Google.hs view
@@ -0,0 +1,221 @@+-----------------------------------------------------------------------------+--+-- Module : Network.Google+-- Copyright : (c) 2012-13 Brian W Bush+-- License : MIT+--+-- Maintainer : Brian W Bush <b.w.bush@acm.org>+-- Stability : Stable+-- Portability : Portable+--+-- | Helper functions for accessing Google APIs.+--+-----------------------------------------------------------------------------+++{-# LANGUAGE FlexibleInstances #-}+++module Network.Google (+-- * Types+ AccessToken+, toAccessToken+, ProjectId+-- * Functions+, appendBody+, appendHeaders+, appendQuery+, doManagedRequest+, doRequest+, makeProjectRequest+, makeRequest+, makeRequestValue+) where+++import Control.Exception (finally)+import Control.Monad.Trans.Resource (ResourceT, runResourceT)+import Data.List (intersperse)+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.Lazy.Char8 as LBS8 (ByteString)+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.XML.Light (Element, parseXMLDoc)+++-- | OAuth 2.0 access token.+type AccessToken = BS.ByteString++-- | Convert a string to an access token.+toAccessToken ::+ String -- ^ The string.+ -> AccessToken -- ^ The OAuth 2.0 access token.+toAccessToken = BS8.pack+++-- | Google API project ID, see <https://code.google.com/apis/console>.+type ProjectId = String+++-- | Construct a Google API request.+makeRequest ::+ AccessToken -- ^ The OAuth 2.0 access token.+ -> (String, String) -- ^ The Google API name and version.+ -> String -- ^ The HTTP method.+ -> (String, String) -- ^ The host and path for the request.+ -> Request m -- ^ The HTTP request.+makeRequest accessToken (apiName, apiVersion) method (host, path) =+ def {+ method = BS8.pack method+ , secure = True+ , host = BS8.pack host+ , port = 443+ , path = BS8.pack path+ , requestHeaders = [+ (makeHeaderName apiName, BS8.pack apiVersion)+ , (makeHeaderName "Authorization", BS8.append (BS8.pack "OAuth ") accessToken)+ ]+ }+++-- | Construct a project-related Google API request.+makeProjectRequest ::+ ProjectId -- ^ The project ID.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> (String, String) -- ^ The Google API name and version.+ -> String -- ^ The HTTP method.+ -> (String, String) -- ^ The host and path for the request.+ -> Request m -- ^ The HTTP request.+makeProjectRequest projectId accessToken api method hostPath =+ appendHeaders+ [+ ("x-goog-project-id", projectId)+ ]+ (makeRequest accessToken api method hostPath)+++-- | Class for Google API request.+class DoRequest a where+ -- | Perform a request.+ doRequest ::+ Request (ResourceT IO) -- ^ The request.+ -> IO a -- ^ The action returning the result of performing the request.+ doRequest request =+ do+{--+ -- TODO: The following seems cleaner, but has type/instance problems:+ (_, manager) <- allocate (newManager def) closeManager+ doManagedRequest manager request+--}+ manager <- newManager def+ finally+ (doManagedRequest manager request)+ (closeManager manager)+ doManagedRequest ::+ Manager -- ^ The conduit HTTP manager.+ -> Request (ResourceT IO) -- ^ The request.+ -> IO a -- ^ The action returning the result of performing the request.+++instance DoRequest LBS8.ByteString where+ doManagedRequest manager request =+ do+ response <- runResourceT (httpLbs request manager)+ return $ responseBody response+++instance DoRequest String where+ doManagedRequest manager request =+ do+ result <- doManagedRequest manager request+ return $ lbsToS result+++instance DoRequest [(String, String)] where+ doManagedRequest manager request =+ do+ response <- runResourceT (httpLbs request manager)+ return $ read . show $ responseHeaders response+++instance DoRequest () where+ doManagedRequest manager request =+ do+ doManagedRequest manager request :: IO LBS8.ByteString+ return ()+++instance DoRequest Element where+ doManagedRequest manager request =+ do+ result <- (doManagedRequest manager request :: IO String)+ return $ fromJust $ parseXMLDoc result+++-- | Prepare a string for inclusion in a request.+makeRequestValue ::+ String -- ^ The string.+ -> BS8.ByteString -- ^ The prepared string.+makeRequestValue = BS8.pack+++-- | Prepare a name\/key for a header.+makeHeaderName ::+ String -- ^ The name.+ -> CI.CI BS8.ByteString -- ^ The prepared name.+makeHeaderName = CI.mk . BS8.pack+++-- | Prepare a value for a header.+makeHeaderValue ::+ String -- ^ The value.+ -> BS8.ByteString -- ^ The prepared value.+makeHeaderValue = BS8.pack+++-- | Append headers to a request.+appendHeaders ::+ [(String, String)] -- ^ The (name\/key, value) pairs for the headers.+ -> Request m -- ^ The request.+ -> Request m -- ^ The request with the additional headers.+appendHeaders headers request =+ let+ headerize :: (String, String) -> (CI.CI BS8.ByteString, BS8.ByteString)+ headerize (n, v) = (makeHeaderName n, makeHeaderValue v)+ in+ request {+ requestHeaders = requestHeaders request ++ map headerize headers+ }+++-- | Append a body to a request.+appendBody ::+ LBS8.ByteString -- ^ The data for the body.+ -> Request m -- ^ The request.+ -> Request m -- ^ The request with the body appended.+appendBody bytes request =+ request {+ requestBody = RequestBodyLBS bytes+ }+++-- | Append a query to a request.+appendQuery ::+ [(String, String)] -- ^ The query keys and values.+ -> Request m -- ^ The request.+ -> Request m -- ^ The request with the query appended.+appendQuery query request =+ let+ makeParameter :: (String, String) -> String+ makeParameter (k, v) = k ++ "=" ++ urlEncode v+ query' :: String+ query' = concat $ intersperse "&" $ map makeParameter query+ in+ request+ {+ queryString = BS8.pack $ "?" ++ query'+ }
+ src/Network/Google/Contacts.hs view
@@ -0,0 +1,106 @@+-----------------------------------------------------------------------------+--+-- Module : Network.Google.Contacts+-- Copyright : (c) 2012-13 Brian W Bush+-- License : MIT+--+-- Maintainer : Brian W Bush <b.w.bush@acm.org>+-- Stability : Stable+-- Portability : Portable.+--+-- | Functions for accessing the Google Contacts API, see <https://developers.google.com/google-apps/contacts/v3/>.+--+-----------------------------------------------------------------------------+++module Network.Google.Contacts (+-- * Functions+ listContacts+, extractGnuPGNotes+) where+++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 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)+++-- | The host for API access.+contactsHost :: String+contactsHost = "www.google.com"+++-- | The API version used here.+contactsApi :: (String, String)+contactsApi = ("Gdata-version", "3.0")+++-- | List the contacts, see <https://developers.google.com/google-apps/contacts/v3/#retrieving_all_contacts>.+listContacts ::+ AccessToken -- ^ The OAuth 2.0 access token.+ -> IO Element -- ^ The action returning the contacts in XML format.+listContacts accessToken =+ do+ let+ request = listContactsRequest accessToken+ doRequest request+++-- | Make an HTTP request to list the contacts.+listContactsRequest ::+ AccessToken -- ^ The OAuth 2.0 access token.+ -> Request m -- ^ The request.+listContactsRequest accessToken =+ (makeRequest accessToken contactsApi "GET" (contactsHost, "/m8/feeds/contacts/default/full/"))+ {+ queryString = makeRequestValue "?max-results=100000"+ }+++-- | Extract the GnuPG\/PGP text in the \"Notes\" fields of a contact list. Extracts are re-encrypted if recipients for the re-encrypted list are specified.+extractGnuPGNotes ::+ [Recipient] -- ^ The recipients to re-encrypt the extracts to.+ -> Element -- ^ The contact list.+ -> IO String -- ^ The action return the decrypted and then possibly re-encrypted extracts.+extractGnuPGNotes recipients text =+ do+ let+ passwords = extractGnuPGNotes' text+ replacePassword (t, o, p) =+ do+ p' <- decrypt p+ return $ unlines $ ["-----", "", t, o, "", p']+ passwords' <- mapM replacePassword passwords+ (if null recipients then return . id else encrypt recipients) $ unlines passwords'+++-- | Extract the GnuPG\/PGP from a contact list.+extractGnuPGNotes' ::+ Element -- ^ The contact list.+ -> [(String, String, String)] -- ^ The contacts in (title, organization, GnuPG\/PGP extract) format.+extractGnuPGNotes' xml =+ let+ findChildName :: String -> Element -> Maybe Element+ findChildName x = filterChildName (\z -> qName z == x)+ checkPrefix :: String -> String -> Maybe String+ checkPrefix p x = liftM (const x) . stripPrefix p $ x+ getTitle :: Element -> Maybe String+ getTitle = liftM strContent . findChildName "title"+ getOrganization :: Element -> Maybe String+ getOrganization = liftM strContent . findChildName "orgName" <=< findChildName "organization"+ getPGP :: Element -> Maybe String+ getPGP = checkPrefix "-----BEGIN PGP MESSAGE-----" <=< liftM strContent . findChildName "content"+ getEntry :: Element -> Maybe (String, String, String)+ getEntry x =+ do+ t <- getTitle x+ o <- getOrganization x+ p <- getPGP x+ return (t, o, p)+ in+ catMaybes $ map getEntry $ elChildren xml
+ src/Network/Google/OAuth2.hs view
@@ -0,0 +1,246 @@+-----------------------------------------------------------------------------+--+-- Module : Network.Google.OAuth2+-- Copyright : (c) 2012-13 Brian W Bush+-- License : MIT+--+-- Maintainer : Brian W Bush <b.w.bush@acm.org>+-- Stability : Stable+-- Portability : Portable+--+-- | Functions for OAuth 2.0 authentication for Google APIs.+--+-----------------------------------------------------------------------------+++module Network.Google.OAuth2 (+-- * Types+ OAuth2Client(..)+, OAuth2Scope+, OAuth2Tokens(..)+-- * Functions+, googleScopes+, formUrl+, exchangeCode+, refreshTokens+, validateTokens+) where+++import Data.ByteString.Char8 as BS8 (ByteString, pack)+import Data.ByteString.Util (lbsToS)+import Data.CaseInsensitive as CI (CI(..), mk)+import Data.List (intercalate)+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)+++-- An OAuth 2.0 client for an installed application, see <https://developers.google.com/accounts/docs/OAuth2InstalledApp>.+data OAuth2Client = OAuth2Client+ {+ clientId :: String -- ^ The client ID.+ , clientSecret :: String -- ^ The client secret.+ }+ deriving (Read, Show)+++-- | An OAuth 2.0 code.+type OAuth2Code = String+++-- | OAuth 2.0 tokens.+data OAuth2Tokens = OAuth2Tokens+ {+ accessToken :: String -- ^ The access token.+ , refreshToken :: String -- ^ The refresh token.+ , expiresIn :: Rational -- ^ The number of seconds until the access token expires.+ , tokenType :: String -- ^ The token type.+ }+ deriving (Read, Show)+++-- | An OAuth 2.0 scope.+type OAuth2Scope = String+++-- | The OAuth 2.0 scopes for Google APIs, see <https://developers.google.com/oauthplayground/>.+googleScopes ::+ [(String, OAuth2Scope)] -- ^ List of names and the corresponding scopes.+googleScopes =+ [+ ("Adsense Management", "https://www.googleapis.com/auth/adsense")+ , ("Google Affiliate Network", "https://www.googleapis.com/auth/gan")+ , ("Analytics", "https://www.googleapis.com/auth/analytics.readonly")+ , ("Google Books", "https://www.googleapis.com/auth/books")+ , ("Blogger", "https://www.googleapis.com/auth/blogger")+ , ("Calendar", "https://www.googleapis.com/auth/calendar")+ , ("Google Cloud Storage", "https://www.googleapis.com/auth/devstorage.read_write")+ , ("Contacts", "https://www.google.com/m8/feeds/")+ , ("Content API for Shopping", "https://www.googleapis.com/auth/structuredcontent")+ , ("Chrome Web Store", "https://www.googleapis.com/auth/chromewebstore.readonly")+ , ("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")+ , ("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/")+ , ("Google Latitude", "https://www.googleapis.com/auth/latitude.all.best https://www.googleapis.com/auth/latitude.all.city")+ , ("Moderator", "https://www.googleapis.com/auth/moderator")+ , ("Nicknames", "Provisioning https://apps-apis.google.com/a/feeds/alias/")+ , ("Orkut", "https://www.googleapis.com/auth/orkut")+ , ("Picasa Web", "https://picasaweb.google.com/data/")+ , ("Sites", "https://sites.google.com/feeds/")+ , ("Spreadsheets", "https://spreadsheets.google.com/feeds/")+ , ("Tasks", "https://www.googleapis.com/auth/tasks")+ , ("URL Shortener", "https://www.googleapis.com/auth/urlshortener")+ , ("Userinfo - Email", "https://www.googleapis.com/auth/userinfo.email")+ , ("Userinfo - Profile", "https://www.googleapis.com/auth/userinfo.profile")+ , ("User Provisioning", "https://apps-apis.google.com/a/feeds/user/")+ , ("Webmaster Tools", "https://www.google.com/webmasters/tools/feeds/")+ , ("YouTube", "https://gdata.youtube.com")+ ]+++-- | The redirect URI for an installed application, see <https://developers.google.com/accounts/docs/OAuth2InstalledApp#choosingredirecturi>.+redirectUri :: String+redirectUri = "urn:ietf:wg:oauth:2.0:oob"+++-- | Form a URL for authorizing an installed application, see <https://developers.google.com/accounts/docs/OAuth2InstalledApp#formingtheurl>.+formUrl ::+ OAuth2Client -- ^ The OAuth 2.0 client.+ -> [OAuth2Scope] -- ^ The OAuth 2.0 scopes to be authorized.+ -> String -- ^ The URL for authorization.+formUrl client scopes =+ "https://accounts.google.com/o/oauth2/auth"+ ++ "?response_type=code"+ ++ "&client_id=" ++ clientId client+ ++ "&redirect_uri=" ++ redirectUri+ ++ "&scope=" ++ (intercalate "+" $ map urlEncode scopes)+++-- | Exchange an authorization code for tokens, see <https://developers.google.com/accounts/docs/OAuth2InstalledApp#handlingtheresponse>.+exchangeCode ::+ OAuth2Client -- ^ The OAuth 2.0 client.+ -> OAuth2Code -- ^ The authorization code.+ -> IO OAuth2Tokens -- ^ The action for obtaining the tokens.+exchangeCode client code =+ do+ result <- doOAuth2 client "authorization_code" ("&redirect_uri=" ++ redirectUri ++ "&code=" ++ code)+ let+ (Ok result') = decodeTokens result+ return result'+++-- | Parse OAuth 2.0 tokens.+decodeTokens ::+ JSObject JSValue -- ^ The JSON value.+ -> Result OAuth2Tokens -- ^ The OAuth 2.0 tokens.+decodeTokens value =+ do+ let+ (!) = flip valFromObj+ expiresIn' :: Rational+ (Ok (JSRational _ expiresIn')) = valFromObj "expires_in" value+ accessToken <- value ! "access_token"+ refreshToken <- value ! "refresh_token"+ -- expiresIn <- value ! "expires_in"+ tokenType <- value ! "token_type"+ return OAuth2Tokens+ {+ accessToken = accessToken+ , refreshToken = refreshToken+ , expiresIn = expiresIn'+ , tokenType = tokenType+ }+++-- | Refresh OAuth 2.0 tokens, see <https://developers.google.com/accounts/docs/OAuth2InstalledApp#refresh>.+refreshTokens ::+ OAuth2Client -- ^ The client.+ -> OAuth2Tokens -- ^ The tokens.+ -> IO OAuth2Tokens -- ^ The action to refresh the tokens.+refreshTokens client tokens =+ do+ result <- doOAuth2 client "refresh_token" ("&refresh_token=" ++ refreshToken tokens)+ let+ (Ok result') = decodeTokens' 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 client grantType extraBody =+ do+ let+ makeHeaderName :: String -> CI.CI BS8.ByteString+ makeHeaderName = CI.mk . BS8.pack+ request =+ def {+ method = BS8.pack "POST"+ , secure = True+ , host = BS8.pack "accounts.google.com"+ , port = 443+ , path = BS8.pack "/o/oauth2/token"+ , requestHeaders = [+ (makeHeaderName "Content-Type", BS8.pack "application/x-www-form-urlencoded")+ ]+ , requestBody = RequestBodyBS . BS8.pack+ $ "client_id=" ++ clientId client+ ++ "&client_secret=" ++ clientSecret client+ ++ "&grant_type=" ++ grantType+ ++ extraBody+ }+ response <- withManager $ httpLbs request+ let+ (Ok result) = decode . lbsToS $ responseBody response+ return $ result+++-- | Validate OAuth 2.0 tokens, see <https://developers.google.com/accounts/docs/OAuth2Login#validatingtoken>.+validateTokens ::+ OAuth2Tokens -- ^ The tokens.+ -> IO Rational -- ^ The number of seconds until the access token expires.+validateTokens tokens =+ do+ let+ makeHeaderName :: String -> CI.CI BS8.ByteString+ makeHeaderName = CI.mk . BS8.pack+ request =+ def {+ method = BS8.pack "GET"+ , secure = True+ , host = BS8.pack "www.googleapis.com"+ , port = 443+ , path = BS8.pack "/oauth2/v1/tokeninfo"+ , queryString = BS8.pack ("?access_token=" ++ accessToken tokens)+ }+ response <- withManager $ httpLbs request+ let+ (Ok result) = decode . lbsToS $ responseBody response+ expiresIn' :: Rational+ (Ok (JSRational _ expiresIn')) = valFromObj "expires_in" result+ return expiresIn'
+ src/Network/Google/Storage.hs view
@@ -0,0 +1,455 @@+-----------------------------------------------------------------------------+--+-- Module : Network.Google.Storage+-- Copyright : (c) 2012-13 Brian W Bush+-- License : MIT+--+-- Maintainer : Brian W Bush <b.w.bush@acm.org>+-- Stability : Stable+-- Portability : Portable+--+-- | Functions for the Google Storage API, see <https://developers.google.com/storage/docs/reference-methods>.++-----------------------------------------------------------------------------+++module Network.Google.Storage (+-- * Types+ BucketName+, KeyName+, StorageAcl(..)+, MIMEType+-- * Service Requests+, getService+, getServiceUsingManager+-- * Bucket Requests+, putBucket+, putBucketUsingManager+, getBucket+, getBucketUsingManager+, deleteBucket+, deleteBucketUsingManager+-- * Object Requests+, getObject+, getObjectUsingManager+, putObject+, putObjectUsingManager+, headObject+, headObjectUsingManager+, deleteObject+, deleteObjectUsingManager+) where+++import Control.Monad (liftM)+import Control.Monad.Trans.Resource (ResourceT)+import Crypto.MD5 (MD5Info, md5Base64)+import Data.ByteString.Char8 (unpack)+import Data.ByteString.Lazy (ByteString)+import Data.ByteString.Util (sToBs)+import Data.List (intersperse, stripPrefix)+import Data.List.Util (separate)+import Data.Maybe (fromJust, isNothing, maybe)+import Network.Google (AccessToken, ProjectId, appendBody, appendHeaders, appendQuery, doManagedRequest, doRequest, makeProjectRequest)+import Network.HTTP.Base (urlEncode)+import Network.HTTP.Conduit (Manager, Request, queryString)+import Text.XML.Light (Element(elContent), QName(qName), filterChildName, ppTopElement, strContent)+++-- | A bucket name.+type BucketName = String+++-- | A key name for an object.+type KeyName = String+++-- | Access control.+data StorageAcl =+ Private+ | PublicRead+ | PublicReadWrite+ | AuthenicatedRead+ | BucketOwnerRead+ | BucketOwnerFullControl+ deriving (Bounded, Enum, Eq)++instance Show StorageAcl where+ show Private = "private"+ show PublicRead = "public-read"+ show PublicReadWrite = "public-read-write"+ show AuthenicatedRead = "authenticated-read"+ show BucketOwnerRead = "bucket-owner-read"+ show BucketOwnerFullControl = "bucket-owner-full-control"++instance Read StorageAcl where+ readsPrec _ x =+ let+ matches :: [StorageAcl]+ matches = filter (\y -> show y == x) [minBound..maxBound]+ in+ if null matches+ then []+ else [(last matches, "")]+++-- | MIME type.+type MIMEType = String+++-- | The host name for API access.+storageHost :: String+storageHost = "storage.googleapis.com"+++-- | The API version used here.+storageApi :: (String, String)+storageApi = ("x-goog-api-version", "2")+++-- | Make a host name.+makeHost ::+ BucketName -- ^ The bucket.+ -> String -- ^ The host for the bucket.+makeHost bucket = bucket ++ "." ++ storageHost+++-- | URL-encode a path.+makePath ::+ String -- ^ The unencoded path.+ -> String -- ^ The URL-encoded path.+makePath = ('/' :) . concat . intersperse "/" . map (urlEncode . unpack . sToBs) . 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>.+getService ::+ ProjectId -- ^ The project ID.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO Element -- ^ The action returning the XML with the metadata for the buckets.+getService = getServiceImpl doRequest+++-- | 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>.+getServiceUsingManager ::+ Manager -- ^ The conduit HTTP manager to use.+ -> ProjectId -- ^ The project ID.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO Element -- ^ The action returning the XML with the metadata for the buckets.+getServiceUsingManager = getServiceImpl . doManagedRequest+++-- | 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>.+getServiceImpl ::+ (Request (ResourceT IO) -> IO Element) -- ^ The function for performing the request.+ -> ProjectId -- ^ The project ID.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO Element -- ^ The action returning the XML with the metadata for the buckets.+getServiceImpl doer projectId accessToken =+ do+ let+ request = makeProjectRequest projectId accessToken storageApi "GET" (storageHost, "/")+ doer request+++-- | Creates a bucket in a specified project. This performs the \"PUT Bucket\" request, see <https://developers.google.com/storage/docs/reference-methods#putbucket>.+putBucket ::+ ProjectId -- ^ The project ID.+ -> StorageAcl -- ^ The pre-defined access control.+ -> BucketName -- ^ The bucket.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to put the object and return the response header.+putBucket = putBucketImpl doRequest+++-- | Creates a bucket in a specified project. This performs the \"PUT Bucket\" request, see <https://developers.google.com/storage/docs/reference-methods#putbucket>.+putBucketUsingManager ::+ Manager -- ^ The conduit HTTP manager to use.+ -> ProjectId -- ^ The project ID.+ -> StorageAcl -- ^ The pre-defined access control.+ -> BucketName -- ^ The bucket.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to put the object and return the response header.+putBucketUsingManager = putBucketImpl . doManagedRequest+++-- | Creates a bucket in a specified project. This performs the \"PUT Bucket\" request, see <https://developers.google.com/storage/docs/reference-methods#putbucket>.+putBucketImpl ::+ (Request (ResourceT IO) -> IO [(String, String)]) -- ^ The function for performing the request.+ -> ProjectId -- ^ The project ID.+ -> StorageAcl -- ^ The pre-defined access control.+ -> BucketName -- ^ The bucket.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to create the bucket and return the response header.+putBucketImpl doer projectId acl bucket accessToken =+ do+ let+ request = appendHeaders+ [+ ("x-goog-acl", show acl)+ ]+ (makeProjectRequest projectId accessToken storageApi "PUT" (makeHost bucket, "/"))+ doer request+++-- | Lists the objects that are in a bucket. This performs the \"GET Bucket\" request, see <https://developers.google.com/storage/docs/reference-methods#getbucket>.+getBucket ::+ ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO Element -- ^ The action returning the XML with the metadata for the objects.+getBucket = getBucketImpl doRequest+++-- | Lists the objects that are in a bucket. This performs the \"GET Bucket\" request, see <https://developers.google.com/storage/docs/reference-methods#getbucket>.+getBucketUsingManager ::+ Manager -- ^ The conduit HTTP manager to use.+ -> ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO Element -- ^ The action returning the XML with the metadata for the objects.+getBucketUsingManager = getBucketImpl . doManagedRequest+++-- | Lists the objects that are in a bucket. This performs the \"GET Bucket\" request, see <https://developers.google.com/storage/docs/reference-methods#getbucket>.+getBucketImpl ::+ (Request (ResourceT IO) -> IO Element) -- ^ The function for performing the request.+ -> ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO Element -- ^ The action returning the XML with the metadata for the objects.+getBucketImpl doer projectId bucket accessToken =+ do+ results <- getBucketImpl' doer Nothing projectId bucket accessToken+ let+ root = head results+ return $ root {elContent = concat $ map 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>.+getBucketImpl' ::+ (Request (ResourceT IO) -> IO Element) -- ^ The function for performing the request.+ -> Maybe KeyName -- ^ The key to start listing at.+ -> ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [Element] -- ^ The action returning the XML with the metadata for the objects.+getBucketImpl' doer marker projectId bucket accessToken =+ do+ let+ request =+ appendHeaders+ [+ ("max-keys", "1000000")+ ]+ (makeProjectRequest projectId accessToken storageApi "GET" (makeHost bucket, "/"))+ request' = maybe request (\x -> appendQuery [("marker", x)] request) marker+ result <- doer request'+ let+ marker' :: Maybe String+ marker' = liftM strContent $ filterChildName (("NextMarker" ==) . qName) result+ if isNothing marker' || marker' == Just ""+ then return [result]+ else liftM (result :) $ getBucketImpl' doer marker' projectId bucket accessToken+++-- | Deletes an empty bucket. This performs the \"DELETE Bucket\" request, see <https://developers.google.com/storage/docs/reference-methods#deletebucket>.+deleteBucket ::+ ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to delete the bucket and return the response header.+deleteBucket = deleteBucketImpl doRequest+++-- | Deletes an empty bucket. This performs the \"DELETE Bucket\" request, see <https://developers.google.com/storage/docs/reference-methods#deletebucket>.+deleteBucketUsingManager ::+ Manager -- ^ The conduit HTTP manager to use.+ -> ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to delete the bucket and return the response header.+deleteBucketUsingManager = deleteBucketImpl . doManagedRequest+++-- | Deletes an empty bucket. This performs the \"DELETE Bucket\" request, see <https://developers.google.com/storage/docs/reference-methods#deletebucket>.+deleteBucketImpl ::+ (Request (ResourceT IO) -> IO [(String, String)]) -- ^ The function for performing the request.+ -> ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to delete the bucket and return the response header.+deleteBucketImpl doer projectId bucket accessToken =+ do+ let+ request = makeProjectRequest projectId accessToken storageApi "DELETE" (makeHost bucket, "/")+ doer request+++-- | Downloads an object. This performs the \"GET Object\" request, see <https://developers.google.com/storage/docs/reference-methods#getobject>.+getObject ::+ ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO ByteString -- ^ The action returning the object.+getObject = getObjectImpl doRequest+++-- | Downloads an object. This performs the \"GET Object\" request, see <https://developers.google.com/storage/docs/reference-methods#getobject>.+getObjectUsingManager ::+ Manager -- ^ The conduit HTTP manager to use.+ -> ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO ByteString -- ^ The action returning the object.+getObjectUsingManager = getObjectImpl . doManagedRequest+++-- | Downloads an object. This performs the \"GET Object\" request, see <https://developers.google.com/storage/docs/reference-methods#getobject>.+getObjectImpl ::+ (Request (ResourceT IO) -> IO ByteString) -- ^ The function performing the action.+ -> ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO ByteString -- ^ The action returning the object.+getObjectImpl doer projectId bucket key accessToken =+ do+ let+ request = (makeProjectRequest projectId accessToken storageApi "GET" (makeHost bucket, makePath key))+ doer request+++-- TODO: Uploads objects by using HTML forms. This performs the \"POST Object\" request, see <https://developers.google.com/storage/docs/reference-methods#postobject>.+postObject = undefined+++-- | Uploads an object. This performs the \"PUT Object\" request, see <https://developers.google.com/storage/docs/reference-methods#putobject>.+putObject ::+ ProjectId -- ^ The project ID.+ -> StorageAcl -- ^ The pre-defined access control.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> Maybe MIMEType -- ^ The object's MIME type.+ -> ByteString -- ^ The object's data.+ -> Maybe MD5Info -- ^ The MD5 checksum.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to put the object and return the response header.+putObject = putObjectImpl doRequest+++-- | Uploads an object. This performs the \"PUT Object\" request, see <https://developers.google.com/storage/docs/reference-methods#putobject>.+putObjectUsingManager ::+ Manager -- ^ The conduit HTTP manager to use.+ -> ProjectId -- ^ The project ID.+ -> StorageAcl -- ^ The pre-defined access control.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> Maybe MIMEType -- ^ The object's MIME type.+ -> ByteString -- ^ The object's data.+ -> Maybe MD5Info -- ^ The MD5 checksum.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to put the object and return the response header.+putObjectUsingManager = putObjectImpl . doManagedRequest+++-- | Uploads an object. This performs the \"PUT Object\" request, see <https://developers.google.com/storage/docs/reference-methods#putobject>.+putObjectImpl ::+ (Request (ResourceT IO) -> IO [(String, String)]) -- ^ The function for performing the request.+ -> ProjectId -- ^ The project ID.+ -> StorageAcl -- ^ The pre-defined access control.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> Maybe MIMEType -- ^ The object's MIME type.+ -> ByteString -- ^ The object's data.+ -> Maybe MD5Info -- ^ The MD5 checksum.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to put the object and return the response header.+putObjectImpl doer projectId acl bucket key mimeType bytes md5 accessToken =+ do+ let+ md5' = maybe (snd $ md5Base64 bytes) snd md5+ request =+ appendBody bytes $+ appendHeaders (+ [+ ("x-goog-acl", show acl)+ , ("Content-MD5", md5')+ ]+ +++ maybe [] (\x -> [("Content-Type", x)]) mimeType+ ) (makeProjectRequest projectId accessToken storageApi "PUT" (makeHost bucket, makePath key))+ doer request+++-- | Lists metadata for an object. This performs the \"HEAD Object\" request, see <https://developers.google.com/storage/docs/reference-methods#headobject>.+headObject ::+ ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action returning the object's metadata.+headObject = headObjectImpl doRequest+++-- | Lists metadata for an object. This performs the \"HEAD Object\" request, see <https://developers.google.com/storage/docs/reference-methods#headobject>.+headObjectUsingManager ::+ Manager -- ^ The conduit HTTP manager to use.+ -> ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action returning the object's metadata.+headObjectUsingManager = headObjectImpl . doManagedRequest+++-- | Lists metadata for an object. This performs the \"HEAD Object\" request, see <https://developers.google.com/storage/docs/reference-methods#headobject>.+headObjectImpl ::+ (Request (ResourceT IO) -> IO [(String, String)]) -- ^ The function for performing the request.+ -> ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action returning the object's metadata.+headObjectImpl doer projectId bucket key accessToken =+ do+ let+ request = (makeProjectRequest projectId accessToken storageApi "HEAD" (makeHost bucket, makePath key))+ doer request+++-- | Deletes an object. This performs the \"DELETE Object\" request, see <https://developers.google.com/storage/docs/reference-methods#deleteobject>.+deleteObject ::+ ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to delete the object and return the response header.+deleteObject = deleteObjectImpl doRequest+++-- | Deletes an object. This performs the \"DELETE Object\" request, see <https://developers.google.com/storage/docs/reference-methods#deleteobject>.+deleteObjectUsingManager ::+ Manager -- ^ The conduit HTTP manager to use.+ -> ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to delete the object and return the response header.+deleteObjectUsingManager = deleteObjectImpl . doManagedRequest+++-- | Deletes an object. This performs the \"DELETE Object\" request, see <https://developers.google.com/storage/docs/reference-methods#deleteobject>.+deleteObjectImpl ::+ (Request (ResourceT IO) -> IO [(String, String)]) -- ^ The function for performing the request.+ -> ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to delete the object and return the response header.+deleteObjectImpl doer projectId bucket key accessToken =+ do+ let+ request = (makeProjectRequest projectId accessToken storageApi "DELETE" (makeHost bucket, makePath key))+ doer request
+ src/Network/Google/Storage/Encrypted.hs view
@@ -0,0 +1,113 @@+-----------------------------------------------------------------------------+--+-- Module : Network.Google.Storage.Encrypted+-- Copyright : (c) 2012-13 Brian W Bush+-- License : MIT+--+-- Maintainer : Brian W Bush <b.w.bush@acm.org>+-- Stability : Stable+-- Portability : Portable+--+-- | Functions for putting and getting GnuPG-encrypted objects in Google Storage.+--+-----------------------------------------------------------------------------+++module Network.Google.Storage.Encrypted (+ -- * Object Requests+ putEncryptedObject+, putEncryptedObjectUsingManager+, getEncryptedObject+, getEncryptedObjectUsingManager+) where+++import Crypto.GnuPG (Recipient, decryptLbs, encryptLbs)+import Crypto.MD5 (MD5Info)+import Data.ByteString.Lazy (ByteString)+import Network.Google (AccessToken, ProjectId)+import Network.Google.Storage (BucketName, KeyName, MIMEType, StorageAcl, getObject, getObjectUsingManager, putObject, putObjectUsingManager)+import Network.HTTP.Conduit (Manager)+++-- | Downloads an object and decrypts it.+getEncryptedObject ::+ ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO ByteString -- ^ The action returning the object.+getEncryptedObject = getEncryptedObjectImpl getObject+++-- | Downloads an object and decrypts it.+getEncryptedObjectUsingManager ::+ Manager -- ^ The conduit HTTP manager to use.+ -> ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO ByteString -- ^ The action returning the object.+getEncryptedObjectUsingManager = getEncryptedObjectImpl . getObjectUsingManager+++-- | Downloads an object and decrypts it.+getEncryptedObjectImpl ::+ (String -> String -> String -> AccessToken -> IO ByteString) -- ^ Function for getting an object.+ -> ProjectId -- ^ The project ID.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO ByteString -- ^ The action returning the object.+getEncryptedObjectImpl getter projectId bucket key accessToken =+ do+ bytes <- getter projectId bucket key accessToken+ decryptLbs $ bytes+++-- | Encrypt an object and upload it.+putEncryptedObject ::+ [Recipient] -- ^ The recipients for GnuPG encryption of the uploaded files.+ -> ProjectId -- ^ The project ID.+ -> StorageAcl -- ^ The pre-defined access control.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> Maybe MIMEType -- ^ The object's MIME type.+ -> ByteString -- ^ The object's data.+ -> Maybe MD5Info -- ^ The MD5 checksum.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to put the object and return the response header.+putEncryptedObject = putEncryptedObjectImpl putObject+++putEncryptedObjectUsingManager ::+ Manager -- ^ The conduit HTTP manager to use.+ -> [Recipient] -- ^ The recipients for GnuPG encryption of the uploaded files.+ -> ProjectId -- ^ The project ID.+ -> StorageAcl -- ^ The pre-defined access control.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> Maybe MIMEType -- ^ The object's MIME type.+ -> ByteString -- ^ The object's data.+ -> Maybe MD5Info -- ^ The MD5 checksum.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to put the object and return the response header.+putEncryptedObjectUsingManager = putEncryptedObjectImpl . putObjectUsingManager+++putEncryptedObjectImpl ::+ (String -> StorageAcl -> String -> String -> Maybe String -> ByteString -> Maybe (String, String) -> AccessToken -> IO [(String, String)]) -- ^ Function for putting an object.+ -> [Recipient] -- ^ The recipients for GnuPG encryption of the uploaded files.+ -> ProjectId -- ^ The project ID.+ -> StorageAcl -- ^ The pre-defined access control.+ -> BucketName -- ^ The bucket.+ -> KeyName -- ^ The object's key.+ -> Maybe MIMEType -- ^ The object's MIME type.+ -> ByteString -- ^ The object's data.+ -> Maybe MD5Info -- ^ The MD5 checksum.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to put the object and return the response header.+putEncryptedObjectImpl putter recipients projectId acl bucket key _ bytes _ accessToken =+ do+ bytes' <- encryptLbs recipients bytes+ putter projectId acl bucket key (Just "application/pgp-encrypted") bytes' Nothing accessToken
+ src/Network/Google/Storage/Sync.hs view
@@ -0,0 +1,353 @@+-----------------------------------------------------------------------------+--+-- Module : Network.Google.Storage.Sync+-- Copyright : (c) 2012-13 Brian W Bush+-- License : MIT+--+-- Maintainer : Brian W Bush <b.w.bush@acm.org>+-- Stability : Stable+-- Portability : POSIX+--+-- | Synchronization of filesystem directories with Google Storage buckets.+--+-----------------------------------------------------------------------------+++{-# LANGUAGE BangPatterns #-}+++module Network.Google.Storage.Sync (+ RegexExclusion+, sync+) where+++import Control.Exception (SomeException, finally, handle)+import Control.Monad (filterM, liftM)+import Crypto.GnuPG (Recipient)+import Crypto.MD5 (MD5Info, md5Base64)+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.Time.Clock (UTCTime, addUTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Time.Format (parseTime)+import Network.Google (AccessToken, ProjectId, toAccessToken)+import Network.Google.OAuth2 (OAuth2Client(..), OAuth2Tokens(..), refreshTokens, validateTokens)+import Network.Google.Storage (BucketName, KeyName, MIMEType, StorageAcl, deleteObjectUsingManager, getBucketUsingManager, putObjectUsingManager)+import Network.Google.Storage.Encrypted (putEncryptedObject, putEncryptedObjectUsingManager)+import Network.HTTP.Conduit (closeManager, def, newManager)+import System.Directory (doesDirectoryExist, getDirectoryContents)+import System.FilePath (pathSeparator)+import System.IO (hFlush, stdout)+import System.Locale (defaultTimeLocale)+import System.Posix.Files (fileSize, getFileStatus, modificationTime)+import Text.Regex.Posix ((=~))+import Text.XML.Light (Element, QName(qName), filterChildrenName, filterChildName, ppTopElement, strContent)+++-- | A regular expression used for excluding files from synchronization.+type RegexExclusion = String+++-- | Synchronize a filesystem directory with a Google Storage bucket.+sync ::+ ProjectId -- ^ The Google project ID.+ -> StorageAcl -- ^ The pre-defined access control.+ -> BucketName -- ^ The bucket name.+ -> OAuth2Client -- ^ The OAuth 2.0 client information.+ -> OAuth2Tokens -- ^ The OAuth 2.0 tokens.+ -> FilePath -- ^ The directory to be synchronized.+ -> [Recipient] -- ^ The recipients for GnuPG encryption of the uploaded files.+ -> [RegexExclusion] -- ^ The regular expressions used for excluding files from synchronization.+ -> Bool -- ^ Whether to write a file \".md5sum\" of MD5 sums of synchronized files into the root directory.+ -> Bool -- ^ Whether to delete keys from the bucket that do not correspond to files on the filesystem.+ -> IO () -- ^ The IO action for the synchronization.+sync projectId acl bucket client tokens directory recipients exclusions md5sums purge =+ do+ manager <- newManager def+ putStrLn $ "DIRECTORY " ++ directory+ putStrLn $ "PROJECT " ++ projectId+ putStrLn $ "BUCKET " ++ bucket+ putStrLn $ "ACCESS " ++ show acl+ finally+ (+ sync'+ (getBucketUsingManager manager projectId bucket)+ ((if null recipients then putObjectUsingManager manager else putEncryptedObjectUsingManager manager recipients) projectId acl bucket)+ (deleteObjectUsingManager manager projectId bucket)+ client tokens directory+ (null recipients)+ (makeExcluder exclusions)+ md5sums+ purge+ )(+ closeManager manager+ )+++-- | A function for listing a bucket.+type Lister =+ AccessToken -- ^ The OAuth 2.0 access token.+ -> IO Element -- ^ The action returning the XML with the metadata for the objects.+++-- | A function for putting an object into a bucket.+type Putter =+ KeyName -- ^ The object's key.+ -> Maybe MIMEType -- ^ The object's MIME type.+ -> LBS.ByteString -- ^ The object's data.+ -> Maybe MD5Info -- ^ The MD5 checksum.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to put the object and return the response header.+++-- | A function for deleting an object from a bucket.+type Deleter =+ KeyName -- ^ The object's key.+ -> AccessToken -- ^ The OAuth 2.0 access token.+ -> IO [(String, String)] -- ^ The action to put the object and return the response header.+++-- | A function for determining whether to exclude an object from synchronization.+type Excluder =+ ObjectMetadata -- ^ The object's metadata.+ -> Bool -- ^ Whether to exclude the object from synchronization.+++-- | An expiration time and the tokens which expire then.+type TokenClock = (UTCTime, OAuth2Tokens)+++-- | Check whether a token has expired and refresh it if necessary.+checkExpiration ::+ OAuth2Client -- ^ The OAuth 2.0 client information.+ -> TokenClock -- ^ The token and its expiration.+ -> IO TokenClock -- ^ The action to update the token and its expiration.+checkExpiration client (expirationTime, tokens) =+ do+ now <- getCurrentTime+ if now > expirationTime+ then+ do+ tokens' <- refreshTokens client tokens+ start <- getCurrentTime+ let+ expirationTime' = addUTCTime (fromRational (expiresIn tokens') - 60) start+ putStrLn $ "REFRESH " ++ show expirationTime'+ return (expirationTime', tokens')+ else+ return (expirationTime, tokens)+++-- | Make a function to exclude objects based on regular expressions for filenames.+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+++-- | Synchronize a filesystem directory with a Google Storage bucket.+sync' ::+ Lister -- ^ The bucket listing function.+ -> Putter -- ^ The object putting function.+ -> Deleter -- ^ The object deletion function.+ -> OAuth2Client -- ^ The OAuth 2.0 client information.+ -> OAuth2Tokens -- ^ The OAuth 2.0 tokens.+ -> FilePath -- ^ The directory to be synchronized.+ -> Bool -- ^ Whether to use ETags in comparing object metadata.+ -> Excluder -- ^ The function for excluding objects.+ -> Bool -- ^ Whether to write a file \".md5sum\" of MD5 sums of synchronized files into the root directory.+ -> Bool -- ^ Whether to delete keys from the bucket that do not correspond to files on the filesystem.+ -> IO () -- ^ The IO action for the synchronization.+sync' lister putter deleter client tokens directory byETag excluder md5sums purge =+ do+ putStr "LOCAL "+ hFlush stdout+ local <- walkDirectories directory+ putStrLn $ show $ length local+ now <- getCurrentTime+ tokenClock@(_, tokens') <- checkExpiration client (addUTCTime (-60) now, tokens)+ putStr "REMOTE "+ hFlush stdout+ remote' <- lister $ toAccessToken $ accessToken tokens'+ let+ remote = parseMetadata remote'+ putStrLn $ show $ length remote+ let+ tolerance = 300+ sameKey :: ObjectMetadata -> ObjectMetadata -> Bool+ sameKey (ObjectMetadata key _ _ _) (ObjectMetadata key' _ _ _) = key == key'+ sameETag :: ObjectMetadata -> ObjectMetadata -> Bool+ sameETag (ObjectMetadata key eTag _ _) (ObjectMetadata key' eTag' _ _) = key == key' && fst eTag == fst eTag'+ earlierTime :: ObjectMetadata -> ObjectMetadata -> Bool+ earlierTime (ObjectMetadata key _ _ time) (ObjectMetadata key' eTag' _ time') = key == key' && time > (addUTCTime tolerance time')+ putStr $ "EXCLUDED "+ hFlush stdout+ let+ local' = filter excluder local+ putStrLn $ show (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 "+ hFlush stdout+ let+ deletedObjects = deleteFirstsBy sameKey remote local'+ putStrLn $ show (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 ()+++-- | Put a list of objects.+walkPutter ::+ OAuth2Client -- ^ The OAuth 2.0 client information.+ -> TokenClock -- ^ The token and its expiration.+ -> FilePath -- ^ The directory to be synchronized.+ -> Putter -- ^ The object putting function.+ -> [ObjectMetadata] -- ^ Description of the objects to be put.+ -> IO TokenClock -- ^ The action to update the token and its expiration.+walkPutter _ tokenClock _ _ [] = return tokenClock+walkPutter client tokenClock directory putter (x : xs) =+ do+ let+ key' = key x+ tokenClock'@(_, tokens') <- checkExpiration client tokenClock+ putStrLn $ "PUT " ++ key'+ handle+ handler+ (+ do+ bytes <- LBS.readFile $ directory ++ [pathSeparator] ++ key'+ putter key' Nothing bytes (Just $ eTag x) (toAccessToken $ accessToken tokens')+ return ()+ )+ walkPutter client tokenClock' directory putter xs+++-- | Delete a list of objects.+walkDeleter ::+ OAuth2Client -- ^ The OAuth 2.0 client information.+ -> TokenClock -- ^ The token and its expiration.+ -> Deleter -- ^ The object deletion function.+ -> [ObjectMetadata] -- ^ Description of the objects to be deleted.+ -> IO TokenClock -- ^ The action to update the token and its expiration.+walkDeleter _ tokenClock _ [] = return tokenClock+walkDeleter client tokenClock deleter (x : xs) =+ do+ let+ key' = key x+ tokenClock'@(_, tokens') <- checkExpiration client tokenClock+ putStrLn $ "DELETE " ++ key'+ handle+ handler+ (+ do+ deleter key' (toAccessToken $ accessToken tokens')+ return ()+ )+ walkDeleter client tokenClock' deleter xs+++-- |+handler :: SomeException -> IO ()+handler exception = putStrLn $ " FAIL " ++ show exception+++-- | Object metadata.+data ObjectMetadata = ObjectMetadata+ {+ key :: String -- ^ The object's key.+ , eTag :: MD5Info -- ^ The object's MD5 sum.+ , size :: Int -- ^ The object's size, in bytes.+ , lastModified :: UTCTime -- ^ The object's modification time.+ }+ deriving (Show)+++-- | Parse XML metadata into object descriptions.+parseMetadata ::+ Element -- ^ The XML metadata.+ -> [ObjectMetadata] -- ^ The object descriptions.+parseMetadata root =+ let+ makeMetadata :: Element -> Maybe ObjectMetadata+ makeMetadata element =+ do+ let+ finder :: String -> Element -> Maybe String+ finder name = liftM strContent . filterChildName ((name ==) . qName)+ key <- finder "Key" element+ eTag <- finder "ETag" element+ size <- finder "Size" element+ 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+++-- | Gather file metadata from the file system.+walkDirectories ::+ FilePath -- ^ The directory to be synchronized.+ -> IO [ObjectMetadata] -- ^ Action returning file descriptions.+walkDirectories directory = walkDirectories' (directory ++ [pathSeparator]) [""]+++-- | Gather file metadata from the file system.+walkDirectories' ::+ FilePath -- ^ The directory to be synchronized.+ -> [FilePath] -- ^ The subdirectories still remaining to be described.+ -> IO [ObjectMetadata] -- ^ Action returning file descriptions.+walkDirectories' _ [] = return []+walkDirectories' directory (y : ys) =+ handle+ ((+ \exception ->+ do+ putStrLn $ " LIST " ++ y+ putStrLn $ " FAIL " ++ show exception+ walkDirectories' directory ys+ ) :: SomeException -> IO [ObjectMetadata])+ (+ do+ let+ makeMetadata :: FilePath -> IO ObjectMetadata+ makeMetadata file =+ do+ let+ key = tail file+ path = directory ++ key+ bytes <- LBS.readFile path+ status <- getFileStatus path+ let+ lastTime :: UTCTime+ lastTime = posixSecondsToUTCTime $ realToFrac $ modificationTime status+ size :: Int+ size = fromIntegral $ fileSize status+ let !eTag = md5Base64 bytes+ let !x = fst eTag+ let !y = snd eTag+ return $ ObjectMetadata key eTag size lastTime+ files <- liftM (map ((y ++ [pathSeparator]) ++))+ $ liftM ( \\ [".", ".."])+ $ getDirectoryContents (directory ++ y)+ y' <- filterM (doesDirectoryExist . (directory ++)) files+ x' <- mapM makeMetadata $ files \\ y'+ liftM (x' ++) $ walkDirectories' directory (y' ++ ys)+ )