tablestorage 0.1.0.1 → 0.1.0.2

raw patch · 9 files changed

+155/−53 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• src/Network/TableStorage.hs +1/−0
• src/Network/TableStorage/API.hs +36/−10
• src/Network/TableStorage/Auth.hs +3/−3
• src/Network/TableStorage/Development.hs +7/−19
• src/Network/TableStorage/Query.hs +79/−0
• src/Network/TableStorage/Request.hs +2/−3
• src/Network/TableStorage/Response.hs +7/−1
• src/Network/TableStorage/Types.hs +6/−4
• tablestorage.cabal +14/−13

@@ -13,3 +13,4 @@ import Network.TableStorage.Types as TableStorage import Network.TableStorage.API as TableStorage import Network.TableStorage.Development as TableStorage+import Network.TableStorage.Query as TableStorage

@@ -2,9 +2,10 @@ -- This module provides functions wrapping the Azure REST API web methods.  module Network.TableStorage.API (-  queryTables, createTable, deleteTable,+  queryTables, createTable, createTableIfNecessary, deleteTable,   insertEntity, updateEntity, mergeEntity, deleteEntity, -  queryEntity, queryEntities, defaultEntityQuery+  queryEntity, queryEntities, defaultEntityQuery,+  defaultAccount ) where  import Network.HTTP@@ -38,7 +39,7 @@ -- queryTables :: Account -> IO (Either String [String]) queryTables acc = do-  let resource = printf "/%s/Tables" $ accountName acc+  let resource = "/Tables"   response <- authenticatedRequest acc GET [] resource resource ""   return $ response >>= parseQueryTablesResponse @@ -53,17 +54,32 @@ -- createTable :: Account -> String -> IO (Either String ()) createTable acc tableName = do -  let resource = printf "/%s/Tables" (accountName acc)+  let resource = "/Tables"   requestXml <- createTableXml tableName   response <- authenticatedRequest acc POST [] resource resource $ showTopElement requestXml   return $ response >>= parseEmptyResponse (2, 0, 1)  -- |+-- Creates a new table with the specified name if it does not already exist, or returns an erro message+-- +createTableIfNecessary :: Account -> String -> IO (Either String ())+createTableIfNecessary acc tableName = do +  tables <- queryTables acc+  case tables of+    Left err -> return $ Left err+    Right tables' -> +      if any (== tableName) tables'+      then+        return $ Right ()+      else +        createTable acc tableName++-- | -- Deletes the table with the specified name or returns an error message -- deleteTable :: Account -> String -> IO (Either String ()) deleteTable acc tableName = do -  let resource = printf "/%s/Tables('%s')" (accountName acc) tableName+  let resource = printf "/Tables('%s')" tableName   response <- authenticatedRequest acc DELETE [] resource resource ""   return $ response >>= parseEmptyResponse (2, 0, 4) @@ -84,7 +100,7 @@ -- insertEntity :: Account -> String -> Entity -> IO (Either String ()) insertEntity acc tableName entity = do -  let resource = printf "/%s/%s" (accountName acc) tableName+  let resource = printf "/%s" tableName   requestXml <- createInsertEntityXml entity   response <- authenticatedRequest acc POST [] resource resource $ showTopElement requestXml   return $ response >>= parseEmptyResponse (2, 0, 1)  @@ -95,7 +111,7 @@ -- updateOrMergeEntity :: RequestMethod -> Account -> String -> Entity -> IO (Either String ()) updateOrMergeEntity method acc tableName entity = do -  let resource = entityKeyResource acc tableName $ entityKey entity+  let resource = entityKeyResource tableName $ entityKey entity   let additionalHeaders = [ Header (HdrCustom "If-Match") "*" ]   requestXml <- createInsertEntityXml entity   response <- authenticatedRequest acc method additionalHeaders resource resource $ showTopElement requestXml@@ -118,7 +134,7 @@ -- deleteEntity :: Account -> String -> EntityKey -> IO (Either String ()) deleteEntity acc tableName key = do -  let resource = entityKeyResource acc tableName key+  let resource = entityKeyResource tableName key   let additionalHeaders = [ Header (HdrCustom "If-Match") "*" ]   response <- authenticatedRequest acc DELETE additionalHeaders resource resource ""   return $ response >>= parseEmptyResponse (2, 0, 4)@@ -157,7 +173,7 @@ -- queryEntity :: Account -> String -> EntityKey -> IO (Either String Entity) queryEntity acc tableName key = do -  let resource = entityKeyResource acc tableName key+  let resource = entityKeyResource tableName key   response <- authenticatedRequest acc GET [] resource resource ""   return $ response >>= parseQueryEntityResponse @@ -176,7 +192,7 @@ -- queryEntities :: Account -> String -> EntityQuery -> IO (Either String [Entity]) queryEntities acc tableName query = do -  let canonicalizedResource = printf "/%s/%s()" (accountName acc) tableName+  let canonicalizedResource = printf "/%s()" tableName   let queryString = buildQueryString query   let resource = printf "%s?%s" canonicalizedResource queryString   response <- authenticatedRequest acc GET [] resource canonicalizedResource ""@@ -188,3 +204,13 @@ defaultEntityQuery :: EntityQuery defaultEntityQuery = EntityQuery { eqPageSize = Nothing,                                    eqFilter = Nothing }+                                   +-- | +-- Constructs an Account with the default values for Port and Resource Prefix+defaultAccount :: AccountKey -> String -> String -> Account+defaultAccount key name hostname = Account { accountScheme              = "http",+                                             accountHost                = hostname,+                                             accountPort                = 80,+                                             accountKey                 = key,+                                             accountName                = name,+                                             accountResourcePrefix      = "" }

