diff --git a/src/Network/TableStorage.hs b/src/Network/TableStorage.hs --- a/src/Network/TableStorage.hs +++ b/src/Network/TableStorage.hs @@ -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 diff --git a/src/Network/TableStorage/API.hs b/src/Network/TableStorage/API.hs --- a/src/Network/TableStorage/API.hs +++ b/src/Network/TableStorage/API.hs @@ -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 = "" } diff --git a/src/Network/TableStorage/Auth.hs b/src/Network/TableStorage/Auth.hs --- a/src/Network/TableStorage/Auth.hs +++ b/src/Network/TableStorage/Auth.hs @@ -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), diff --git a/src/Network/TableStorage/Development.hs b/src/Network/TableStorage/Development.hs --- a/src/Network/TableStorage/Development.hs +++ b/src/Network/TableStorage/Development.hs @@ -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=="} diff --git a/src/Network/TableStorage/Query.hs b/src/Network/TableStorage/Query.hs new file mode 100644 --- /dev/null +++ b/src/Network/TableStorage/Query.hs @@ -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 diff --git a/src/Network/TableStorage/Request.hs b/src/Network/TableStorage/Request.hs --- a/src/Network/TableStorage/Request.hs +++ b/src/Network/TableStorage/Request.hs @@ -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) diff --git a/src/Network/TableStorage/Response.hs b/src/Network/TableStorage/Response.hs --- a/src/Network/TableStorage/Response.hs +++ b/src/Network/TableStorage/Response.hs @@ -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. diff --git a/src/Network/TableStorage/Types.hs b/src/Network/TableStorage/Types.hs --- a/src/Network/TableStorage/Types.hs +++ b/src/Network/TableStorage/Types.hs @@ -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 diff --git a/tablestorage.cabal b/tablestorage.cabal --- a/tablestorage.cabal +++ b/tablestorage.cabal @@ -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 @@ -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