packages feed

tablestorage (empty) → 0.1

raw patch · 13 files changed

+827/−0 lines, 13 filesdep +HTTPdep +SHAdep +basesetup-changed

Dependencies added: HTTP, SHA, base, base64-bytestring, bytestring, haskell98, network, time, utf8-string, xml

Files

+ LICENSE view
@@ -0,0 +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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain
+ src/Network/TableStorage.hs view
@@ -0,0 +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
+ src/Network/TableStorage/API.hs view
@@ -0,0 +1,191 @@+-- |
+-- 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,
+                                   eqFilter = Nothing }
+ src/Network/TableStorage/Atom.hs view
@@ -0,0 +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 
+      ]
+   ]
+ src/Network/TableStorage/Auth.hs view
@@ -0,0 +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
+  return $ either (Left . show) Right result
+ src/Network/TableStorage/Development.hs view
@@ -0,0 +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,
+                               accountPort = developmentPort }
+ src/Network/TableStorage/Format.hs view
@@ -0,0 +1,24 @@+-- |
+-- 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
+atomDateFormat = "%Y-%m-%dT%H:%M:%S%QZ"
+ src/Network/TableStorage/Request.hs view
@@ -0,0 +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)
+  (maybe "" show $ eqPageSize query)
+ src/Network/TableStorage/Response.hs view
@@ -0,0 +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
+parseEntityColumn _     _              _        = Nothing
+ src/Network/TableStorage/Types.hs view
@@ -0,0 +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
+  deriving Show
+ src/Network/TableStorage/XML.hs view
@@ -0,0 +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,
+         attrVal = uri }
+ tablestorage.cabal view
@@ -0,0 +1,53 @@+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
+  build-depends:   
+                   base >= 4 && < 5,
+                   SHA,
+                   bytestring,
+                   utf8-string,
+                   base64-bytestring,
+                   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
+