module Network.TableStorage.API (
queryTables, createTable, createTableIfNecessary, deleteTable,
insertEntity, updateEntity, mergeEntity, deleteEntity,
queryEntity, queryEntities, defaultEntityQuery,
defaultAccount
) where
import Network.HTTP
( HeaderName(HdrCustom),
Header(Header),
RequestMethod(Custom, DELETE, GET, POST, PUT),
Response_String )
import Text.XML.Light
( Element(elName),
QName(qName, qURI),
showTopElement,
filterChildren,
findAttr,
findChild,
findChildren,
strContent )
import Network.TableStorage.Types
( EntityQuery(..),
Entity(..),
EntityColumn(EdmDateTime, EdmString),
EntityKey(..),
Account(..),
AccountKey )
import Network.TableStorage.Auth ( authenticatedRequest )
import Network.TableStorage.Request
( propertyList, entityKeyResource, buildQueryString )
import Network.TableStorage.Response
( parseEmptyResponse, parseXmlResponseOrError, parseEntityColumn )
import Network.TableStorage.Atom
( dataServicesNamespace,
qualifyAtom,
qualifyDataServices,
qualifyMetadata,
wrapContent )
import Control.Monad ( (>=>), unless )
import Control.Monad.Error ( ErrorT(..) )
import Data.Time.Clock ( getCurrentTime )
import Data.Maybe ( fromMaybe )
parseQueryTablesResponse :: Response_String -> Either String [String]
parseQueryTablesResponse = parseXmlResponseOrError (2, 0, 0) readTables where
readTables :: Element -> Maybe [String]
readTables feed = sequence $ do
entry <- findChildren (qualifyAtom "entry") feed
return $ readTableName entry
readTableName =
findChild (qualifyAtom "content")
>=> findChild (qualifyMetadata "properties")
>=> findChild (qualifyDataServices "TableName")
>=> return . strContent
queryTables :: Account -> IO (Either String [String])
queryTables acc = do
let resource = "/Tables"
response <- authenticatedRequest acc GET [] resource resource ""
return $ response >>= parseQueryTablesResponse
createTableXml :: String -> IO Element
createTableXml tableName = wrapContent $ propertyList [("TableName", EdmString $ Just tableName)]
createTable :: Account -> String -> IO (Either String ())
createTable acc tableName = do
let resource = "/Tables"
requestXml <- createTableXml tableName
response <- authenticatedRequest acc POST [] resource resource $ showTopElement requestXml
return $ response >>= parseEmptyResponse (2, 0, 1)
createTableIfNecessary :: Account -> String -> IO (Either String ())
createTableIfNecessary acc tableName = runErrorT $ do
tables <- ErrorT $ queryTables acc
unless (tableName `elem` tables) $ ErrorT $ createTable acc tableName
deleteTable :: Account -> String -> IO (Either String ())
deleteTable acc tableName = do
let resource = "/Tables('" ++ tableName ++ "')"
response <- authenticatedRequest acc DELETE [] resource resource ""
return $ response >>= parseEmptyResponse (2, 0, 4)
createInsertEntityXml :: Entity -> IO Element
createInsertEntityXml entity = do
time <- getCurrentTime
wrapContent $ propertyList $ [
("PartitionKey", EdmString $ Just $ ekPartitionKey $ entityKey entity),
("RowKey", EdmString $ Just $ ekRowKey $ entityKey entity),
("Timestamp", EdmDateTime $ Just time)
] ++ entityColumns entity
insertEntity :: Account -> String -> Entity -> IO (Either String ())
insertEntity acc tableName entity = do
let resource = '/' : tableName
requestXml <- createInsertEntityXml entity
response <- authenticatedRequest acc POST [] resource resource $ showTopElement requestXml
return $ response >>= parseEmptyResponse (2, 0, 1)
updateOrMergeEntity :: RequestMethod -> Account -> String -> Entity -> IO (Either String ())
updateOrMergeEntity method acc tableName entity = do
let resource = entityKeyResource tableName $ entityKey entity
let additionalHeaders = [ Header (HdrCustom "If-Match") "*" ]
requestXml <- createInsertEntityXml entity
response <- authenticatedRequest acc method additionalHeaders resource resource $ showTopElement requestXml
return $ response >>= parseEmptyResponse (2, 0, 4)
updateEntity :: Account -> String -> Entity -> IO (Either String ())
updateEntity = updateOrMergeEntity PUT
mergeEntity :: Account -> String -> Entity -> IO (Either String ())
mergeEntity = updateOrMergeEntity (Custom "MERGE")
deleteEntity :: Account -> String -> EntityKey -> IO (Either String ())
deleteEntity acc tableName key = do
let resource = entityKeyResource tableName key
let additionalHeaders = [ Header (HdrCustom "If-Match") "*" ]
response <- authenticatedRequest acc DELETE additionalHeaders resource resource ""
return $ response >>= parseEmptyResponse (2, 0, 4)
readEntity :: Element -> Maybe Entity
readEntity entry = do
properties <-
findChild (qualifyAtom "content")
>=> findChild (qualifyMetadata "properties")
$ entry
partitionKey <- findChild (qualifyDataServices "PartitionKey") properties
rowKey <- findChild (qualifyDataServices "RowKey") properties
let columnData = filterChildren filterProperties properties
columns <- mapM elementToColumn columnData
return Entity { entityKey = EntityKey { ekPartitionKey = strContent partitionKey,
ekRowKey = strContent rowKey },
entityColumns = columns } where
filterProperties el | elName el == qualifyDataServices "PartitionKey" = False
| elName el == qualifyDataServices "RowKey" = False
| otherwise = qURI (elName el) == Just dataServicesNamespace
elementToColumn el =
let propertyName = qName $ elName el in
let typeAttr = fromMaybe "Edm.String" $ findAttr (qualifyMetadata "type") el in
let typeNull = maybe False ("true" ==) $ findAttr (qualifyMetadata "null") el in
(\val -> (propertyName, val)) `fmap` parseEntityColumn typeNull typeAttr (strContent el)
parseQueryEntityResponse :: Response_String -> Either String Entity
parseQueryEntityResponse = parseXmlResponseOrError (2, 0, 0) readEntity where
queryEntity :: Account -> String -> EntityKey -> IO (Either String Entity)
queryEntity acc tableName key = do
let resource = entityKeyResource tableName key
response <- authenticatedRequest acc GET [] resource resource ""
return $ response >>= parseQueryEntityResponse
parseQueryEntitiesResponse :: Response_String -> Either String [Entity]
parseQueryEntitiesResponse = parseXmlResponseOrError (2, 0, 0) readEntities where
readEntities :: Element -> Maybe [Entity]
readEntities feed = sequence $ do
entry <- findChildren (qualifyAtom "entry") feed
return $ readEntity entry
queryEntities :: Account -> String -> EntityQuery -> IO (Either String [Entity])
queryEntities acc tableName query = do
let canonicalizedResource = '/' : tableName ++ "()"
let queryString = buildQueryString query
let resource = canonicalizedResource ++ '?' : queryString
response <- authenticatedRequest acc GET [] resource canonicalizedResource ""
return $ response >>= parseQueryEntitiesResponse
defaultEntityQuery :: EntityQuery
defaultEntityQuery = EntityQuery { eqPageSize = Nothing,
eqFilter = Nothing }
defaultAccount :: AccountKey -> String -> String -> Account
defaultAccount key name hostname = Account { accountScheme = "http",
accountHost = hostname,
accountPort = 80,
accountKey = key,
accountName = name,
accountResourcePrefix = "" }