packages feed

tablestorage 0.1 → 0.1.0.1

raw patch · 13 files changed

+802/−808 lines, 13 filesdep +old-localedep −haskell98setup-changed

Dependencies added: old-locale

Dependencies removed: haskell98

Files

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
+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.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple+main = defaultMain
src/Network/TableStorage.hs view
@@ -1,15 +1,15 @@--- | 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
+-- | 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
src/Network/TableStorage/API.hs view
@@ -1,191 +1,190 @@--- |
--- This module provides functions wrapping the Azure REST API web methods.
-
-module Network.TableStorage.API (
-  queryTables, createTable, deleteTable,
-  insertEntity, updateEntity, mergeEntity, deleteEntity, 
-  queryEntity, queryEntities, defaultEntityQuery
-) where
-
-import Network.HTTP
-import Text.XML.Light
-import Text.Printf
-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)
-
--- |
--- 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 entry = do
-    content <- findChild (qualifyAtom "content") entry
-    properties <- findChild (qualifyMetadata "properties") content
-    tableName <- findChild (qualifyDataServices "TableName") properties
-    return $ strContent tableName
-
--- |
--- List the names of tables for an account or returns an error message
---
-queryTables :: Account -> IO (Either String [String])
-queryTables acc = do
-  let resource = printf "/%s/Tables" $ accountName acc
-  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 = printf "/%s/Tables" (accountName acc)
-  requestXml <- createTableXml tableName
-  response <- authenticatedRequest acc POST [] resource resource $ showTopElement requestXml
-  return $ response >>= parseEmptyResponse (2, 0, 1)
-
--- |
--- Deletes the table with the specified name or returns an error message
---
-deleteTable :: Account -> String -> IO (Either String ())
-deleteTable acc tableName = do 
-  let resource = printf "/%s/Tables('%s')" (accountName acc) 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 = printf "/%s/%s" (accountName acc) 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 acc 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 acc 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
-    content <- findChild (qualifyAtom "content") entry
-    properties <- findChild (qualifyMetadata "properties") content
-    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 = fromMaybe False $ fmap ("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 acc 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 = printf "/%s/%s()" (accountName acc) tableName
-  let queryString = buildQueryString query
-  let resource = printf "%s?%s" canonicalizedResource queryString
-  print 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,
+-- |+-- This module provides functions wrapping the Azure REST API web methods.++module Network.TableStorage.API (+  queryTables, createTable, deleteTable,+  insertEntity, updateEntity, mergeEntity, deleteEntity, +  queryEntity, queryEntities, defaultEntityQuery+) where++import Network.HTTP+import Text.XML.Light+import Text.Printf+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)++-- |+-- 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 entry = do+    content <- findChild (qualifyAtom "content") entry+    properties <- findChild (qualifyMetadata "properties") content+    tableName <- findChild (qualifyDataServices "TableName") properties+    return $ strContent tableName++-- |+-- List the names of tables for an account or returns an error message+--+queryTables :: Account -> IO (Either String [String])+queryTables acc = do+  let resource = printf "/%s/Tables" $ accountName acc+  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 = printf "/%s/Tables" (accountName acc)+  requestXml <- createTableXml tableName+  response <- authenticatedRequest acc POST [] resource resource $ showTopElement requestXml+  return $ response >>= parseEmptyResponse (2, 0, 1)++-- |+-- Deletes the table with the specified name or returns an error message+--+deleteTable :: Account -> String -> IO (Either String ())+deleteTable acc tableName = do +  let resource = printf "/%s/Tables('%s')" (accountName acc) 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 = printf "/%s/%s" (accountName acc) 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 acc 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 acc 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+    content <- findChild (qualifyAtom "content") entry+    properties <- findChild (qualifyMetadata "properties") content+    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 acc 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 = printf "/%s/%s()" (accountName acc) tableName+  let queryString = buildQueryString query+  let resource = printf "%s?%s" 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 }
src/Network/TableStorage/Atom.hs view
@@ -1,74 +1,74 @@--- |
--- Functions for constructing and parsing Atom feeds for use in the 
--- request and response bodies of the various web methods.
---
-
-module Network.TableStorage.Atom where
-
-import Network.TableStorage.XML
-import Network.TableStorage.Format
-import Text.XML.Light
-
-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 where++import Network.TableStorage.XML+import Network.TableStorage.Format+import Text.XML.Light++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 +      ]    ]
src/Network/TableStorage/Auth.hs view
@@ -1,105 +1,105 @@--- |
--- 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
-import Network.URI
-import Network.HTTP
-import Network.HTTP.Base ( )
-import Network.Stream ( Result )
-import Network.TableStorage.Types
-import Network.TableStorage.Format
-import Text.Printf ( printf )
-
-authenticationType :: String
-authenticationType = "SharedKey"
-
--- |
--- Constructs the unencrypted content of the Shared Key authentication token 
---
-printSharedKeyAuth :: SharedKeyAuth -> String
-printSharedKeyAuth auth = printf "%s\n%s\n%s\n%s\n%s"
-  (show (sharedKeyAuthVerb auth))
-  (sharedKeyAuthContentMD5 auth)
-  (sharedKeyAuthContentType auth)
-  (sharedKeyAuthDate auth)
-  (sharedKeyAuthCanonicalizedResource auth)
-
-hmacSha256' :: AccountKey -> String -> B.ByteString
-hmacSha256' base64Key = 
-  let (Right key) = Base64C.decode $ UTF8.fromString 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 = 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 = printf "%s %s:%s"
-  authenticationType 
-  (accountName acc) 
-  (signature (accountKey acc) auth)
-
--- |
--- Constructs an absolute URI from an Account and relative URI 
---
-qualifyResource :: String -> Account -> URI
-qualifyResource res acc =
-  URI { uriScheme = "http",
-        uriAuthority =  
-          Just URIAuth { uriRegName = accountHost acc, 
-                         uriPort = ':' : show (accountPort acc),
-                         uriUserInfo = "" },
-        uriQuery = "",
-        uriFragment = "",
-        uriPath = 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 ++ canonicalizedResource }
-  let basicHeaders = [ Header HdrAuthorization (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
+-- |+-- 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+import Network.URI+import Network.HTTP+import Network.HTTP.Base ( )+import Network.Stream ( Result )+import Network.TableStorage.Types+import Network.TableStorage.Format+import Text.Printf ( printf )++authenticationType :: String+authenticationType = "SharedKey"++-- |+-- Constructs the unencrypted content of the Shared Key authentication token +--+printSharedKeyAuth :: SharedKeyAuth -> String+printSharedKeyAuth auth = printf "%s\n%s\n%s\n%s\n%s"+  (show (sharedKeyAuthVerb auth))+  (sharedKeyAuthContentMD5 auth)+  (sharedKeyAuthContentType auth)+  (sharedKeyAuthDate auth)+  (sharedKeyAuthCanonicalizedResource auth)++hmacSha256' :: AccountKey -> String -> B.ByteString+hmacSha256' base64Key = +  let (Right key) = Base64C.decode $ UTF8.fromString 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 = 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 = printf "%s %s:%s"+  authenticationType +  (accountName acc) +  (signature (accountKey acc) auth)++-- |+-- Constructs an absolute URI from an Account and relative URI +--+qualifyResource :: String -> Account -> URI+qualifyResource res acc =+  URI { uriScheme = "http",+        uriAuthority =  +          Just URIAuth { uriRegName = accountHost acc, +                         uriPort = ':' : show (accountPort acc),+                         uriUserInfo = "" },+        uriQuery = "",+        uriFragment = "",+        uriPath = 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 ++ canonicalizedResource }+  let basicHeaders = [ Header HdrAuthorization (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
src/Network/TableStorage/Development.hs view
@@ -1,30 +1,30 @@--- |
--- This module contains constants for working with the storage emulator.  
---
-
-module Network.TableStorage.Development (
-  developmentAccount
-) where
-
-import Network.TableStorage.Types
-
-developmentAccountName :: String
-developmentAccountName = "devstoreaccount1"
-
-developmentKey :: AccountKey
-developmentKey = "Eby8vdM02xNOcqFlqUwJPLlmEtlCDXJ1OUzFT50uSRZ6IFsuFq2UVErCz4I6tq/K1SZFPTOtr/KBHBeksoGMGw=="
-
-developmentHost :: String
-developmentHost = "127.0.0.1"
-
-developmentPort :: Int
-developmentPort = 10002
-
--- |
--- An account for the storage emulator
---
-developmentAccount :: Account
-developmentAccount = Account { accountName = developmentAccountName,
-                               accountKey = developmentKey, 
-                               accountHost = developmentHost,
+-- |+-- This module contains constants for working with the storage emulator.  +--++module Network.TableStorage.Development (+  developmentAccount+) where++import Network.TableStorage.Types++developmentAccountName :: String+developmentAccountName = "devstoreaccount1"++developmentKey :: AccountKey+developmentKey = "Eby8vdM02xNOcqFlqUwJPLlmEtlCDXJ1OUzFT50uSRZ6IFsuFq2UVErCz4I6tq/K1SZFPTOtr/KBHBeksoGMGw=="++developmentHost :: String+developmentHost = "127.0.0.1"++developmentPort :: Int+developmentPort = 10002++-- |+-- An account for the storage emulator+--+developmentAccount :: Account+developmentAccount = Account { accountName = developmentAccountName,+                               accountKey = developmentKey, +                               accountHost = developmentHost,                                accountPort = developmentPort }
src/Network/TableStorage/Format.hs view
@@ -1,24 +1,23 @@--- |
--- Helper methods for working with formatted dates
---
-
-module Network.TableStorage.Format where
-
-import Locale
-import Data.Time.Clock
-import Data.Time.Format
-
-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 where++import Data.Time+import System.Locale++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/Request.hs view
@@ -1,103 +1,103 @@--- |
--- Helper methods used to construct requests.
---
-
-module Network.TableStorage.Request where
-
-import Data.Maybe (fromMaybe)
-import Data.List (intercalate)
-import Text.XML.Light.Types (elAttribs)
-import Text.XML.Light
-import Network.TableStorage.Types
-import Network.TableStorage.XML
-import Network.TableStorage.Atom
-import Network.TableStorage.Format
-import Network.HTTP.Base
-import Text.Printf (printf)
-import Data.Time.Format (formatTime)
-import Locale (defaultTimeLocale)
-
--- |
--- 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 :: Account -> String -> EntityKey -> String
-entityKeyResource acc tableName key = printf "/%s/%s(PartitionKey='%s',RowKey='%s')" 
-  (accountName acc) 
-  tableName 
-  (ekPartitionKey key) 
-  (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 $ printf "%f" val
-printEntityColumn (EdmGuid (Just val))         = Just val
-printEntityColumn (EdmInt32 (Just val))        = Just $ printf "%d" val
-printEntityColumn (EdmInt64 (Just val))        = Just $ printf "%d" val
-printEntityColumn (EdmString (Just val))       = Just val
-printEntityColumn _                            = Nothing
-
-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) = printf "(%s)" $ intercalate "%%20and%%20" $ map buildFilterString fs
-buildFilterString (Or fs) = printf "(%s)" $ intercalate "%%20or%%20" $ map buildFilterString fs
-buildFilterString (Not f) = "(not%%20" ++ buildFilterString f ++ ")"
-buildFilterString (CompareBoolean prop val) = printf "%s%%20eq%%20%s" (urlEncode prop) (if val then "true" else "false")
-buildFilterString (CompareDateTime prop cmp val) = printf "%s%%20%s%%20datetime'%s'" (urlEncode prop) (printComparisonType cmp) (formatTime defaultTimeLocale atomDateFormat val)
-buildFilterString (CompareDouble prop cmp val) = printf "%s%%20%s%%20%f" (urlEncode prop) (printComparisonType cmp) val
-buildFilterString (CompareGuid prop val) = printf "%s%%20eq%%20guid'%s'" (urlEncode prop) val
-buildFilterString (CompareInt32 prop cmp val) = printf "%s%%20%s%%20%d" (urlEncode prop) (printComparisonType cmp) val
-buildFilterString (CompareInt64 prop cmp val) = printf "%s%%20%s%%20%d" (urlEncode prop) (printComparisonType cmp) val
-buildFilterString (CompareString prop cmp val) = printf "%s%%20%s%%20'%s'" (urlEncode prop) (printComparisonType cmp) (urlEncode val)
-
--- |
--- Constructs the full query string for the Query Entities web method. 
---
-buildQueryString :: EntityQuery -> String
-buildQueryString query = printf "$filter=%s&$top=%s"
-  (maybe "" buildFilterString $ eqFilter query)
+-- |+-- Helper methods used to construct requests.+--++module Network.TableStorage.Request where++import Data.Time+import System.Locale+import Data.Maybe (fromMaybe)+import Data.List (intercalate)+import Text.XML.Light.Types (elAttribs)+import Text.XML.Light+import Network.TableStorage.Types+import Network.TableStorage.XML+import Network.TableStorage.Atom+import Network.TableStorage.Format+import Network.HTTP.Base+import Text.Printf (printf)++-- |+-- 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 :: Account -> String -> EntityKey -> String+entityKeyResource acc tableName key = printf "/%s/%s(PartitionKey='%s',RowKey='%s')" +  (accountName acc) +  tableName +  (ekPartitionKey key) +  (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 $ printf "%f" val+printEntityColumn (EdmGuid (Just val))         = Just val+printEntityColumn (EdmInt32 (Just val))        = Just $ printf "%d" val+printEntityColumn (EdmInt64 (Just val))        = Just $ printf "%d" val+printEntityColumn (EdmString (Just val))       = Just val+printEntityColumn _                            = Nothing++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) = printf "(%s)" $ intercalate "%%20and%%20" $ map buildFilterString fs+buildFilterString (Or fs) = printf "(%s)" $ intercalate "%%20or%%20" $ map buildFilterString fs+buildFilterString (Not f) = "(not%%20" ++ buildFilterString f ++ ")"+buildFilterString (CompareBoolean prop val) = printf "%s%%20eq%%20%s" (urlEncode prop) (if val then "true" else "false")+buildFilterString (CompareDateTime prop cmp val) = printf "%s%%20%s%%20datetime'%s'" (urlEncode prop) (printComparisonType cmp) (formatTime defaultTimeLocale atomDateFormat val)+buildFilterString (CompareDouble prop cmp val) = printf "%s%%20%s%%20%f" (urlEncode prop) (printComparisonType cmp) val+buildFilterString (CompareGuid prop val) = printf "%s%%20eq%%20guid'%s'" (urlEncode prop) val+buildFilterString (CompareInt32 prop cmp val) = printf "%s%%20%s%%20%d" (urlEncode prop) (printComparisonType cmp) val+buildFilterString (CompareInt64 prop cmp val) = printf "%s%%20%s%%20%d" (urlEncode prop) (printComparisonType cmp) val+buildFilterString (CompareString prop cmp val) = printf "%s%%20%s%%20'%s'" (urlEncode prop) (printComparisonType cmp) (urlEncode val)++-- |+-- Constructs the full query string for the Query Entities web method. +--+buildQueryString :: EntityQuery -> String+buildQueryString query = printf "$filter=%s&$top=%s"+  (maybe "" buildFilterString $ eqFilter query)   (maybe "" show $ eqPageSize query)
src/Network/TableStorage/Response.hs view
@@ -1,70 +1,70 @@--- |
--- Helper methods for parsing web method response bodies. 
---
-
-module Network.TableStorage.Response where
-
-import Text.XML.Light
-import Control.Monad (guard)
-import Data.Maybe (fromMaybe)
-import Network.TableStorage.Atom
-import Network.TableStorage.Types
-import Network.TableStorage.Format
-import Network.HTTP.Base
-import Data.Time.Format (readTime)
-import Locale (defaultTimeLocale)
-
--- |
--- 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
-
--- |
--- 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 $ fromMaybe "Unknown error" (parseXMLDoc (rspBody res) >>= parseError)
-
--- |
--- 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 where++import Data.Time+import System.Locale+import Text.XML.Light+import Control.Monad (guard)+import Data.Maybe (fromMaybe)+import Network.TableStorage.Atom+import Network.TableStorage.Types+import Network.TableStorage.Format+import Network.HTTP.Base++-- |+-- 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++-- |+-- 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 $ fromMaybe "Unknown error" (parseXMLDoc (rspBody res) >>= parseError)++-- |+-- 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 parseEntityColumn _     _              _        = Nothing
src/Network/TableStorage/Types.hs view
@@ -1,106 +1,106 @@--- |
--- Data types used to construct the various web method requests. 
---
-
-module Network.TableStorage.Types where
-
-import Data.Time
-import Network.HTTP.Base
-
--- |
--- The Base-64 encoded account secret key
---
-type AccountKey = String
-
--- |
--- The type of authorization header signatures 
---
-type Signature = String
-
--- |
--- The type of authorization headers 
---
-type AuthHeader = String
-
--- |
--- Account information: host, port, secret key and account name 
---
-data Account = Account { accountHost :: String,
-                         accountPort :: Int,
-                         accountKey  :: AccountKey,
-                         accountName :: String } deriving Show               
-
--- |
--- The unencrypted content of the Shared Key authorization header 
---
-data SharedKeyAuth = SharedKeyAuth { sharedKeyAuthVerb                  :: RequestMethod,
-                                     sharedKeyAuthContentMD5            :: String,
-                                     sharedKeyAuthContentType           :: String,
-                                     sharedKeyAuthDate                  :: String,
-                                     sharedKeyAuthCanonicalizedResource :: String } deriving Show
-
--- |
--- Uniquely identifies an entity in a table : a partition key and row key pair. 
---
-data EntityKey = EntityKey { ekPartitionKey :: String,
-                             ekRowKey       :: String } deriving Show
-
--- |
--- 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
-
--- |
--- 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
-                                 
--- |
--- The various comparisons supported in entity queries. 
---
-data ComparisonType = 
-  Equal |
-  GreaterThan | 
-  GreaterThanOrEqual | 
-  LessThan |
-  LessThanOrEqual | 
-  NotEqual 
-  deriving Show
-                                 
--- |
--- 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 where++import Data.Time+import Network.HTTP.Base++-- |+-- The Base-64 encoded account secret key+--+type AccountKey = String++-- |+-- The type of authorization header signatures +--+type Signature = String++-- |+-- The type of authorization headers +--+type AuthHeader = String++-- |+-- Account information: host, port, secret key and account name +--+data Account = Account { accountHost :: String,+                         accountPort :: Int,+                         accountKey  :: AccountKey,+                         accountName :: String } deriving Show               ++-- |+-- The unencrypted content of the Shared Key authorization header +--+data SharedKeyAuth = SharedKeyAuth { sharedKeyAuthVerb                  :: RequestMethod,+                                     sharedKeyAuthContentMD5            :: String,+                                     sharedKeyAuthContentType           :: String,+                                     sharedKeyAuthDate                  :: String,+                                     sharedKeyAuthCanonicalizedResource :: String } deriving Show++-- |+-- Uniquely identifies an entity in a table : a partition key and row key pair. +--+data EntityKey = EntityKey { ekPartitionKey :: String,+                             ekRowKey       :: String } deriving Show++-- |+-- 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++-- |+-- 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+                                 +-- |+-- The various comparisons supported in entity queries. +--+data ComparisonType = +  Equal |+  GreaterThan | +  GreaterThanOrEqual | +  LessThan |+  LessThanOrEqual | +  NotEqual +  deriving Show+                                 +-- |+-- 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
src/Network/TableStorage/XML.hs view
@@ -1,30 +1,30 @@--- |
--- Helper methods for working with XML 
---
-
-module Network.TableStorage.XML where
-
-import Text.XML.Light.Types
-
--- |
--- 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 where++import Text.XML.Light.Types++-- |+-- 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,31 +1,27 @@-name:           tablestorage
-version:        0.1
-cabal-version:  >= 1.6
-build-type:     Simple
-author:         Phil Freeman <paf31-at-cantab.net>
-stability:      experimental
-maintainer:     Phil Freeman <paf31-at-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.
-
-source-repository head
-  type:     git
-  location: git://github.com/paf31/tablestorage.git
-
-library
-  hs-source-dirs:  src
+name:           tablestorage+version:        0.1.0.1+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   build-depends:   
                    base >= 4 && < 5,
                    SHA,
@@ -35,19 +31,19 @@                    HTTP,
                    network,
                    time,
-                   haskell98,
-                   xml
-  ghc-options:     -Wall
-  exposed-modules: 
-                   Network.TableStorage,
-                   Network.TableStorage.API,
-                   Network.TableStorage.Auth,
-                   Network.TableStorage.Development,
-                   Network.TableStorage.Types
-  other-modules:   
-                   Network.TableStorage.Atom,
-                   Network.TableStorage.Format,
-                   Network.TableStorage.Request,
-                   Network.TableStorage.Response,
-                   Network.TableStorage.XML
-
+                   xml,
+                   old-locale
+  ghc-options:     -Wall+  exposed-modules: +                   Network.TableStorage,+                   Network.TableStorage.API,+                   Network.TableStorage.Auth,+                   Network.TableStorage.Development,+                   Network.TableStorage.Types+  other-modules:   +                   Network.TableStorage.Atom,+                   Network.TableStorage.Format,+                   Network.TableStorage.Request,+                   Network.TableStorage.Response,+                   Network.TableStorage.XML+