diff --git a/handa-gdata.cabal b/handa-gdata.cabal --- a/handa-gdata.cabal +++ b/handa-gdata.cabal @@ -1,11 +1,14 @@ name: handa-gdata -version: 0.6.9.1 +version: 0.7 cabal-version: >=1.6 -- CHANGELOG: -- 0.6.2: Improve getCachedTokens -- 0.6.8: Add FusionTables.bulkImportRows -- 0.6.9: Add FusionTables.createColumn +-- 0.6.9.2: Add FusionTables.tableSelect +-- 0.6.9.3: tableSQLQuery +-- 0.7: change the API for http-conduit 2.0+ support build-type: Simple license: MIT @@ -77,8 +80,10 @@ data-dir: "" source-repository head - type: mercurial - location: https://code.google.com/p/hgdata/ +-- type: mercurial +-- location: https://code.google.com/p/hgdata/ + type: git + location: https://github.com/rrnewton/hgdata library build-depends: base >= 4 && < 5 @@ -86,11 +91,13 @@ , binary >= 0.5.1.1 , bytestring >= 0.10.0.2 , case-insensitive >= 0.2 + , data-default -any , directory -any , filepath -any , GenericPretty >= 1.0.0 , HTTP >= 4000.2.5 - , http-conduit >= 1.9.0 && < 2.0 + , http-conduit >= 2 + , network == 2.5.0.0 , json >= 0.5 , old-locale -any , pretty -any @@ -98,7 +105,7 @@ , pureMD5 >= 2.1.2.1 , random -any , regex-posix >= 0.95.2 - , resourcet >= 0.3 + , resourcet >= 1.1.3 , split >= 0.2.0.0 , time -any , unix-compat -any @@ -131,16 +138,16 @@ , cmdargs >= 0.9.4 , GenericPretty >= 1.0.0 , HTTP >= 4000.2.5 - , http-conduit >= 1.9.0 && < 2.0 + , http-conduit >= 2 , json >= 0.5 - , network -any + , network == 2.5.0.0 , old-locale -any , pretty -any , process >= 1.1.0.2 , pureMD5 >= 2.1.2.1 , random -any , regex-posix >= 0.95.2 - , resourcet >= 0.3 + , resourcet >= 1.1.3 , split >= 0.2.0.0 , time -any , unix-compat -any diff --git a/src/Network/Google.hs b/src/Network/Google.hs --- a/src/Network/Google.hs +++ b/src/Network/Google.hs @@ -38,6 +38,7 @@ import qualified Control.Exception as E import Control.Concurrent (threadDelay) import Control.Monad.Trans.Resource (ResourceT, runResourceT) +import Data.Default import Data.List (intercalate) import Data.Maybe (fromJust) import Data.ByteString as BS (ByteString) @@ -46,8 +47,8 @@ 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(..), HttpException, - closeManager, def, httpLbs, newManager, responseBody) +import Network.HTTP.Conduit (Manager, ManagerSettings, mkManagerSettings, Request(..), RequestBody(..), Response(..), HttpException, + closeManager, httpLbs, newManager, responseBody) import Text.JSON (JSValue, Result(Ok), decode) import Text.XML.Light (Element, parseXMLDoc) @@ -72,7 +73,7 @@ -> (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. + -> Request -- ^ The HTTP request. makeRequest accessToken (apiName, apiVersion) method (host, path) = -- TODO: In principle, we should UTF-8 encode the bytestrings packed below. def { @@ -95,7 +96,7 @@ -> (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. + -> Request -- ^ The HTTP request. makeProjectRequest projectId accessToken api method hostPath = appendHeaders [ @@ -108,17 +109,17 @@ class DoRequest a where -- | Perform a request. doRequest :: - Request (ResourceT IO) -- ^ The request. + Request -- ^ The request. -> IO a -- ^ The action returning the result of performing the request. doRequest request = do - manager <- newManager def + manager <- newManager (mkManagerSettings def Nothing) E.finally (doManagedRequest manager request) (closeManager manager) doManagedRequest :: Manager -- ^ The conduit HTTP manager. - -> Request (ResourceT IO) -- ^ The request. + -> Request -- ^ The request. -> IO a -- ^ The action returning the result of performing the request. @@ -193,8 +194,8 @@ -- | 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. + -> Request -- ^ The request. + -> Request -- ^ The request with the additional headers. appendHeaders headers request = let headerize :: (String, String) -> (CI.CI BS8.ByteString, BS8.ByteString) @@ -208,8 +209,8 @@ -- | 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. + -> Request -- ^ The request. + -> Request -- ^ The request with the body appended. appendBody bytes request = request { requestBody = RequestBodyLBS bytes @@ -219,8 +220,8 @@ -- | 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. + -> Request -- ^ The request. + -> Request -- ^ The request with the query appended. appendQuery query request = let makeParameter :: (String, String) -> String diff --git a/src/Network/Google/Bookmarks.hs b/src/Network/Google/Bookmarks.hs --- a/src/Network/Google/Bookmarks.hs +++ b/src/Network/Google/Bookmarks.hs @@ -27,10 +27,11 @@ 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.Default (def) import Data.Maybe (fromJust) import Data.Time.Clock (getCurrentTime) import Network.Google (appendHeaders) -import Network.HTTP.Conduit (CookieJar, Request(..), RequestBody(..), Response(..), def, httpLbs, parseUrl, withManager) +import Network.HTTP.Conduit (CookieJar, Request(..), RequestBody(..), Response(..), httpLbs, parseUrl, withManager) import Text.XML.Light (Element(..), QName(..), blank_name, filterElement, findAttr, parseXMLDoc) @@ -112,7 +113,7 @@ return $ responseXml responsePost3 -accountsPostRequest :: String -> Request m +accountsPostRequest :: String -> Request accountsPostRequest path = appendHeaders [("Content-Type", "application/x-www-form-urlencoded")] $ def { diff --git a/src/Network/Google/Books.hs b/src/Network/Google/Books.hs --- a/src/Network/Google/Books.hs +++ b/src/Network/Google/Books.hs @@ -156,7 +156,7 @@ AccessToken -- ^ The OAuth 2.0 access token. -> Maybe ShelfId -- ^ The bookshelf ID. -> Int -- ^ The starting index - -> Request m -- ^ The request. + -> Request -- ^ The request. booksRequest accessToken shelf startIndex = appendQuery [ diff --git a/src/Network/Google/Contacts.hs b/src/Network/Google/Contacts.hs --- a/src/Network/Google/Contacts.hs +++ b/src/Network/Google/Contacts.hs @@ -22,10 +22,11 @@ import Control.Monad ((<=<), (>>), liftM) import Crypto.GnuPG (Recipient, decrypt, encrypt) +import Data.Default (def) import Data.List (stripPrefix) import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Network.Google (AccessToken, doRequest, makeRequest, makeRequestValue) -import Network.HTTP.Conduit (Request(..), def, httpLbs, responseBody, withManager) +import Network.HTTP.Conduit (Request(..), httpLbs, responseBody, withManager) import Text.XML.Light (Element, elChildren, filterChildName, parseXMLDoc, qName, strContent) @@ -53,7 +54,7 @@ -- | Make an HTTP request to list the contacts. listContactsRequest :: AccessToken -- ^ The OAuth 2.0 access token. - -> Request m -- ^ The request. + -> Request -- ^ The request. listContactsRequest accessToken = (makeRequest accessToken contactsApi "GET" (contactsHost, "/m8/feeds/contacts/default/full/")) { diff --git a/src/Network/Google/FusionTables.hs b/src/Network/Google/FusionTables.hs --- a/src/Network/Google/FusionTables.hs +++ b/src/Network/Google/FusionTables.hs @@ -30,6 +30,11 @@ , insertRows -- , filterRows , bulkImportRows + + -- js experimentation + , getData, ColData(..), FTValue(..), tableSelect + , tableSQLQuery + ) where import Control.Monad (liftM, unless) @@ -45,7 +50,7 @@ -- TODO: Ideally this dependency wouldn't exist here and the user could select their -- own JSON parsing lib (e.g. Aeson). import Text.JSON (JSObject(..), JSValue(..), Result(Ok,Error), - decode, valFromObj, toJSObject, toJSString, fromJSString) + decode, valFromObj, toJSObject, toJSString, fromJSString,readJSON) import Text.JSON.Pretty (pp_value) -- For easy pretty printing: @@ -286,3 +291,112 @@ -- TODO: provide some basic select functionality filterRows = error "implement filterRows" + +--getData :: AccessToken +-- -> String +-- -> String +-- -> Request m + +getData :: AccessToken + -> String -- ^ Table ID + -> String -- ^ The SQL expression following "SELECT" + -> Maybe String -- ^ Optional expression to follow "WHERE" + -> IO ColData +getData = tableSelect + +-- tableSelect token table_id str cond +-- = let req = (makeRequest token fusiontableApi "GET" +-- (fusiontableHost, "/fusiontables/v1/query")) +-- { +-- queryString = B.pack$ H.urlEncodeVars [("sql",query)] +-- } +-- query = case cond of +-- Nothing -> "SELECT " ++ str ++ " FROM " ++ table_id +-- Just c -> "SELECT " ++ str ++ " FROM " ++ table_id ++ " WHERE " ++ c +-- in do resp <- doRequest req +-- case parseResponse resp of +-- Ok x -> return x +-- Error err -> error$ "getData: failed to parse JSON response:\n"++err +-- where +-- parseResponse :: JSValue -> Result ColData +-- parseResponse (JSArray as) = Error "GOT ARRAY EARLY" +-- parseResponse (JSObject ob) = do +-- -- get array of column names (headings) +-- (JSArray cols) <- valFromObj "columns" ob +-- let colNom = map (\(JSString s) -> fromJSString s) cols +-- -- Get array of array of data values +-- (JSArray rows) <- valFromObj "rows" ob +-- rows' <- mapM parseVal' rows +-- return $ ColData colNom rows' +-- parseVal' (JSArray ar) = mapM parseVal ar +-- parseVal :: JSValue -> Result FTValue +-- parseVal r@(JSRational _ _) = do +-- d <- readJSON r +-- return $ DoubleValue d +-- parseVal (JSString s) = return $ StringValue $ fromJSString s + +-- parseVal _ = Error "I imagined there'd be Rationals here" + +-- Leave this here for backwards compat +tableSelect :: AccessToken + -> String -- ^ Table ID + -> String -- ^ The SQL expression following "SELECT" + -> Maybe String -- ^ Optional expression to follow "WHERE" + -> IO ColData +tableSelect token table_id str cond = + tableSQLQuery token table_id query + where + query = + case cond of + Nothing -> "SELECT " ++ str ++ " FROM " ++ table_id + Just c -> "SELECT " ++ str ++ " FROM " ++ table_id ++ " WHERE " ++ c + +-- | Run a supported SQL query to retrieve data from a fusion table. +tableSQLQuery :: AccessToken + -> String -- ^ Table ID + -> String -- ^ Complete SQL expression. + -> IO ColData +tableSQLQuery token table_id query + = let req = (makeRequest token fusiontableApi "GET" + (fusiontableHost, "/fusiontables/v1/query")) + { + queryString = B.pack$ H.urlEncodeVars [("sql",query)] + } + -- query = case cond of + -- Nothing -> "SELECT " ++ str ++ " FROM " ++ table_id + -- Just c -> "SELECT " ++ str ++ " FROM " ++ table_id ++ " WHERE " ++ c + in do resp <- doRequest req + case parseResponse resp of + Ok x -> return x + Error err -> error$ "getData: failed to parse JSON response:\n"++err + where + parseResponse :: JSValue -> Result ColData + parseResponse (JSArray as) = Error "GOT ARRAY EARLY" + parseResponse (JSObject ob) = do + -- get array of column names (headings) + (JSArray cols) <- valFromObj "columns" ob + let colNom = map (\(JSString s) -> fromJSString s) cols + -- Get array of array of data values + (JSArray rows) <- valFromObj "rows" ob + rows' <- mapM parseVal' rows + return $ ColData colNom rows' + parseVal' (JSArray ar) = mapM parseVal ar + parseVal :: JSValue -> Result FTValue + parseVal r@(JSRational _ _) = do + d <- readJSON r + return $ DoubleValue d + parseVal (JSString s) = return $ StringValue $ fromJSString s + + parseVal _ = Error "I imagined there'd be Rationals here" + + +data FTValue = StringValue FTString + | DoubleValue Double + deriving (Eq, Show ) + + + +data ColData = ColData {colName :: [FTString], + values :: [[FTValue]]} + deriving (Eq, Show) + diff --git a/src/Network/Google/OAuth2.hs b/src/Network/Google/OAuth2.hs --- a/src/Network/Google/OAuth2.hs +++ b/src/Network/Google/OAuth2.hs @@ -84,13 +84,14 @@ import Control.Monad (unless) import Data.ByteString.Char8 as BS8 (ByteString, pack) import Data.ByteString.Lazy.UTF8 (toString) +import Data.Default (def) import Data.List (intercalate) import Data.Time.Clock (getCurrentTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.Word (Word64) import Network.Google (makeHeaderName) import Network.HTTP.Base (urlEncode) -import Network.HTTP.Conduit (Request(..), RequestBody(..), Response(..), def, httpLbs, responseBody, withManager) +import Network.HTTP.Conduit (Request(..), RequestBody(..), Response(..), httpLbs, responseBody, withManager) import Text.JSON (JSObject, JSValue(JSRational), Result(Ok), decode, valFromObj) import System.Info (os) import System.Process (rawSystem) @@ -355,7 +356,8 @@ -- This is the part where we require user interaction: askUser = do putStrLn$ " [getCachedTokens] Load this URL: "++show permissionUrl - runBrowser + -- BJS: This crash on my machine. + -- runBrowser putStrLn " [getCachedTokens] Then please paste the verification code and press enter:\n$ " authcode <- getLine tokens <- exchangeCode client authcode diff --git a/src/Network/Google/Picasa.hs b/src/Network/Google/Picasa.hs --- a/src/Network/Google/Picasa.hs +++ b/src/Network/Google/Picasa.hs @@ -111,7 +111,7 @@ 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. + -> Request -- ^ The request. picasaFeedRequest accessToken userId albumId = makeRequest accessToken picasaApi "GET" ( diff --git a/src/Network/Google/Storage.hs b/src/Network/Google/Storage.hs --- a/src/Network/Google/Storage.hs +++ b/src/Network/Google/Storage.hs @@ -141,7 +141,7 @@ -- | List all of the buckets in a specified project. This performs the \"GET Service\" request, see . getServiceImpl :: - (Request (ResourceT IO) -> IO Element) -- ^ The function for performing the request. + (Request -> 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. @@ -175,7 +175,7 @@ -- | Creates a bucket in a specified project. This performs the \"PUT Bucket\" request, see . putBucketImpl :: - (Request (ResourceT IO) -> IO [(String, String)]) -- ^ The function for performing the request. + (Request -> IO [(String, String)]) -- ^ The function for performing the request. -> ProjectId -- ^ The project ID. -> StorageAcl -- ^ The pre-defined access control. -> BucketName -- ^ The bucket. @@ -213,7 +213,7 @@ -- | Lists the objects that are in a bucket. This performs the \"GET Bucket\" request, see . getBucketImpl :: - (Request (ResourceT IO) -> IO Element) -- ^ The function for performing the request. + (Request -> IO Element) -- ^ The function for performing the request. -> ProjectId -- ^ The project ID. -> BucketName -- ^ The bucket. -> AccessToken -- ^ The OAuth 2.0 access token. @@ -228,7 +228,7 @@ -- | Lists the objects that are in a bucket. This performs the \"GET Bucket\" request, see . getBucketImpl' :: - (Request (ResourceT IO) -> IO Element) -- ^ The function for performing the request. + (Request -> IO Element) -- ^ The function for performing the request. -> Maybe KeyName -- ^ The key to start listing at. -> ProjectId -- ^ The project ID. -> BucketName -- ^ The bucket. @@ -274,7 +274,7 @@ -- | Deletes an empty bucket. This performs the \"DELETE Bucket\" request, see . deleteBucketImpl :: - (Request (ResourceT IO) -> IO [(String, String)]) -- ^ The function for performing the request. + (Request -> IO [(String, String)]) -- ^ The function for performing the request. -> ProjectId -- ^ The project ID. -> BucketName -- ^ The bucket. -> AccessToken -- ^ The OAuth 2.0 access token. @@ -309,7 +309,7 @@ -- | Downloads an object. This performs the \"GET Object\" request, see . getObjectImpl :: - (Request (ResourceT IO) -> IO ByteString) -- ^ The function performing the action. + (Request -> IO ByteString) -- ^ The function performing the action. -> ProjectId -- ^ The project ID. -> BucketName -- ^ The bucket. -> KeyName -- ^ The object's key. @@ -357,7 +357,7 @@ -- | Uploads an object. This performs the \"PUT Object\" request, see . putObjectImpl :: - (Request (ResourceT IO) -> IO [(String, String)]) -- ^ The function for performing the request. + (Request -> IO [(String, String)]) -- ^ The function for performing the request. -> ProjectId -- ^ The project ID. -> StorageAcl -- ^ The pre-defined access control. -> BucketName -- ^ The bucket. @@ -407,7 +407,7 @@ -- | Lists metadata for an object. This performs the \"HEAD Object\" request, see . headObjectImpl :: - (Request (ResourceT IO) -> IO [(String, String)]) -- ^ The function for performing the request. + (Request -> IO [(String, String)]) -- ^ The function for performing the request. -> ProjectId -- ^ The project ID. -> BucketName -- ^ The bucket. -> KeyName -- ^ The object's key. @@ -443,7 +443,7 @@ -- | Deletes an object. This performs the \"DELETE Object\" request, see . deleteObjectImpl :: - (Request (ResourceT IO) -> IO [(String, String)]) -- ^ The function for performing the request. + (Request -> IO [(String, String)]) -- ^ The function for performing the request. -> ProjectId -- ^ The project ID. -> BucketName -- ^ The bucket. -> KeyName -- ^ The object's key. diff --git a/src/Network/Google/Storage/Sync.hs b/src/Network/Google/Storage/Sync.hs --- a/src/Network/Google/Storage/Sync.hs +++ b/src/Network/Google/Storage/Sync.hs @@ -27,6 +27,7 @@ import Crypto.GnuPG (Recipient) import Crypto.MD5 (MD5Info, md5Base64, md5Empty) import qualified Data.ByteString.Lazy as LBS (ByteString, readFile) +import Data.Default (def) import qualified Data.Digest.Pure.MD5 as MD5 (md5) import Data.List ((\\), sort) import Data.Maybe (catMaybes, fromJust, fromMaybe, mapMaybe) @@ -37,7 +38,7 @@ 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 Network.HTTP.Conduit (mkManagerSettings, closeManager, newManager) import System.Directory (doesDirectoryExist, getDirectoryContents) import System.FilePath (combine, splitDirectories) import System.FilePath.Posix (joinPath) @@ -82,7 +83,7 @@ let local' = filter (makeExcluder exclusions) local print $ length local - length local' - manager <- newManager def + manager <- newManager (mkManagerSettings def Nothing) finally ( sync'