tablestorage 0.1.0.3 → 0.2.1.0
raw patch · 14 files changed
+1123/−1066 lines, 14 filesdep +conduitdep +crypto-apidep +cryptohashsetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: conduit, crypto-api, cryptohash, http-conduit, http-types, resourcet, transformers
API changes (from Hackage documentation)
+ Network.TableStorage.API: defaultConf :: AccountKey -> String -> String -> TableConf
+ Network.TableStorage.API: withTableStorage :: TableConf -> TableStorage a -> IO (Either TableError a)
+ Network.TableStorage.Development: developmentConf :: TableConf
+ Network.TableStorage.Types: QueryResponse :: Status -> String -> QueryResponse
+ Network.TableStorage.Types: TableConf :: Account -> Maybe Manager -> Maybe Proxy -> TableConf
+ Network.TableStorage.Types: TableOtherError :: String -> TableError
+ Network.TableStorage.Types: TableParseError :: TableError
+ Network.TableStorage.Types: TableUnknownError :: TableError
+ Network.TableStorage.Types: data QueryResponse
+ Network.TableStorage.Types: data TableConf
+ Network.TableStorage.Types: data TableError
+ Network.TableStorage.Types: httpManager :: TableConf -> Maybe Manager
+ Network.TableStorage.Types: httpProxy :: TableConf -> Maybe Proxy
+ Network.TableStorage.Types: instance Error TableError
+ Network.TableStorage.Types: instance Show TableError
+ Network.TableStorage.Types: tableAccount :: TableConf -> Account
+ Network.TableStorage.Types: type TableStorage = ErrorT TableError (ReaderT TableConf IO)
- Network.TableStorage.API: createTable :: Account -> String -> IO (Either String ())
+ Network.TableStorage.API: createTable :: String -> TableStorage ()
- Network.TableStorage.API: createTableIfNecessary :: Account -> String -> IO (Either String ())
+ Network.TableStorage.API: createTableIfNecessary :: String -> TableStorage ()
- Network.TableStorage.API: deleteEntity :: Account -> String -> EntityKey -> IO (Either String ())
+ Network.TableStorage.API: deleteEntity :: String -> EntityKey -> TableStorage ()
- Network.TableStorage.API: deleteTable :: Account -> String -> IO (Either String ())
+ Network.TableStorage.API: deleteTable :: String -> TableStorage ()
- Network.TableStorage.API: insertEntity :: Account -> String -> Entity -> IO (Either String ())
+ Network.TableStorage.API: insertEntity :: String -> Entity -> TableStorage ()
- Network.TableStorage.API: mergeEntity :: Account -> String -> Entity -> IO (Either String ())
+ Network.TableStorage.API: mergeEntity :: String -> Entity -> TableStorage ()
- Network.TableStorage.API: queryEntities :: Account -> String -> EntityQuery -> IO (Either String [Entity])
+ Network.TableStorage.API: queryEntities :: String -> EntityQuery -> TableStorage [Entity]
- Network.TableStorage.API: queryEntity :: Account -> String -> EntityKey -> IO (Either String Entity)
+ Network.TableStorage.API: queryEntity :: String -> EntityKey -> TableStorage Entity
- Network.TableStorage.API: queryTables :: Account -> IO (Either String [String])
+ Network.TableStorage.API: queryTables :: TableStorage [String]
- Network.TableStorage.API: updateEntity :: Account -> String -> Entity -> IO (Either String ())
+ Network.TableStorage.API: updateEntity :: String -> Entity -> TableStorage ()
- Network.TableStorage.Auth: authenticatedRequest :: Account -> RequestMethod -> [Header] -> String -> String -> String -> IO (Either String Response_String)
+ Network.TableStorage.Auth: authenticatedRequest :: Method -> [Header] -> String -> String -> String -> TableStorage QueryResponse
- Network.TableStorage.Types: SharedKeyAuth :: RequestMethod -> String -> String -> String -> String -> SharedKeyAuth
+ Network.TableStorage.Types: SharedKeyAuth :: Method -> String -> String -> String -> String -> SharedKeyAuth
- Network.TableStorage.Types: sharedKeyAuthVerb :: SharedKeyAuth -> RequestMethod
+ Network.TableStorage.Types: sharedKeyAuthVerb :: SharedKeyAuth -> Method
Files
- LICENSE +24/−24
- Setup.hs +2/−2
- src/Network/TableStorage.hs +16/−16
- src/Network/TableStorage/API.hs +242/−237
- src/Network/TableStorage/Atom.hs +86/−84
- src/Network/TableStorage/Auth.hs +131/−131
- src/Network/TableStorage/Development.hs +24/−21
- src/Network/TableStorage/Format.hs +25/−25
- src/Network/TableStorage/Query.hs +84/−84
- src/Network/TableStorage/Request.hs +158/−158
- src/Network/TableStorage/Response.hs +78/−81
- src/Network/TableStorage/Types.hs +168/−126
- src/Network/TableStorage/XML.hs +36/−36
- tablestorage.cabal +49/−41
LICENSE view
@@ -1,24 +1,24 @@-Copyright (c) 2012, Phil Freeman-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.- * Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.- * Neither the name of the <organization> nor the- names of its contributors may be used to endorse or promote products- derived from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY-DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright (c) Phil Freeman, Aaron Friel 2012 +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the <organization> nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple +main = defaultMain
src/Network/TableStorage.hs view
@@ -1,16 +1,16 @@--- | A simple wrapper for the Azure Table Storage REST API------ This module exists simply to re-export the following:------ * "Network.TableStorage.Types"------ * "Network.TableStorage.API"------ * "Network.TableStorage.Development"--module Network.TableStorage (module TableStorage) where--import Network.TableStorage.Types as TableStorage-import Network.TableStorage.API as TableStorage-import Network.TableStorage.Development as TableStorage-import Network.TableStorage.Query as TableStorage+-- | A simple wrapper for the Azure Table Storage REST API +-- +-- This module exists simply to re-export the following: +-- +-- * "Network.TableStorage.Types" +-- +-- * "Network.TableStorage.API" +-- +-- * "Network.TableStorage.Development" + +module Network.TableStorage (module TableStorage) where + +import Network.TableStorage.Types as TableStorage +import Network.TableStorage.API as TableStorage +import Network.TableStorage.Development as TableStorage +import Network.TableStorage.Query as TableStorage
src/Network/TableStorage/API.hs view
@@ -1,237 +1,242 @@--- |--- This module provides functions wrapping the Azure REST API web methods.--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 )---- |--- Parse the response body of the Query Tables web method----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---- |--- List the names of tables for an account or returns an error message----queryTables :: Account -> IO (Either String [String])-queryTables acc = do- let resource = "/Tables"- response <- authenticatedRequest acc GET [] resource resource ""- return $ response >>= parseQueryTablesResponse---- |--- Construct the request body for the Create Table web method----createTableXml :: String -> IO Element-createTableXml tableName = wrapContent $ propertyList [("TableName", EdmString $ Just tableName)]---- |--- Creates a new table with the specified name or returns an error message----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)---- |--- Creates a new table with the specified name if it does not already exist, or returns an erro message--- -createTableIfNecessary :: Account -> String -> IO (Either String ())-createTableIfNecessary acc tableName = runErrorT $ do - tables <- ErrorT $ queryTables acc- unless (tableName `elem` tables) $ ErrorT $ createTable acc tableName---- |--- Deletes the table with the specified name or returns an error message----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)---- |--- Construct the request body for the Insert Entity web method----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---- |--- Inserts an entity into the table with the specified name or returns an error message----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) ---- |--- Shared method to update or merge an existing entity. The only difference between the--- two methods is the request method used.----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)- --- |--- Updates the specified entity (possibly removing columns) or returns an error message----updateEntity :: Account -> String -> Entity -> IO (Either String ())-updateEntity = updateOrMergeEntity PUT---- |--- Merges the specified entity (without removing columns) or returns an error message ----mergeEntity :: Account -> String -> Entity -> IO (Either String ())-mergeEntity = updateOrMergeEntity (Custom "MERGE")---- |--- Deletes the entity with the specified key or returns an error message ----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)---- |--- Parse an Atom entry as an entity ----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)---- |--- Parse the response body of the Query Entity web method ----parseQueryEntityResponse :: Response_String -> Either String Entity-parseQueryEntityResponse = parseXmlResponseOrError (2, 0, 0) readEntity where ---- |--- Returns the entity with the specified table name and key or an error message----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---- |--- Parse the response body of the Query Entities web method----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- --- |--- Returns a collection of entities by executing the specified query or returns an error message ----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- --- |--- An empty query with no filters and no specified page size ----defaultEntityQuery :: EntityQuery-defaultEntityQuery = EntityQuery { eqPageSize = Nothing,- eqFilter = Nothing }- --- | --- Constructs an Account with the default values for Port and Resource Prefix-defaultAccount :: AccountKey -> String -> String -> Account-defaultAccount key name hostname = Account { accountScheme = "http",- accountHost = hostname,- accountPort = 80,- accountKey = key,- accountName = name,- accountResourcePrefix = "" }+{-# LANGUAGE OverloadedStrings #-} +-- | +-- This module provides functions wrapping the Azure REST API web methods. + +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 + +-- | +-- Runs TableStorage actions given a configuration +-- +withTableStorage :: TableConf -> TableStorage a -> IO (Either TableError a) +withTableStorage conf f = runReaderT (runErrorT f) conf + +-- | +-- Simple helper function to convert non-monadic parser results into the monadic result +-- +fromEither :: MonadError e m => Either e a -> m a +fromEither (Left e) = throwError e +fromEither (Right a) = return a +{-# INLINE fromEither #-} + +-- | +-- Parse the response body of the Query Tables web method +-- +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 + +-- | +-- List the names of tables for an account or returns an error message +-- +queryTables :: TableStorage [String] +queryTables = do + let resource = "/Tables" + response <- authenticatedRequest methodGet [] resource resource "" + fromEither $ parseQueryTablesResponse response + +-- | +-- Construct the request body for the Create Table web method +-- +createTableXml :: String -> IO Element +createTableXml tableName = wrapContent Nothing $ propertyList [("TableName", EdmString $ Just tableName)] + +-- | +-- Creates a new table with the specified name or returns an error message +-- +createTable :: String -> TableStorage () +createTable tableName = do + let resource = "/Tables" + requestXml <- liftIO $ createTableXml tableName + response <- authenticatedRequest methodPost [] resource resource $ showTopElement requestXml + fromEither $ parseEmptyResponse status201 response + +-- | +-- Creates a new table with the specified name if it does not already exist, or returns an erro message +-- +createTableIfNecessary :: String -> TableStorage () +createTableIfNecessary tableName = do + tables <- queryTables + unless (tableName `elem` tables) $ createTable tableName + +-- | +-- Deletes the table with the specified name or returns an error message +-- +deleteTable :: String -> TableStorage () +deleteTable tableName = do + let resource = "/Tables('" ++ tableName ++ "')" + response <- authenticatedRequest methodDelete [] resource resource "" + fromEither $ parseEmptyResponse status204 response + +-- | +-- Construct the request body for the Insert Entity web method +-- +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 + +-- | +-- Inserts an entity into the table with the specified name or returns an error message +-- +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 + +-- | +-- Shared method to update or merge an existing entity. The only difference between the +-- two methods is the request method used. +-- +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 + +-- | +-- Updates the specified entity (possibly removing columns) or returns an error message +-- +updateEntity :: String -> Entity -> TableStorage () +updateEntity = updateOrMergeEntity methodPut + +-- | +-- Merges the specified entity (without removing columns) or returns an error message +-- +mergeEntity :: String -> Entity -> TableStorage () +mergeEntity = updateOrMergeEntity "MERGE" + +-- | +-- Deletes the entity with the specified key or returns an error message +-- +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 + +-- | +-- Parse an Atom entry as an entity +-- +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) + +-- | +-- Parse the response body of the Query Entity web method +-- +parseQueryEntityResponse :: QueryResponse -> Either TableError Entity +parseQueryEntityResponse = parseXmlResponseOrError status200 readEntity + +-- | +-- Returns the entity with the specified table name and key or an error message +-- +queryEntity :: String -> EntityKey -> TableStorage Entity +queryEntity tableName key = do + let resource = entityKeyResource tableName key + response <- authenticatedRequest methodGet [] resource resource "" + fromEither $ parseQueryEntityResponse response + +-- | +-- Parse the response body of the Query Entities web method +-- +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 + +-- | +-- Returns a collection of entities by executing the specified query or returns an error message +-- +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 + +-- | +-- An empty query with no filters and no specified page size +-- +defaultEntityQuery :: EntityQuery +defaultEntityQuery = EntityQuery { eqPageSize = Nothing, + eqFilter = Nothing } + +-- | +-- Constructs an Account with the default values for Port and Resource Prefix +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
src/Network/TableStorage/Atom.hs view
@@ -1,85 +1,87 @@--- |--- Functions for constructing and parsing Atom feeds for use in the --- request and response bodies of the various web methods.-----module Network.TableStorage.Atom (- atomNamespace, dataServicesNamespace, metadataNamespace,- qualifyAtom, qualifyDataServices, qualifyMetadata,- atomElement, atomAttr, wrapContent-) where--import Network.TableStorage.XML- ( qualify, cDataText, namespaceAttr )-import Network.TableStorage.Format ( atomDate )-import Text.XML.Light- ( Element(elAttribs, elContent, elName),- Content(Elem),- QName,- Attr(..),- blank_element,- unqual )--atomNamespace :: String-atomNamespace = "http://www.w3.org/2005/Atom"--dataServicesNamespace :: String-dataServicesNamespace = "http://schemas.microsoft.com/ado/2007/08/dataservices"--metadataNamespace :: String-metadataNamespace = "http://schemas.microsoft.com/ado/2007/08/dataservices/metadata"--qualifyAtom :: String -> QName-qualifyAtom = qualify (Just atomNamespace) Nothing--qualifyDataServices :: String -> QName-qualifyDataServices = qualify (Just dataServicesNamespace) (Just "d")--qualifyMetadata :: String -> QName-qualifyMetadata = qualify (Just metadataNamespace) (Just "m")---- |--- An element in the Atom namespace with the provided attributes and child elements----atomElement :: String -> Maybe String -> [Attr] -> [Element] -> Element-atomElement name content attrs els =- blank_element { elName = qualifyAtom name,- elAttribs = attrs,- elContent = map Elem els ++ maybe [] cDataText content }- --- |--- An attribute in the Atom namespace----atomAttr :: String -> String -> Attr-atomAttr name value =- Attr { attrKey = qualifyAtom name,- attrVal = value }---- |--- Create an Atom entry using the specified element as the content element----wrapContent :: Element -> IO Element-wrapContent content = do- date <- atomDate- return $ atomElement "entry" Nothing - [- Attr { attrKey = unqual "xmlns", attrVal = atomNamespace },- namespaceAttr "d" dataServicesNamespace,- namespaceAttr "m" metadataNamespace- ] - [- atomElement "title" Nothing [] [],- atomElement "updated" (Just date) [] [],- atomElement "author" Nothing [] - [- atomElement "name" Nothing [] []- ],- atomElement "id" Nothing [] [],- atomElement "content" Nothing - [- atomAttr "type" "application/xml"- ] - [ - content +-- | +-- Functions for constructing and parsing Atom feeds for use in the +-- request and response bodies of the various web methods. +-- + +module Network.TableStorage.Atom ( + atomNamespace, dataServicesNamespace, metadataNamespace, + qualifyAtom, qualifyDataServices, qualifyMetadata, + atomElement, atomAttr, wrapContent +) where + +import Network.TableStorage.XML + ( qualify, cDataText, namespaceAttr ) +import Network.TableStorage.Format ( atomDate ) +import Text.XML.Light + ( Element(elAttribs, elContent, elName), + Content(Elem), + QName, CDataKind(..), Content(..), CData(..), + Attr(..), + blank_element, + unqual ) +import Data.Maybe (fromMaybe) + +atomNamespace :: String +atomNamespace = "http://www.w3.org/2005/Atom" + +dataServicesNamespace :: String +dataServicesNamespace = "http://schemas.microsoft.com/ado/2007/08/dataservices" + +metadataNamespace :: String +metadataNamespace = "http://schemas.microsoft.com/ado/2007/08/dataservices/metadata" + +qualifyAtom :: String -> QName +qualifyAtom = qualify (Just atomNamespace) Nothing + +qualifyDataServices :: String -> QName +qualifyDataServices = qualify (Just dataServicesNamespace) (Just "d") + +qualifyMetadata :: String -> QName +qualifyMetadata = qualify (Just metadataNamespace) (Just "m") + +-- | +-- An element in the Atom namespace with the provided attributes and child elements +-- +atomElement :: String -> Maybe String -> [Attr] -> [Element] -> Element +atomElement name content attrs els = + blank_element { elName = qualifyAtom name, + elAttribs = attrs, + elContent = map Elem els ++ maybe [] cDataText content } + +-- | +-- An attribute in the Atom namespace +-- +atomAttr :: String -> String -> Attr +atomAttr name value = + Attr { attrKey = qualifyAtom name, + attrVal = value } + +-- | +-- Create an Atom entry using the specified element as the content element +-- +wrapContent :: Maybe String -> Element -> IO Element +wrapContent entityID content = do + date <- atomDate + return $ + atomElement "entry" Nothing + [ Attr { attrKey = unqual "xmlns", attrVal = atomNamespace } + , namespaceAttr "d" dataServicesNamespace + , namespaceAttr "m" metadataNamespace + ] + [ atomElement "category" Nothing + [ atomAttr "scheme" "http://schemas.microsoft.com/ado/2007/08/dataservices/scheme" + , atomAttr "term" "clio.cookies" + ] [] + , atomElement "title" Nothing [] [] + , atomElement "author" Nothing [] + [ atomElement "name" Nothing [] [] ] + , atomElement "updated" (Just date) [] [] + , blank_element + { elName = qualifyAtom "id" + , elAttribs = [] + , elContent = [Text CData { cdVerbatim = CDataRaw, cdData = fromMaybe "" entityID, cdLine = Nothing }] + } + , atomElement "content" Nothing + [ atomAttr "type" "application/xml" ] + [ content ] ]- ]
src/Network/TableStorage/Auth.hs view
@@ -1,131 +1,131 @@--- |--- This module provides functions to create authenticated requests to the Table--- Storage REST API.------ Functions are provided to create Shared Key authorization tokens, and to add the--- required headers for the various requests.-----module Network.TableStorage.Auth (- authenticatedRequest-) where--import qualified Data.ByteString.Base64 as Base64C- ( encode, decode )-import qualified Codec.Binary.UTF8.String as UTF8C ( encodeString )-import qualified Data.ByteString as B ( ByteString, concat )-import qualified Data.ByteString.UTF8 as UTF8- ( toString, fromString )-import qualified Data.ByteString.Lazy.UTF8 as UTF8L ( fromString )-import qualified Data.ByteString.Lazy.Char8 as Char8L ( toChunks )-import qualified Data.ByteString.Lazy as L ( fromChunks )-import qualified Data.Digest.Pure.SHA as SHA- ( bytestringDigest, hmacSha256 )-import Network.TCP ( HStream(close, openStream) )-import Network.URI- ( URIAuth(URIAuth, uriPort, uriRegName, uriUserInfo), URI(..) )-import Network.HTTP- ( HeaderName(HdrAccept, HdrAuthorization, HdrContentLength,- HdrContentType, HdrDate),- Header(..),- Request(Request, rqBody, rqHeaders, rqMethod, rqURI),- RequestMethod,- Response_String,- sendHTTP )-import Network.HTTP.Base ()-import Network.Stream ( Result )-import Network.TableStorage.Types- ( SharedKeyAuth(..),- Account(accountHost, accountKey, accountName, accountPort,- accountResourcePrefix, accountScheme),- AuthHeader(..),- Signature(..),- AccountKey(unAccountKey) )-import Network.TableStorage.Format ( rfc1123Date )--authenticationType :: String-authenticationType = "SharedKey"---- |--- Constructs the unencrypted content of the Shared Key authentication token ----printSharedKeyAuth :: SharedKeyAuth -> String-printSharedKeyAuth auth = - show (sharedKeyAuthVerb auth)- ++ "\n" - ++ sharedKeyAuthContentMD5 auth- ++ "\n" - ++ sharedKeyAuthContentType auth- ++ "\n" - ++ sharedKeyAuthDate auth - ++ "\n" - ++ sharedKeyAuthCanonicalizedResource auth- -hmacSha256' :: AccountKey -> String -> B.ByteString-hmacSha256' base64Key = - let (Right key) = Base64C.decode . UTF8.fromString . unAccountKey $ base64Key in- B.concat . Char8L.toChunks . SHA.bytestringDigest . SHA.hmacSha256 (L.fromChunks $ return key) . UTF8L.fromString- --- |--- Constructs the authorization signature----signature :: AccountKey -> SharedKeyAuth -> Signature-signature key = Signature . UTF8.toString . Base64C.encode . hmacSha256' key . UTF8C.encodeString . printSharedKeyAuth---- |--- Constructs the authorization header including account name and signature----authHeader :: Account -> SharedKeyAuth -> AuthHeader-authHeader acc auth = AuthHeader $- authenticationType - ++ " " - ++ accountName acc - ++ ":"- ++ unSignature (signature (accountKey acc) auth)---- |--- Constructs an absolute URI from an Account and relative URI ----qualifyResource :: String -> Account -> URI-qualifyResource res acc =- URI { uriScheme = accountScheme acc- , uriAuthority = - Just URIAuth - { uriRegName = accountHost acc- , uriPort = ':' : show (accountPort acc)- , uriUserInfo = "" }- , uriQuery = ""- , uriFragment = ""- , uriPath = accountResourcePrefix acc ++ res }---- |--- Creates and executes an authenticated request including the Authorization header.------ The function takes the account information, request method, additional headers, --- resource, canonicalized resource and request body as parameters, and returns--- an error message or the response object.----authenticatedRequest :: Account -> RequestMethod -> [Header] -> String -> String -> String -> IO (Either String Response_String)-authenticatedRequest acc method hdrs resource canonicalizedResource body = do- time <- rfc1123Date - connection <- openStream (accountHost acc) (accountPort acc) - let { auth = SharedKeyAuth - { sharedKeyAuthVerb = method- , sharedKeyAuthContentMD5 = ""- , sharedKeyAuthContentType = "application/atom+xml"- , sharedKeyAuthDate = time- , sharedKeyAuthCanonicalizedResource = "/" ++ accountName acc ++ accountResourcePrefix acc ++ canonicalizedResource } }- let { basicHeaders =- [ Header HdrAuthorization $ unAuthHeader $ authHeader acc auth- , Header HdrContentType "application/atom+xml"- , Header HdrContentLength $ show $ length body- , Header HdrAccept "application/atom+xml,application/xml"- , Header HdrDate time ] }- let { request = Request - { rqURI = qualifyResource resource acc- , rqMethod = method- , rqHeaders = basicHeaders ++ hdrs- , rqBody = body } }- result <- sendHTTP connection request :: IO (Result Response_String)- _ <- close connection- return $ either (Left . show) Right result+{-# LANGUAGE OverloadedStrings #-} +-- | +-- This module provides functions to create authenticated requests to the Table +-- Storage REST API. +-- +-- Functions are provided to create Shared Key authorization tokens, and to add the +-- required headers for the various requests. +-- + +module Network.TableStorage.Auth ( + authenticatedRequest +) where + +import qualified Data.ByteString.Base64 as Base64C + ( encode, decode ) +import qualified Codec.Binary.UTF8.String as UTF8C ( encodeString ) +import qualified Data.ByteString as B ( ByteString, concat ) +import qualified Data.ByteString.UTF8 as UTF8 + ( toString, fromString ) +import qualified Data.ByteString.Lazy.UTF8 as UTF8L ( fromString, toString ) +import qualified Data.ByteString.Lazy.Char8 as Char8L ( toChunks ) +import qualified Data.ByteString.Lazy as L ( fromChunks ) +import Crypto.Hash.MD5 as MD5 (hash) +import qualified Data.Digest.Pure.SHA as SHA + ( bytestringDigest, hmacSha256 ) +import Network.URI + ( URIAuth(URIAuth, uriPort, uriRegName, uriUserInfo), URI(..) ) +import Network.HTTP.Conduit +import Network.HTTP.Conduit.Internal (setUri) +import Network.HTTP.Types +import Network.TableStorage.Types +import Network.TableStorage.Format ( rfc1123Date ) +import Data.Monoid ((<>)) +import Control.Monad.Reader +import Control.Monad.Trans.Resource + +authenticationType :: String +authenticationType = "SharedKey" + +-- | +-- Constructs the unencrypted content of the Shared Key authentication token +-- +printSharedKeyAuth :: SharedKeyAuth -> String +printSharedKeyAuth auth = + UTF8.toString (sharedKeyAuthVerb auth) + ++ "\n" + ++ sharedKeyAuthContentMD5 auth + ++ "\n" + ++ sharedKeyAuthContentType auth + ++ "\n" + ++ sharedKeyAuthDate auth + ++ "\n" + ++ sharedKeyAuthCanonicalizedResource auth + +hmacSha256' :: AccountKey -> String -> B.ByteString +hmacSha256' base64Key = + let (Right key) = Base64C.decode . UTF8.fromString . unAccountKey $ base64Key in + B.concat . Char8L.toChunks . SHA.bytestringDigest . SHA.hmacSha256 (L.fromChunks $ return key) . UTF8L.fromString + +-- | +-- Constructs the authorization signature +-- +signature :: AccountKey -> SharedKeyAuth -> Signature +signature key = Signature . UTF8.toString . Base64C.encode . hmacSha256' key . UTF8C.encodeString . printSharedKeyAuth + +-- | +-- Constructs the authorization header including account name and signature +-- +authHeader :: Account -> SharedKeyAuth -> AuthHeader +authHeader acc auth = AuthHeader $ + authenticationType + ++ " " + ++ accountName acc + ++ ":" + ++ unSignature (signature (accountKey acc) auth) + +-- | +-- Constructs an absolute URI from an Account and relative URI +-- +qualifyResource :: String -> Account -> URI +qualifyResource res acc = + URI { uriScheme = accountScheme acc + , uriAuthority = + Just URIAuth + { uriRegName = accountHost acc + , uriPort = ':' : show (accountPort acc) + , uriUserInfo = "" } + , uriQuery = "" + , uriFragment = "" + , uriPath = accountResourcePrefix acc ++ res } + +-- | +-- Creates and executes an authenticated request including the Authorization header. +-- +-- The function takes the account information, request method, additional headers, +-- resource, canonicalized resource and request body as parameters, and returns +-- an error message or the response object. +-- +authenticatedRequest :: Method -> [Header] -> String -> String -> String -> TableStorage QueryResponse +authenticatedRequest mthd hdrs resource canonicalizedResource body = do + time <- liftIO rfc1123Date + (TableConf acc maybeMgr maybeProxy) <- ask + let contentMD5 = (Base64C.encode . hash . UTF8.fromString) body + let atomType = "application/atom+xml" :: B.ByteString + let auth = SharedKeyAuth { sharedKeyAuthVerb = mthd + , sharedKeyAuthContentMD5 = UTF8.toString contentMD5 + , sharedKeyAuthContentType = UTF8.toString atomType + , sharedKeyAuthDate = time + , sharedKeyAuthCanonicalizedResource = "/" ++ accountName acc ++ accountResourcePrefix acc ++ canonicalizedResource } + let uri = qualifyResource resource acc + let defaultReq = def { method = mthd + , requestHeaders = [ (hAuthorization, UTF8.fromString . unAuthHeader $ authHeader acc auth) + , (hContentType, atomType) + , (hContentMD5, contentMD5) + , (hAccept, atomType <> ",application/xml") + , (hDate, UTF8.fromString time) + , ("x-ms-date", UTF8.fromString time) + , ("x-ms-version", "2009-09-19") + , ("DataServiceVersion", "1.0;NetFx") + , ("MaxDataServiceVersion", "2.0;NetFx") + ] ++ hdrs + , requestBody = RequestBodyBS $ UTF8.fromString body + , redirectCount = 0 + , checkStatus = \_ _ -> Nothing + , proxy = maybeProxy + } + request <- setUri defaultReq uri + response <- case maybeMgr of + Just mgr -> runResourceT $ httpLbs request mgr + Nothing -> withManager (httpLbs request) + return $ QueryResponse (responseStatus response) (UTF8L.toString $ responseBody response)
src/Network/TableStorage/Development.hs view
@@ -1,21 +1,24 @@--- |--- This module contains constants for working with the storage emulator. -----module Network.TableStorage.Development (- developmentAccount-) where--import Network.TableStorage.Types- ( Account(..), AccountKey(AccountKey) )---- |--- An account for the storage emulator----developmentAccount :: Account-developmentAccount = Account { accountScheme = "http",- accountHost = "127.0.0.1" ,- accountName = "devstoreaccount1",- accountPort = 10002,- accountResourcePrefix = "/devstoreaccount1",- accountKey = AccountKey "Eby8vdM02xNOcqFlqUwJPLlmEtlCDXJ1OUzFT50uSRZ6IFsuFq2UVErCz4I6tq/K1SZFPTOtr/KBHBeksoGMGw=="}+-- | +-- This module contains constants for working with the storage emulator. +-- + +module Network.TableStorage.Development ( + developmentAccount, developmentConf +) where + +import Network.TableStorage.Types + ( Account(..), AccountKey(AccountKey), TableConf(..) ) + +-- | +-- An account for the storage emulator +-- +developmentAccount :: Account +developmentAccount = Account { accountScheme = "http:", + accountHost = "127.0.0.1" , + accountName = "devstoreaccount1", + accountPort = 10002, + accountResourcePrefix = "/devstoreaccount1", + accountKey = AccountKey "Eby8vdM02xNOcqFlqUwJPLlmEtlCDXJ1OUzFT50uSRZ6IFsuFq2UVErCz4I6tq/K1SZFPTOtr/KBHBeksoGMGw=="} + +developmentConf :: TableConf +developmentConf = TableConf developmentAccount Nothing Nothing
src/Network/TableStorage/Format.hs view
@@ -1,26 +1,26 @@--- |--- Helper methods for working with formatted dates-----module Network.TableStorage.Format (- getFormattedTime, rfc1123Date, atomDate, - rfc1123Format, atomDateFormat-) where--import Data.Time ( getCurrentTime, formatTime )-import System.Locale ( defaultTimeLocale )--getFormattedTime :: String -> IO String-getFormattedTime formatString = fmap (formatTime defaultTimeLocale formatString) getCurrentTime--rfc1123Date :: IO String-rfc1123Date = getFormattedTime rfc1123Format--atomDate :: IO String-atomDate = getFormattedTime atomDateFormat--rfc1123Format :: String-rfc1123Format = "%a, %d %b %Y %H:%M:%S GMT"--atomDateFormat :: String+-- | +-- Helper methods for working with formatted dates +-- + +module Network.TableStorage.Format ( + getFormattedTime, rfc1123Date, atomDate, + rfc1123Format, atomDateFormat +) where + +import Data.Time ( getCurrentTime, formatTime ) +import System.Locale ( defaultTimeLocale ) + +getFormattedTime :: String -> IO String +getFormattedTime formatString = fmap (formatTime defaultTimeLocale formatString) getCurrentTime + +rfc1123Date :: IO String +rfc1123Date = getFormattedTime rfc1123Format + +atomDate :: IO String +atomDate = getFormattedTime atomDateFormat + +rfc1123Format :: String +rfc1123Format = "%a, %d %b %Y %H:%M:%S GMT" + +atomDateFormat :: String atomDateFormat = "%Y-%m-%dT%H:%M:%S%QZ"
src/Network/TableStorage/Query.hs view
@@ -1,85 +1,85 @@--- |--- This module contains functions which help when unmarshalling query responses--module Network.TableStorage.Query (- edmBinary, edmBoolean, edmDateTime, edmDouble,- edmGuid, edmInt32, edmInt64, edmString-) where--import Data.Time ( UTCTime )-import Network.TableStorage.Types- ( Entity(entityColumns),- EntityColumn(EdmBinary, EdmBoolean, EdmDateTime, EdmDouble,- EdmGuid, EdmInt32, EdmInt64, EdmString) )---- |--- Find the value in a binary-valued column or return Nothing if no such column exists-edmBinary :: String -> Entity -> Maybe String-edmBinary key en = do- col <- lookup key $ entityColumns en- case col of- EdmBinary s -> s- _ -> Nothing- --- |--- Find the value in a string-valued column or return Nothing if no such column exists-edmString :: String -> Entity -> Maybe String-edmString key en = do- col <- lookup key $ entityColumns en- case col of- EdmString s -> s- _ -> Nothing---- |--- Find the value in a boolean-valued column or return Nothing if no such column exists-edmBoolean :: String -> Entity -> Maybe Bool-edmBoolean key en = do- col <- lookup key $ entityColumns en- case col of- EdmBoolean s -> s- _ -> Nothing---- |--- Find the value in a date-valued column or return Nothing if no such column exists-edmDateTime :: String -> Entity -> Maybe UTCTime-edmDateTime key en = do- col <- lookup key $ entityColumns en- case col of- EdmDateTime s -> s- _ -> Nothing---- |--- Find the value in a double-valued column or return Nothing if no such column exists-edmDouble :: String -> Entity -> Maybe Double-edmDouble key en = do- col <- lookup key $ entityColumns en- case col of- EdmDouble s -> s- _ -> Nothing---- |--- Find the value in a Guid-valued column or return Nothing if no such column exists-edmGuid :: String -> Entity -> Maybe String-edmGuid key en = do- col <- lookup key $ entityColumns en- case col of- EdmGuid s -> s- _ -> Nothing---- |--- Find the value in an integer-valued column or return Nothing if no such column exists-edmInt32 :: String -> Entity -> Maybe Int-edmInt32 key en = do- col <- lookup key $ entityColumns en- case col of- EdmInt32 s -> s- _ -> Nothing---- |--- Find the value in an integer-valued column or return Nothing if no such column exists-edmInt64 :: String -> Entity -> Maybe Int-edmInt64 key en = do- col <- lookup key $ entityColumns en- case col of- EdmInt64 s -> s+-- | +-- This module contains functions which help when unmarshalling query responses + +module Network.TableStorage.Query ( + edmBinary, edmBoolean, edmDateTime, edmDouble, + edmGuid, edmInt32, edmInt64, edmString +) where + +import Data.Time ( UTCTime ) +import Network.TableStorage.Types + ( Entity(entityColumns), + EntityColumn(EdmBinary, EdmBoolean, EdmDateTime, EdmDouble, + EdmGuid, EdmInt32, EdmInt64, EdmString) ) + +-- | +-- Find the value in a binary-valued column or return Nothing if no such column exists +edmBinary :: String -> Entity -> Maybe String +edmBinary key en = do + col <- lookup key $ entityColumns en + case col of + EdmBinary s -> s + _ -> Nothing + +-- | +-- Find the value in a string-valued column or return Nothing if no such column exists +edmString :: String -> Entity -> Maybe String +edmString key en = do + col <- lookup key $ entityColumns en + case col of + EdmString s -> s + _ -> Nothing + +-- | +-- Find the value in a boolean-valued column or return Nothing if no such column exists +edmBoolean :: String -> Entity -> Maybe Bool +edmBoolean key en = do + col <- lookup key $ entityColumns en + case col of + EdmBoolean s -> s + _ -> Nothing + +-- | +-- Find the value in a date-valued column or return Nothing if no such column exists +edmDateTime :: String -> Entity -> Maybe UTCTime +edmDateTime key en = do + col <- lookup key $ entityColumns en + case col of + EdmDateTime s -> s + _ -> Nothing + +-- | +-- Find the value in a double-valued column or return Nothing if no such column exists +edmDouble :: String -> Entity -> Maybe Double +edmDouble key en = do + col <- lookup key $ entityColumns en + case col of + EdmDouble s -> s + _ -> Nothing + +-- | +-- Find the value in a Guid-valued column or return Nothing if no such column exists +edmGuid :: String -> Entity -> Maybe String +edmGuid key en = do + col <- lookup key $ entityColumns en + case col of + EdmGuid s -> s + _ -> Nothing + +-- | +-- Find the value in an integer-valued column or return Nothing if no such column exists +edmInt32 :: String -> Entity -> Maybe Int +edmInt32 key en = do + col <- lookup key $ entityColumns en + case col of + EdmInt32 s -> s + _ -> Nothing + +-- | +-- Find the value in an integer-valued column or return Nothing if no such column exists +edmInt64 :: String -> Entity -> Maybe Int +edmInt64 key en = do + col <- lookup key $ entityColumns en + case col of + EdmInt64 s -> s _ -> Nothing
src/Network/TableStorage/Request.hs view
@@ -1,158 +1,158 @@--- |--- Helper methods used to construct requests.-----module Network.TableStorage.Request (- propertyList,- entityKeyResource,- columnToTypeString,- printEntityColumn,- printComparisonType,- buildFilterString,- buildQueryString-) where--import Data.Time ( formatTime )-import System.Locale ( defaultTimeLocale )-import Data.Maybe ( fromMaybe )-import Data.List ( intercalate )-import Text.XML.Light.Types ( elAttribs )-import Text.XML.Light- ( Element(elAttribs, elContent, elName),- Content(Elem),- Attr(Attr),- blank_element )-import Network.TableStorage.Types- ( EntityFilter(..),- ComparisonType(..),- EntityQuery(eqFilter, eqPageSize),- EntityColumn(..),- EntityKey(ekPartitionKey, ekRowKey) )-import Network.TableStorage.XML ( cDataText )-import Network.TableStorage.Atom- ( qualifyDataServices, qualifyMetadata )-import Network.TableStorage.Format ( atomDateFormat )-import Network.HTTP.Base ( urlEncode )---- |--- Formats a list of entity properties for inclusion in an Atom entry. ----propertyList :: [(String, EntityColumn)] -> Element-propertyList props = - blank_element { elName = qualifyMetadata "properties",- elContent = map property props } where- property (key, value) =- let stringValue = printEntityColumn value in- Elem blank_element { elName = qualifyDataServices key,- elAttribs = [ Attr (qualifyMetadata "type") $ columnToTypeString value, - Attr (qualifyMetadata "null") $ maybe "true" (const "false") stringValue ],- elContent = cDataText $ fromMaybe "" stringValue }---- |--- Constructs relative URIs which refer to the entity with the specified table name--- and entity key. ----entityKeyResource :: String -> EntityKey -> String-entityKeyResource tableName key = tableName ++ "(PartitionKey='" ++ ekPartitionKey key ++ "',RowKey='" ++ ekRowKey key ++ "')"---- |--- Converts an entity column into its type name----columnToTypeString :: EntityColumn -> String-columnToTypeString (EdmBinary _) = "Edm.Binary"-columnToTypeString (EdmBoolean _) = "Edm.Boolean"-columnToTypeString (EdmDateTime _) = "Edm.DateTime"-columnToTypeString (EdmDouble _) = "Edm.Double"-columnToTypeString (EdmGuid _) = "Edm.EdmGuid"-columnToTypeString (EdmInt32 _) = "Edm.Int32"-columnToTypeString (EdmInt64 _) = "Edm.Int64"-columnToTypeString (EdmString _) = "Edm.String"---- |--- Formats a column value to appear in the body of an Atom entry----printEntityColumn :: EntityColumn -> Maybe String-printEntityColumn (EdmBinary (Just val)) = Just val-printEntityColumn (EdmBoolean (Just True)) = Just "true"-printEntityColumn (EdmBoolean (Just False)) = Just "false"-printEntityColumn (EdmDateTime (Just val)) = Just $ formatTime defaultTimeLocale atomDateFormat val-printEntityColumn (EdmDouble (Just val)) = Just $ show val-printEntityColumn (EdmGuid (Just val)) = Just val-printEntityColumn (EdmInt32 (Just val)) = Just $ show val-printEntityColumn (EdmInt64 (Just val)) = Just $ show val-printEntityColumn (EdmString (Just val)) = Just val-printEntityColumn _ = Nothing---- |--- Formats a comparison type to appear in the query string----printComparisonType :: ComparisonType -> String-printComparisonType Equal = "eq"-printComparisonType GreaterThan = "gt"-printComparisonType GreaterThanOrEqual = "ge" -printComparisonType LessThan = "lt"-printComparisonType LessThanOrEqual = "le" -printComparisonType NotEqual = "ne"---- |--- Converts entity filter values into strings to appear in the filter--- portion of the Query Entities URI. ----buildFilterString :: EntityFilter -> String-buildFilterString (And fs) = '(' : intercalate "%20and%20" (map buildFilterString fs) ++ ")"-buildFilterString (Or fs) = '(' : intercalate "%20or%20" (map buildFilterString fs) ++ ")"-buildFilterString (Not f) = - "(not%20" - ++ buildFilterString f - ++ ")"-buildFilterString (CompareBoolean prop val) = - urlEncode prop - ++ "%20eq%20" - ++ if val then "true" else "false"-buildFilterString (CompareDateTime prop cmp val) = - urlEncode prop - ++ "%20"- ++ printComparisonType cmp - ++ "%20datetime'" - ++ formatTime defaultTimeLocale atomDateFormat val - ++ "'"-buildFilterString (CompareDouble prop cmp val) = - urlEncode prop- ++ "%20" - ++ printComparisonType cmp - ++ "%20" - ++ show val-buildFilterString (CompareGuid prop val) = - urlEncode prop - ++ "%20eq%20guid'" - ++ val- ++ "'"-buildFilterString (CompareInt32 prop cmp val) = - urlEncode prop - ++ "%20" - ++ printComparisonType cmp - ++ "%20" - ++ show val-buildFilterString (CompareInt64 prop cmp val) = - urlEncode prop - ++ "%20" - ++ printComparisonType cmp - ++ "%20" - ++ show val-buildFilterString (CompareString prop cmp val) = - urlEncode prop - ++ "%20" - ++ printComparisonType cmp- ++ "%20'" - ++ urlEncode val - ++ "'"---- |--- Constructs the full query string for the Query Entities web method. ----buildQueryString :: EntityQuery -> String-buildQueryString query = - "$filter="- ++ maybe "" buildFilterString (eqFilter query) - ++ "&$top=" - ++ maybe "" show (eqPageSize query) +-- | +-- Helper methods used to construct requests. +-- + +module Network.TableStorage.Request ( + propertyList, + entityKeyResource, + columnToTypeString, + printEntityColumn, + printComparisonType, + buildFilterString, + buildQueryString +) where + +import Data.Time ( formatTime ) +import System.Locale ( defaultTimeLocale ) +import Data.Maybe ( fromMaybe ) +import Data.List ( intercalate ) +import Text.XML.Light.Types ( elAttribs ) +import Text.XML.Light + ( Element(elContent, elName), + Content(Elem), + Attr(Attr), + blank_element ) +import Network.TableStorage.Types + ( EntityFilter(..), + ComparisonType(..), + EntityQuery(eqFilter, eqPageSize), + EntityColumn(..), + EntityKey(ekPartitionKey, ekRowKey) ) +import Network.TableStorage.XML ( cDataText ) +import Network.TableStorage.Atom + ( qualifyDataServices, qualifyMetadata ) +import Network.TableStorage.Format ( atomDateFormat ) +import Network.HTTP.Base ( urlEncode ) + +-- | +-- Formats a list of entity properties for inclusion in an Atom entry. +-- +propertyList :: [(String, EntityColumn)] -> Element +propertyList props = + blank_element { elName = qualifyMetadata "properties", + elContent = map property props } where + property (key, value) = + let stringValue = printEntityColumn value in + Elem blank_element { elName = qualifyDataServices key, + elAttribs = [ Attr (qualifyMetadata "type") $ columnToTypeString value, + Attr (qualifyMetadata "null") $ maybe "true" (const "false") stringValue ], + elContent = cDataText $ fromMaybe "" stringValue } + +-- | +-- Constructs relative URIs which refer to the entity with the specified table name +-- and entity key. +-- +entityKeyResource :: String -> EntityKey -> String +entityKeyResource tableName key = "/" ++ tableName ++ "(PartitionKey='" ++ ekPartitionKey key ++ "',RowKey='" ++ ekRowKey key ++ "')" + +-- | +-- Converts an entity column into its type name +-- +columnToTypeString :: EntityColumn -> String +columnToTypeString (EdmBinary _) = "Edm.Binary" +columnToTypeString (EdmBoolean _) = "Edm.Boolean" +columnToTypeString (EdmDateTime _) = "Edm.DateTime" +columnToTypeString (EdmDouble _) = "Edm.Double" +columnToTypeString (EdmGuid _) = "Edm.EdmGuid" +columnToTypeString (EdmInt32 _) = "Edm.Int32" +columnToTypeString (EdmInt64 _) = "Edm.Int64" +columnToTypeString (EdmString _) = "Edm.String" + +-- | +-- Formats a column value to appear in the body of an Atom entry +-- +printEntityColumn :: EntityColumn -> Maybe String +printEntityColumn (EdmBinary (Just val)) = Just val +printEntityColumn (EdmBoolean (Just True)) = Just "true" +printEntityColumn (EdmBoolean (Just False)) = Just "false" +printEntityColumn (EdmDateTime (Just val)) = Just $ formatTime defaultTimeLocale atomDateFormat val +printEntityColumn (EdmDouble (Just val)) = Just $ show val +printEntityColumn (EdmGuid (Just val)) = Just val +printEntityColumn (EdmInt32 (Just val)) = Just $ show val +printEntityColumn (EdmInt64 (Just val)) = Just $ show val +printEntityColumn (EdmString (Just val)) = Just val +printEntityColumn _ = Nothing + +-- | +-- Formats a comparison type to appear in the query string +-- +printComparisonType :: ComparisonType -> String +printComparisonType Equal = "eq" +printComparisonType GreaterThan = "gt" +printComparisonType GreaterThanOrEqual = "ge" +printComparisonType LessThan = "lt" +printComparisonType LessThanOrEqual = "le" +printComparisonType NotEqual = "ne" + +-- | +-- Converts entity filter values into strings to appear in the filter +-- portion of the Query Entities URI. +-- +buildFilterString :: EntityFilter -> String +buildFilterString (And fs) = '(' : intercalate "%20and%20" (map buildFilterString fs) ++ ")" +buildFilterString (Or fs) = '(' : intercalate "%20or%20" (map buildFilterString fs) ++ ")" +buildFilterString (Not f) = + "(not%20" + ++ buildFilterString f + ++ ")" +buildFilterString (CompareBoolean prop val) = + urlEncode prop + ++ "%20eq%20" + ++ if val then "true" else "false" +buildFilterString (CompareDateTime prop cmp val) = + urlEncode prop + ++ "%20" + ++ printComparisonType cmp + ++ "%20datetime'" + ++ formatTime defaultTimeLocale atomDateFormat val + ++ "'" +buildFilterString (CompareDouble prop cmp val) = + urlEncode prop + ++ "%20" + ++ printComparisonType cmp + ++ "%20" + ++ show val +buildFilterString (CompareGuid prop val) = + urlEncode prop + ++ "%20eq%20guid'" + ++ val + ++ "'" +buildFilterString (CompareInt32 prop cmp val) = + urlEncode prop + ++ "%20" + ++ printComparisonType cmp + ++ "%20" + ++ show val +buildFilterString (CompareInt64 prop cmp val) = + urlEncode prop + ++ "%20" + ++ printComparisonType cmp + ++ "%20" + ++ show val +buildFilterString (CompareString prop cmp val) = + urlEncode prop + ++ "%20" + ++ printComparisonType cmp + ++ "%20'" + ++ urlEncode val + ++ "'" + +-- | +-- Constructs the full query string for the Query Entities web method. +-- +buildQueryString :: EntityQuery -> String +buildQueryString query = + "$filter=" + ++ maybe "" buildFilterString (eqFilter query) + ++ "&$top=" + ++ maybe "" show (eqPageSize query)
src/Network/TableStorage/Response.hs view
@@ -1,82 +1,79 @@--- |--- Helper methods for parsing web method response bodies. -----module Network.TableStorage.Response (- parseError, errorToString,- parseEmptyResponse, parseXmlResponseOrError,- parseEntityColumn-) where--import Data.Time ( readTime )-import System.Locale ( defaultTimeLocale )-import Text.XML.Light- ( Element(elName), parseXMLDoc, findChild, strContent )-import Control.Monad ( guard )-import Data.Maybe ( fromMaybe )-import Network.TableStorage.Atom ( qualifyMetadata )-import Network.TableStorage.Types ( EntityColumn(..) )-import Network.TableStorage.Format ( atomDateFormat )-import Network.HTTP.Base- ( ResponseCode, Response(rspBody, rspCode), Response_String )---- |--- Extracts the error message from an error response ----parseError :: Element -> Maybe String-parseError root = do- guard $ qualifyMetadata "error" == elName root- message <- findChild (qualifyMetadata "message") root- return $ strContent message---- |--- Summarize an error appearing in a response body or return "Unknown error" if the response cannot be parsed----errorToString :: Response_String -> String-errorToString res = fromMaybe "Unknown error" (parseXMLDoc (rspBody res) >>= parseError)---- |--- Verifies a response code, parsing an error message if necessary.----parseEmptyResponse :: ResponseCode -> Response_String -> Either String ()-parseEmptyResponse code res = - if rspCode res == code - then- Right ()- else- Left $ errorToString res---- |--- Parse an XML response, or an error response as appropriate.----parseXmlResponseOrError :: ResponseCode -> (Element -> Maybe a) -> Response_String -> Either String a-parseXmlResponseOrError code parse res = - let xmlDoc = parseXMLDoc (rspBody res) in- if rspCode res == code - then- maybe (Left "Unable to parse result") Right $ xmlDoc >>= parse- else- Left $ fromMaybe "Unknown error" (xmlDoc >>= parseError)---- |--- Parses an entity column type and value----parseEntityColumn :: Bool -> String -> String -> Maybe EntityColumn-parseEntityColumn True "Edm.Binary" _ = Just $ EdmBinary Nothing-parseEntityColumn False "Edm.Binary" val = Just $ EdmBinary $ Just val-parseEntityColumn True "Edm.Boolean" _ = Just $ EdmBoolean Nothing-parseEntityColumn False "Edm.Boolean" "true" = Just $ EdmBoolean $ Just True-parseEntityColumn False "Edm.Boolean" "false" = Just $ EdmBoolean $ Just False-parseEntityColumn True "Edm.DateTime" _ = Just $ EdmDateTime Nothing-parseEntityColumn False "Edm.DateTime" val = Just $ EdmDateTime $ Just $ readTime defaultTimeLocale atomDateFormat val-parseEntityColumn True "Edm.Double" _ = Just $ EdmDouble Nothing-parseEntityColumn False "Edm.Double" val = Just $ EdmDouble $ Just $ read val-parseEntityColumn True "Edm.Guid" _ = Just $ EdmGuid Nothing-parseEntityColumn False "Edm.Guid" val = Just $ EdmGuid $ Just val-parseEntityColumn True "Edm.Int32" _ = Just $ EdmInt32 Nothing-parseEntityColumn False "Edm.Int32" val = Just $ EdmInt32 $ Just $ read val-parseEntityColumn True "Edm.Int64" _ = Just $ EdmInt64 Nothing-parseEntityColumn False "Edm.Int64" val = Just $ EdmInt64 $ Just $ read val-parseEntityColumn True "Edm.String" _ = Just $ EdmString Nothing-parseEntityColumn False "Edm.String" val = Just $ EdmString $ Just val+-- | +-- Helper methods for parsing web method response bodies. +-- + +module Network.TableStorage.Response ( + parseError, + parseEmptyResponse, parseXmlResponseOrError, + parseEntityColumn +) where + +import Data.Time ( readTime ) +import System.Locale ( defaultTimeLocale ) +import Text.XML.Light + ( Element(elName), parseXMLDoc, findChild, strContent ) +import Network.TableStorage.Atom +import Network.TableStorage.Types +import Network.TableStorage.Format +import Network.HTTP.Types +import Control.Monad.Error + +-- | +-- Extracts the error message from an error response +-- +parseErrorMaybe :: Element -> Maybe String +parseErrorMaybe root = do + guard $ qualifyMetadata "error" == elName root + message <- findChild (qualifyMetadata "message") root + return $ strContent message + +parseError :: Maybe Element -> TableError +parseError e = case e >>= parseErrorMaybe of + Nothing -> TableUnknownError + Just s -> TableOtherError s + +-- | +-- Verifies a response status, parsing an error message if necessary. +-- +parseEmptyResponse :: Status -> QueryResponse -> Either TableError () +parseEmptyResponse status (QueryResponse rspStatus rspBody) = + if rspStatus == status + then + Right () + else + Left $ parseError $ parseXMLDoc rspBody + +-- | +-- Parse an XML response, or an error response as appropriate. +-- +parseXmlResponseOrError :: Status -> (Element -> Maybe a) -> QueryResponse -> Either TableError a +parseXmlResponseOrError status parse (QueryResponse rspStatus rspBody) = + let xmlDoc = parseXMLDoc rspBody in + if rspStatus == status + then + maybe (Left TableUnknownError) Right $ xmlDoc >>= parse + else + Left $ parseError xmlDoc + +-- | +-- Parses an entity column type and value +-- +parseEntityColumn :: Bool -> String -> String -> Maybe EntityColumn +parseEntityColumn True "Edm.Binary" _ = Just $ EdmBinary Nothing +parseEntityColumn False "Edm.Binary" val = Just $ EdmBinary $ Just val +parseEntityColumn True "Edm.Boolean" _ = Just $ EdmBoolean Nothing +parseEntityColumn False "Edm.Boolean" "true" = Just $ EdmBoolean $ Just True +parseEntityColumn False "Edm.Boolean" "false" = Just $ EdmBoolean $ Just False +parseEntityColumn True "Edm.DateTime" _ = Just $ EdmDateTime Nothing +parseEntityColumn False "Edm.DateTime" val = Just $ EdmDateTime $ Just $ readTime defaultTimeLocale atomDateFormat val +parseEntityColumn True "Edm.Double" _ = Just $ EdmDouble Nothing +parseEntityColumn False "Edm.Double" val = Just $ EdmDouble $ Just $ read val +parseEntityColumn True "Edm.Guid" _ = Just $ EdmGuid Nothing +parseEntityColumn False "Edm.Guid" val = Just $ EdmGuid $ Just val +parseEntityColumn True "Edm.Int32" _ = Just $ EdmInt32 Nothing +parseEntityColumn False "Edm.Int32" val = Just $ EdmInt32 $ Just $ read val +parseEntityColumn True "Edm.Int64" _ = Just $ EdmInt64 Nothing +parseEntityColumn False "Edm.Int64" val = Just $ EdmInt64 $ Just $ read val +parseEntityColumn True "Edm.String" _ = Just $ EdmString Nothing +parseEntityColumn False "Edm.String" val = Just $ EdmString $ Just val parseEntityColumn _ _ _ = Nothing
src/Network/TableStorage/Types.hs view
@@ -1,127 +1,169 @@--- |--- Data types used to construct the various web method requests. ----module Network.TableStorage.Types (- AccountKey(..),- Signature(..),- AuthHeader(..),- Account(..),- SharedKeyAuth(..),- EntityKey(..),- EntityColumn(..),- Entity(..),- EntityQuery(..),- ComparisonType(..),- EntityFilter(..)-) where--import Data.Time ( UTCTime )-import Network.HTTP.Base ( RequestMethod )---- |--- The Base-64 encoded account secret key----newtype AccountKey = AccountKey { unAccountKey :: String } deriving (Show, Eq)---- |--- The type of authorization header signatures ----newtype Signature = Signature { unSignature :: String } deriving (Show, Eq)---- |--- The type of authorization headers ----newtype AuthHeader = AuthHeader { unAuthHeader :: String } deriving (Show, Eq)---- |--- Account information: host, port, secret key and account name ----data Account = Account - { accountScheme :: String- , accountHost :: String- , accountPort :: Int- , accountKey :: AccountKey- , accountName :: String- , accountResourcePrefix :: String - } deriving (Show, Eq)---- |--- The unencrypted content of the Shared Key authorization header ----data SharedKeyAuth = SharedKeyAuth - { sharedKeyAuthVerb :: RequestMethod- , sharedKeyAuthContentMD5 :: String- , sharedKeyAuthContentType :: String- , sharedKeyAuthDate :: String- , sharedKeyAuthCanonicalizedResource :: String- } deriving (Show, Eq)---- |--- Uniquely identifies an entity in a table : a partition key and row key pair. ----data EntityKey = EntityKey - { ekPartitionKey :: String- , ekRowKey :: String - } deriving (Show, Eq)---- |--- Represents a column in an entity.--- --- The constructor used indicates the data type of the column represented.------ For certain operations, the type must match the type of data stored in the table.----data EntityColumn = - EdmBinary (Maybe String) |- EdmBoolean (Maybe Bool) |- EdmDateTime (Maybe UTCTime) |- EdmDouble (Maybe Double) |- EdmGuid (Maybe String) |- EdmInt32 (Maybe Int) |- EdmInt64 (Maybe Int) |- EdmString (Maybe String)- deriving (Show, Eq)---- |--- An entity consists of a key and zero or more additional columns.----data Entity = Entity { entityKey :: EntityKey,- entityColumns :: [(String, EntityColumn)] } deriving Show---- |--- An entity query consists of an optional filter and an optional number of entities to return.------ Projections are not currently supported. ----data EntityQuery = EntityQuery - { eqPageSize :: Maybe Int- , eqFilter :: Maybe EntityFilter - } deriving (Show, Eq)- --- |--- The various comparisons supported in entity queries. ----data ComparisonType = - Equal |- GreaterThan | - GreaterThanOrEqual | - LessThan |- LessThanOrEqual | - NotEqual - deriving (Show, Eq)- --- |--- The data type of entity filters ----data EntityFilter = - And [EntityFilter] | - Or [EntityFilter] | - Not EntityFilter | - CompareBoolean String Bool |- CompareDateTime String ComparisonType UTCTime |- CompareDouble String ComparisonType Double |- CompareGuid String String |- CompareInt32 String ComparisonType Integer |- CompareInt64 String ComparisonType Integer |- CompareString String ComparisonType String+-- | +-- Data types used to construct the various web method requests. +-- +module Network.TableStorage.Types ( + AccountKey(..), + Signature(..), + AuthHeader(..), + Account(..), + SharedKeyAuth(..), + EntityKey(..), + EntityColumn(..), + Entity(..), + EntityQuery(..), + ComparisonType(..), + EntityFilter(..), + QueryResponse(..), + TableStorage, + TableConf(..), + TableError(..) +) where + +import Data.Time ( UTCTime ) +import Network.HTTP.Types +import Network.HTTP.Conduit +import Control.Monad.Reader +import Control.Monad.Error + +-- | +-- Monad stack and return type of operations on azure tables +-- +type TableStorage = ErrorT TableError (ReaderT TableConf IO) + +-- | +-- TableStorage configuration data +-- +data TableConf = TableConf + { tableAccount :: Account + , httpManager :: Maybe Manager + , httpProxy :: Maybe Proxy + } + +-- | +-- Error type +-- +data TableError = TableParseError + | TableUnknownError + | TableOtherError String + +instance Error TableError where + noMsg = TableUnknownError + strMsg = TableOtherError + +instance Show TableError where + show TableParseError = "Unable to parse result" + show TableUnknownError = "Unknown table storage error" + show (TableOtherError msg) = msg + +-- | +-- The Base-64 encoded account secret key +-- +newtype AccountKey = AccountKey { unAccountKey :: String } deriving (Show, Eq) + +-- | +-- The type of authorization header signatures +-- +newtype Signature = Signature { unSignature :: String } deriving (Show, Eq) + +-- | +-- The type of authorization headers +-- +newtype AuthHeader = AuthHeader { unAuthHeader :: String } deriving (Show, Eq) + +-- | +-- Account information: host, port, secret key and account name +-- +data Account = Account + { accountScheme :: String + , accountHost :: String + , accountPort :: Int + , accountKey :: AccountKey + , accountName :: String + , accountResourcePrefix :: String + } deriving (Show, Eq) + +-- | +-- The unencrypted content of the Shared Key authorization header +-- +data SharedKeyAuth = SharedKeyAuth + { sharedKeyAuthVerb :: Method + , sharedKeyAuthContentMD5 :: String + , sharedKeyAuthContentType :: String + , sharedKeyAuthDate :: String + , sharedKeyAuthCanonicalizedResource :: String + } deriving (Show, Eq) + +-- | +-- Uniquely identifies an entity in a table : a partition key and row key pair. +-- +data EntityKey = EntityKey + { ekPartitionKey :: String + , ekRowKey :: String + } deriving (Show, Eq) + +-- | +-- Represents a column in an entity. +-- +-- The constructor used indicates the data type of the column represented. +-- +-- For certain operations, the type must match the type of data stored in the table. +-- +data EntityColumn = + EdmBinary (Maybe String) | + EdmBoolean (Maybe Bool) | + EdmDateTime (Maybe UTCTime) | + EdmDouble (Maybe Double) | + EdmGuid (Maybe String) | + EdmInt32 (Maybe Int) | + EdmInt64 (Maybe Int) | + EdmString (Maybe String) + deriving (Show, Eq) + +-- | +-- Exception handling type. +-- +data QueryResponse = QueryResponse Status String + +-- | +-- An entity consists of a key and zero or more additional columns. +-- +data Entity = Entity { entityKey :: EntityKey, + entityColumns :: [(String, EntityColumn)] } deriving Show + +-- | +-- An entity query consists of an optional filter and an optional number of entities to return. +-- +-- Projections are not currently supported. +-- +data EntityQuery = EntityQuery + { eqPageSize :: Maybe Int + , eqFilter :: Maybe EntityFilter + } deriving (Show, Eq) + +-- | +-- The various comparisons supported in entity queries. +-- +data ComparisonType = + Equal | + GreaterThan | + GreaterThanOrEqual | + LessThan | + LessThanOrEqual | + NotEqual + deriving (Show, Eq) + +-- | +-- The data type of entity filters +-- +data EntityFilter = + And [EntityFilter] | + Or [EntityFilter] | + Not EntityFilter | + CompareBoolean String Bool | + CompareDateTime String ComparisonType UTCTime | + CompareDouble String ComparisonType Double | + CompareGuid String String | + CompareInt32 String ComparisonType Integer | + CompareInt64 String ComparisonType Integer | + CompareString String ComparisonType String deriving (Show, Eq)
src/Network/TableStorage/XML.hs view
@@ -1,37 +1,37 @@--- |--- Helper methods for working with XML -----module Network.TableStorage.XML (- qualify, cDataText, namespaceAttr-) where--import Text.XML.Light.Types- ( Content(Text),- CDataKind(CDataText),- CData(CData, cdData, cdLine, cdVerbatim),- QName(..),- Attr(..) )---- |--- Qualify a name for a specific namespace and/or prefix ----qualify :: Maybe String -> Maybe String -> String -> QName-qualify namespace prefix name = - QName { qName = name,- qURI = namespace,- qPrefix = prefix }---- |--- Constructs a piece of content consisting of a single string.----cDataText :: String -> [Content]-cDataText content = [ Text CData { cdVerbatim = CDataText, cdData = content, cdLine = Nothing } ]---- |--- Constructs an xmlns attribute to be added to the document root ----namespaceAttr :: String -> String -> Attr-namespaceAttr prefix uri =- Attr { attrKey = qualify Nothing (Just "xmlns") prefix,+-- | +-- Helper methods for working with XML +-- + +module Network.TableStorage.XML ( + qualify, cDataText, namespaceAttr +) where + +import Text.XML.Light.Types + ( Content(Text), + CDataKind(CDataText), + CData(CData, cdData, cdLine, cdVerbatim), + QName(..), + Attr(..) ) + +-- | +-- Qualify a name for a specific namespace and/or prefix +-- +qualify :: Maybe String -> Maybe String -> String -> QName +qualify namespace prefix name = + QName { qName = name, + qURI = namespace, + qPrefix = prefix } + +-- | +-- Constructs a piece of content consisting of a single string. +-- +cDataText :: String -> [Content] +cDataText content = [ Text CData { cdVerbatim = CDataText, cdData = content, cdLine = Nothing } ] + +-- | +-- Constructs an xmlns attribute to be added to the document root +-- +namespaceAttr :: String -> String -> Attr +namespaceAttr prefix uri = + Attr { attrKey = qualify Nothing (Just "xmlns") prefix, attrVal = uri }
tablestorage.cabal view
@@ -1,51 +1,59 @@-name: tablestorage-version: 0.1.0.3-cabal-version: >= 1.2-build-type: Simple-author: Phil Freeman <paf31-at-cantab.net>-stability: experimental-maintainer: Phil Freeman <paf31@cantab.net>-homepage: http://github.com/paf31/tablestorage-category: Web, Database, API-license: BSD3-copyright: (c) Phil Freeman 2012-data-files: - LICENSE, - tablestorage.cabal-tested-with: GHC==7.0.4-license-file: LICENSE-synopsis: Azure Table Storage REST API Wrapper-description: - A collection of functions to call the methods of the Azure Table Storage REST API from Haskell.- Table and entity level functions are supported along with shared key authentication token generation, and error handling. - Pagination and projections are currently not supported.--library- hs-source-dirs: src+name: tablestorage +version: 0.2.1.0 +cabal-version: >= 1.2 +build-type: Simple +author: Phil Freeman, Aaron Friel +stability: experimental +maintainer: Phil Freeman <paf31@cantab.net> +homepage: http://github.com/paf31/tablestorage +category: Web, Database, API +license: BSD3 +copyright: (c) Phil Freeman, Aaron Friel 2012 +data-files: + LICENSE, + tablestorage.cabal +tested-with: GHC==7.0.4 +license-file: LICENSE +synopsis: Azure Table Storage REST API Wrapper +description: + A collection of functions to call the methods of the Azure Table Storage REST API from Haskell. + Table and entity level functions are supported along with shared key authentication token generation, and error handling. + Pagination and projections are currently not supported. + +library + ghc-options: -W -Wall + hs-source-dirs: src build-depends: base >= 4 && < 5, SHA, bytestring, utf8-string, base64-bytestring, - HTTP, + http-conduit >= 1.8.5, + conduit, + http-types, network, time, xml, old-locale, - mtl - ghc-options: -Wall- exposed-modules: - Network.TableStorage,- Network.TableStorage.API,- Network.TableStorage.Auth,- Network.TableStorage.Development,- Network.TableStorage.Query,- Network.TableStorage.Types- other-modules: - Network.TableStorage.Atom,- Network.TableStorage.Format,- Network.TableStorage.Request,- Network.TableStorage.Response,- Network.TableStorage.XML-+ mtl, + transformers, + crypto-api, + cryptohash, + HTTP, + resourcet + ghc-options: -Wall + exposed-modules: + Network.TableStorage, + Network.TableStorage.API, + Network.TableStorage.Auth, + Network.TableStorage.Development, + Network.TableStorage.Query, + Network.TableStorage.Types + other-modules: + Network.TableStorage.Atom, + Network.TableStorage.Format, + Network.TableStorage.Request, + Network.TableStorage.Response, + Network.TableStorage.XML +