@@ -66,14 +66,14 @@ -- qualifyResource :: String -> Account -> URI qualifyResource res acc =-  URI { uriScheme = "http",+  URI { uriScheme = accountScheme acc,         uriAuthority =             Just URIAuth { uriRegName = accountHost acc,                           uriPort = ':' : show (accountPort acc),                          uriUserInfo = "" },         uriQuery = "",         uriFragment = "",-        uriPath = res }+        uriPath = (accountResourcePrefix acc) ++ res }  -- | -- Creates and executes an authenticated request including the Authorization header.@@ -90,7 +90,7 @@                              sharedKeyAuthContentMD5 = "",                              sharedKeyAuthContentType = "application/atom+xml",                              sharedKeyAuthDate = time,-                             sharedKeyAuthCanonicalizedResource = '/' : accountName acc ++ canonicalizedResource }+                             sharedKeyAuthCanonicalizedResource = printf "/%s%s%s" (accountName acc) (accountResourcePrefix acc) canonicalizedResource }   let basicHeaders = [ Header HdrAuthorization (authHeader acc auth),                        Header HdrContentType "application/atom+xml",                        Header HdrContentLength (show $ length body),

@@ -2,29 +2,17 @@ -- This module contains constants for working with the storage emulator.   -- -module Network.TableStorage.Development (-  developmentAccount-) where+module Network.TableStorage.Development 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 }+developmentAccount = Account { accountScheme            = "http",+                               accountHost              = "127.0.0.1" ,+                               accountName              = "devstoreaccount1",+                               accountPort              = 10002,+                               accountResourcePrefix    = "/devstoreaccount1",+                               accountKey               = "Eby8vdM02xNOcqFlqUwJPLlmEtlCDXJ1OUzFT50uSRZ6IFsuFq2UVErCz4I6tq/K1SZFPTOtr/KBHBeksoGMGw=="}

