module Network.TableStorage.API (
withTableStorage,
queryTables, createTable, createTableIfNecessary, deleteTable,
insertEntity, updateEntity, mergeEntity, deleteEntity,
queryEntity, queryEntities, defaultEntityQuery,
defaultAccount, defaultConf
) where
import Network.HTTP.Types
import Text.XML.Light
( Element(elName),
QName(qName, qURI),
showTopElement,
filterChildren,
findAttr,
findChild,
findChildren,
strContent )
import Network.TableStorage.Types
import Network.TableStorage.Auth
import Network.TableStorage.Request
import Network.TableStorage.Response
import Network.TableStorage.Atom
import Data.Time.Clock ( getCurrentTime )
import Data.Maybe ( fromMaybe )
import Control.Monad ( unless )
import Control.Monad.Reader
import Control.Monad.Error
withTableStorage :: TableConf -> TableStorage a -> IO (Either TableError a)
withTableStorage conf f = runReaderT (runErrorT f) conf
fromEither :: MonadError e m => Either e a -> m a
fromEither (Left e) = throwError e
fromEither (Right a) = return a
parseQueryTablesResponse :: QueryResponse -> Either TableError [String]
parseQueryTablesResponse = parseXmlResponseOrError status200 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 :: TableStorage [String]
queryTables = do
let resource = "/Tables"
response <- authenticatedRequest methodGet [] resource resource ""
fromEither $ parseQueryTablesResponse response
createTableXml :: String -> IO Element
createTableXml tableName = wrapContent Nothing $ propertyList [("TableName", EdmString $ Just tableName)]
createTable :: String -> TableStorage ()
createTable tableName = do
let resource = "/Tables"
requestXml <- liftIO $ createTableXml tableName
response <- authenticatedRequest methodPost [] resource resource $ showTopElement requestXml
fromEither $ parseEmptyResponse status201 response
createTableIfNecessary :: String -> TableStorage ()
createTableIfNecessary tableName = do
tables <- queryTables
unless (tableName `elem` tables) $ createTable tableName
deleteTable :: String -> TableStorage ()
deleteTable tableName = do
let resource = "/Tables('" ++ tableName ++ "')"
response <- authenticatedRequest methodDelete [] resource resource ""
fromEither $ parseEmptyResponse status204 response
createInsertEntityXml :: Entity -> Maybe String -> IO Element
createInsertEntityXml entity entityID = do
time <- getCurrentTime
wrapContent entityID $ propertyList $ [
("PartitionKey", EdmString $ Just $ ekPartitionKey $ entityKey entity),
("RowKey", EdmString $ Just $ ekRowKey $ entityKey entity),
("Timestamp", EdmDateTime $ Just time)
] ++ entityColumns entity
insertEntity :: String -> Entity -> TableStorage ()
insertEntity tableName entity = do
let resource = '/' : tableName
requestXml <- liftIO $ createInsertEntityXml entity Nothing
response <- authenticatedRequest methodPost [] resource resource $ showTopElement requestXml
fromEither $ parseEmptyResponse status201 response
updateOrMergeEntity :: Method -> String -> Entity -> TableStorage ()
updateOrMergeEntity method tableName entity = do
let resource = entityKeyResource tableName $ entityKey entity
let additionalHeaders = [ ("If-Match", "*") ]
acc <- fmap tableAccount ask
requestXml <- liftIO $ createInsertEntityXml entity (Just $
accountScheme acc ++ "://" ++ accountHost acc ++ resource)
response <- authenticatedRequest method additionalHeaders resource resource $ showTopElement requestXml
fromEither $ parseEmptyResponse status204 response
updateEntity :: String -> Entity -> TableStorage ()
updateEntity = updateOrMergeEntity methodPut
mergeEntity :: String -> Entity -> TableStorage ()
mergeEntity = updateOrMergeEntity "MERGE"
deleteEntity :: String -> EntityKey -> TableStorage ()
deleteEntity tableName key = do
let resource = entityKeyResource tableName key
let additionalHeaders = [ ("If-Match", "*") ]
response <- authenticatedRequest methodDelete additionalHeaders resource resource ""
fromEither $ parseEmptyResponse status204 response
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 :: QueryResponse -> Either TableError Entity
parseQueryEntityResponse = parseXmlResponseOrError status200 readEntity
queryEntity :: String -> EntityKey -> TableStorage Entity
queryEntity tableName key = do
let resource = entityKeyResource tableName key
response <- authenticatedRequest methodGet [] resource resource ""
fromEither $ parseQueryEntityResponse response
parseQueryEntitiesResponse :: QueryResponse -> Either TableError [Entity]
parseQueryEntitiesResponse = parseXmlResponseOrError status200 readEntities where
readEntities :: Element -> Maybe [Entity]
readEntities feed = sequence $ do
entry <- findChildren (qualifyAtom "entry") feed
return $ readEntity entry
queryEntities :: String -> EntityQuery -> TableStorage [Entity]
queryEntities tableName query = do
let canonicalizedResource = '/' : tableName ++ "()"
let queryString = buildQueryString query
let resource = canonicalizedResource ++ '?' : queryString
response <- authenticatedRequest methodGet [] resource canonicalizedResource ""
fromEither $ parseQueryEntitiesResponse response
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 = "" }
defaultConf :: AccountKey -> String -> String -> TableConf
defaultConf key name hostname = TableConf (defaultAccount key name hostname) Nothing Nothing