{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- -- Module : Network.Google.FusionTables -- Copyright : (c) 2013 Ryan Newton -- License : MIT -- -- Maintainer : Ryan Newton -- Stability : Stable -- Portability : Portable -- -- | Functions for accessing the Fusion Tables API, see -- . -- -- This provides a very limited subset of the complete (v1) API at present. ----------------------------------------------------------------------------- module Network.Google.FusionTables ( -- * Types TableId, TableMetadata(..), ColumnMetadata(..), CellType(..) -- * One-to-one wrappers around API routines, with parsing of JSON results , createTable, createColumn , listTables, listColumns -- , sqlQuery -- * Higher level interface to common SQL queries , insertRows -- , filterRows , bulkImportRows ) where import Control.Monad (liftM, unless) import Data.Maybe (mapMaybe) import Data.List as L import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL import Network.Google (AccessToken, ProjectId, doRequest, makeRequest, appendBody, appendHeaders) import Network.HTTP.Conduit (Request(..), RequestBody(..),parseUrl) import qualified Network.HTTP as H import Text.XML.Light (Element(elContent), QName(..), filterChildrenName, findChild, strContent) -- TODO: Ideally this dependency wouldn't exist here and the user could select their -- own JSON parsing lib (e.g. Aeson). import Text.JSON (JSObject(..), JSValue(..), Result(Ok,Error), decode, valFromObj, toJSObject, toJSString, fromJSString) import Text.JSON.Pretty (pp_value) -- For easy pretty printing: import Text.PrettyPrint.GenericPretty (Out(doc,docPrec), Generic) import Text.PrettyPrint.HughesPJ (text, render) import Text.Printf (printf) -------------------------------------------------------------------------------- -- Haskell Types corresponding to JSON responses -- This could include non-ASCII characters: -- TODO: Use Data.Text -- type FTString = B.ByteString type FTString = String -- | An incomplete representation of data TableMetadata = TableMetadata { tab_name :: FTString , tab_tableId :: FTString , tab_columns :: [ColumnMetadata] } deriving (Eq, Show, Read, Ord, Generic) data ColumnMetadata = ColumnMetadata { col_columnId :: Int , col_name :: FTString , col_type :: FTString } deriving (Eq, Show, Read, Ord, Generic) -- TODO: Use Data.Aeson.TH instance Out TableMetadata instance Out ColumnMetadata -- instance Out B.ByteString where docPrec _ = text . B.unpack; doc = docPrec 0 -- | ID for a specific fusion table type TableId = FTString -------------------------------------------------------------------------------- -- | The host for API access. fusiontableHost :: String -- fusiontableHost = "https://www.googleapis.com/fusiontables/v1" fusiontableHost = "www.googleapis.com" -- | The API version used here. fusiontableApi :: (String, String) -- FIXME: This is meaningless because we're using the new discovery-based API, *NOT* -- the old GData APIs. fusiontableApi = ("Gdata-version", "999") -- | Create an (exportable) table with a given name and list of columns. createTable :: AccessToken -> String -> [(FTString,CellType)] -> IO TableMetadata createTable tok name cols = do response <- doRequest req let Ok final = parseTable response return final where req = appendHeaders [("Content-Type", "application/json")] $ appendBody (BL.pack json) (makeRequest tok fusiontableApi "POST" (fusiontableHost, "fusiontables/v1/tables" )) json :: String json = render$ pp_value$ JSObject$ toJSObject$ [ ("name",str name) , ("isExportable", JSBool True) , ("columns", colsJS) ] colsJS = JSArray (map fn cols) fn (colName, colTy) = JSObject$ toJSObject [ ("name", str colName) , ("kind", str "fusiontables#column") , ("type", str$ show colTy) ] str = JSString . toJSString -- | Create a new column in a given table. Returns the metadata for the new column. createColumn :: AccessToken -> TableId -> (FTString,CellType) -> IO ColumnMetadata createColumn tok tab_tableId (colName,colTy) = do response <- doRequest req let Ok final = parseColumn response return final where req = appendHeaders [("Content-Type", "application/json")] $ appendBody (BL.pack json) (makeRequest tok fusiontableApi "POST" (fusiontableHost, "fusiontables/v1/tables/"++tab_tableId++"/columns" )) json :: String json = render$ pp_value$ JSObject$ toJSObject$ [ ("name",str colName) , ("type",str$ show colTy) ] str = JSString . toJSString -- | Designed to mirror the types listed here: -- data CellType = NUMBER | STRING | LOCATION | DATETIME deriving (Show,Eq,Ord,Read) -- | List all tables belonging to a user. -- See . listTables :: AccessToken -- ^ The OAuth 2.0 access token. -> IO [TableMetadata] listTables accessToken = do resp <- doRequest req case parseTables resp of Ok x -> return x Error err -> error$ "listTables: failed to parse JSON response, error was:\n " ++err++"\nJSON response was:\n "++show resp where req = makeRequest accessToken fusiontableApi "GET" ( fusiontableHost, "fusiontables/v1/tables" ) -- | Construct a simple Haskell representation of the result of `listTables`. parseTables :: JSValue -> Result [TableMetadata] parseTables (JSObject ob) = do JSArray allTables <- valFromObj "items" ob mapM parseTable allTables parseTable :: JSValue -> Result TableMetadata parseTable (JSObject ob) = do tab_name <- valFromObj "name" ob tab_tableId <- valFromObj "tableId" ob tab_columns <- mapM parseColumn =<< valFromObj "columns" ob return TableMetadata {tab_name, tab_tableId, tab_columns} parseTable oth = Error$ "parseTable: Expected JSObject, got "++show oth parseColumn :: JSValue -> Result ColumnMetadata parseColumn (JSObject ob) = do col_name <- valFromObj "name" ob col_columnId <- valFromObj "columnId" ob col_type <- valFromObj "type" ob return ColumnMetadata {col_name, col_type, col_columnId} parseColumn oth = Error$ "parseColumn: Expected JSObject, got "++show oth -- | List the columns within a specific table. -- See . listColumns :: AccessToken -- ^ The OAuth 2.0 access token. -> TableId -- ^ which table -> IO [ColumnMetadata] listColumns accessToken tid = do resp <- doRequest req case parseColumns resp of Ok x -> return x Error err -> error$ "listColumns: failed to parse JSON response:\n"++err where req = makeRequest accessToken fusiontableApi "GET" ( fusiontableHost, "fusiontables/v1/tables/"++tid++"/columns" ) -- | Parse the output of `listColumns`. parseColumns :: JSValue -> Result [ColumnMetadata] parseColumns (JSObject ob) = do JSArray cols <- valFromObj "items" ob mapM parseColumn cols -------------------------------------------------------------------------------- sqlQuery = error "sqlQuery" -- | Insert one or more rows into a table. Rows are represented as lists of strings. -- The columns being written are passed in as a separate list. The length of all -- rows must match eachother and must match the list of column names. -- -- NOTE: this method has a major limitation. SQL queries are encoded into the URL, -- and it is very easy to exceed the maximum URL length accepted by Google APIs. insertRows :: AccessToken -> TableId -> [FTString] -- ^ Which columns to write. -> [[FTString]] -- ^ Rows -> IO () insertRows tok tid cols rows = doRequest req where req = (makeRequest tok fusiontableApi "POST" (fusiontableHost, "fusiontables/v1/query" )) { queryString = B.pack$ H.urlEncodeVars [("sql",query)] } query = concat $ L.intersperse ";\n" $ map (("INSERT INTO "++tid++" "++ colstr ++" VALUES ")++) vals numcols = length cols colstr = parens$ concat$ L.intersperse ", " cols vals = map fn rows fn row = if length row == numcols then parens$ concat$ L.intersperse ", " $ map singQuote row else error$ "insertRows: got a row with an incorrect number of arguments, expected " ++ show numcols ++": "++ show row parens s = "(" ++ s ++ ")" singQuote x = "'"++x++"'" -- | Implement a larger quantity of rows, but with the caveat that the number and order -- of columns must exactly match the schema of the fusion table on the server. -- `bulkImportRows` will perform a listing of the columns to verify this before uploading. -- -- This function also checks that the server reports receiving the same number of -- rows as were uploaded. -- -- NOTE: also use this function for LONG rows, even if there is only one. Really, -- you should almost always use this function rather thna `insertRows`. bulkImportRows :: AccessToken -> TableId -> [FTString] -- ^ Which columns to write. -> [[FTString]] -- ^ Rows -> IO () bulkImportRows tok tid cols rows = do targetSchema <- fmap (map col_name) $ listColumns tok tid unless (targetSchema == cols) $ error$ "bulkImportRows: upload schema (1) did not match server side schema (2):\n (1) "++ show cols ++"\n (2) " ++ show targetSchema let csv = unlines rowlns -- (header : rowlns) -- ARGH, they don't accept the header. -- All sanity checking must be client side [2013.11.30]. -- header = concat$ intersperse "," $ map show cols rowlns = [ concat$ intersperse "," [ "\"" ++f++"\"" | f <- row ] | row <- rows ] req = appendBody (BL.pack csv) $ (makeRequest tok fusiontableApi "POST" (fusiontableHost, "upload/fusiontables/v1/tables/"++tid++"/import" )) { queryString = B.pack $ H.urlEncodeVars [("isStrict", "true")] } resp <- doRequest req let Ok received = parseResponse resp unless (received == length rows) $ error$ "attempted to upload "++show (length rows)++ " rows, but "++show received++" received by server." return () where parseResponse :: JSValue -> Result Int parseResponse (JSObject ob) = do -- JS allTables <- valFromObj "items" ob -- JSString "fusiontables#import" <- valFromObj "kind" ob -- Sanity check. JSString num <- valFromObj "numRowsReceived" ob return$ read$ fromJSString num -- TODO: provide some basic select functionality filterRows = error "implement filterRows"