@@ -0,0 +1,79 @@+-- |
+-- This module contains functions which help when unmarshalling query responses
+
+module Network.TableStorage.Query where
+
+import Data.Time
+import Network.TableStorage.Types
+
+-- |
+-- Find the value in a binary-valued column or return Nothing if no such column exists
+edmBinary :: String -> Entity -> Maybe String
+edmBinary key en = do
+  col <- lookup key $ entityColumns en
+  case col of
+    EdmBinary s -> s
+    _ -> Nothing
+    
+-- |
+-- Find the value in a string-valued column or return Nothing if no such column exists
+edmString :: String -> Entity -> Maybe String
+edmString key en = do
+  col <- lookup key $ entityColumns en
+  case col of
+    EdmString s -> s
+    _ -> Nothing
+
+-- |
+-- Find the value in a boolean-valued column or return Nothing if no such column exists
+edmBoolean :: String -> Entity -> Maybe Bool
+edmBoolean key en = do
+  col <- lookup key $ entityColumns en
+  case col of
+    EdmBoolean s -> s
+    _ -> Nothing
+
+-- |
+-- Find the value in a date-valued column or return Nothing if no such column exists
+edmDateTime :: String -> Entity -> Maybe UTCTime
+edmDateTime key en = do
+  col <- lookup key $ entityColumns en
+  case col of
+    EdmDateTime s -> s
+    _ -> Nothing
+
+-- |
+-- Find the value in a double-valued column or return Nothing if no such column exists
+edmDouble :: String -> Entity -> Maybe Double
+edmDouble key en = do
+  col <- lookup key $ entityColumns en
+  case col of
+    EdmDouble s -> s
+    _ -> Nothing
+
+-- |
+-- Find the value in a Guid-valued column or return Nothing if no such column exists
+edmGuid :: String -> Entity -> Maybe String
+edmGuid key en = do
+  col <- lookup key $ entityColumns en
+  case col of
+    EdmGuid s -> s
+    _ -> Nothing
+
+-- |
+-- Find the value in an integer-valued column or return Nothing if no such column exists
+edmInt32 :: String -> Entity -> Maybe Int
+edmInt32 key en = do
+  col <- lookup key $ entityColumns en
+  case col of
+    EdmInt32 s -> s
+    _ -> Nothing
+
+-- |
+-- Find the value in an integer-valued column or return Nothing if no such column exists
+edmInt64 :: String -> Entity -> Maybe Int
+edmInt64 key en = do
+  col <- lookup key $ entityColumns en
+  case col of
+    EdmInt64 s -> s
+    _ -> Nothing

@@ -35,9 +35,8 @@ -- 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) +entityKeyResource :: String -> EntityKey -> String+entityKeyResource tableName key = printf "%s(PartitionKey='%s',RowKey='%s')"    tableName    (ekPartitionKey key)    (ekRowKey key)

@@ -24,6 +24,12 @@   return $ strContent message  -- |+-- Summarize an error appearing in a response body or return "Unknown error" if the response cannot be parsed+--+errorToString :: Response_String -> String+errorToString res = fromMaybe "Unknown error" (parseXMLDoc (rspBody res) >>= parseError)++-- | -- Verifies a response code, parsing an error message if necessary. -- parseEmptyResponse :: ResponseCode -> Response_String -> Either String ()@@ -32,7 +38,7 @@   then     Right ()   else-    Left $ fromMaybe "Unknown error" (parseXMLDoc (rspBody res) >>= parseError)+    Left $ errorToString res  -- | -- Parse an XML response, or an error response as appropriate.

@@ -25,10 +25,12 @@ -- | -- Account information: host, port, secret key and account name  ---data Account = Account { accountHost :: String,-                         accountPort :: Int,-                         accountKey  :: AccountKey,-                         accountName :: String } deriving Show               +data Account = Account { accountScheme         :: String,+                         accountHost           :: String,+                         accountPort           :: Int,+                         accountKey            :: AccountKey,+                         accountName           :: String,+                         accountResourcePrefix :: String } deriving Show                 -- | -- The unencrypted content of the Shared Key authorization header 

@@ -1,5 +1,5 @@ name:           tablestorage-version:        0.1.0.1+version:        0.1.0.2 cabal-version:  >= 1.2 build-type:     Simple author:         Phil Freeman <paf31-at-cantab.net>@@ -34,16 +34,17 @@                    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+  exposed-modules: 
+                   Network.TableStorage,
+                   Network.TableStorage.API,
+                   Network.TableStorage.Auth,
+                   Network.TableStorage.Development,
+                   Network.TableStorage.Query,
+                   Network.TableStorage.Types
+  other-modules:   
+                   Network.TableStorage.Atom,
+                   Network.TableStorage.Format,
+                   Network.TableStorage.Request,
+                   Network.TableStorage.Response,
+                   Network.TableStorage.XML