Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge in API changes.

  • Loading branch information...
commit 01cc95eaf7bb5d199770a4554d8712fc41eac57e 1 parent 315991d
@AaronFriel authored
View
114 src/Network/TableStorage/API.hs
@@ -3,10 +3,11 @@
-- This module provides functions wrapping the Azure REST API web methods.
module Network.TableStorage.API (
+ -- withTableStorage,
queryTables, createTable, createTableIfNecessary, deleteTable,
insertEntity, updateEntity, mergeEntity, deleteEntity,
queryEntity, queryEntities, defaultEntityQuery,
- defaultAccount
+ defaultAccount, defaultConf
) where
import Network.HTTP.Types
@@ -28,11 +29,24 @@ import Control.Monad ( (>=>), unless )
import Control.Monad.Error ( ErrorT(..) )
import Data.Time.Clock ( getCurrentTime )
import Data.Maybe ( fromMaybe )
+import Control.Monad.Reader
+import Control.Monad.Error
+
+withTableStorage :: TableConf -> TableStorage a -> IO (Either TableError a)
+withTableStorage conf f = runReaderT (runErrorT f) conf
+
+-- |
+-- Simple helper function to convert non-monadic parser results into the monadic result
+--
+fromEither :: MonadError e m => Either e a -> m a
+fromEither (Left e) = throwError e
+fromEither (Right a) = return a
+{-# INLINE fromEither #-}
-- |
-- Parse the response body of the Query Tables web method
--
-parseQueryTablesResponse :: QueryResponse -> Either String [String]
+parseQueryTablesResponse :: QueryResponse -> Either TableError [String]
parseQueryTablesResponse = parseXmlResponseOrError status200 readTables where
readTables :: Element -> Maybe [String]
readTables feed = sequence $ do
@@ -47,11 +61,11 @@ parseQueryTablesResponse = parseXmlResponseOrError status200 readTables where
-- |
-- List the names of tables for an account or returns an error message
--
-queryTables :: Account -> IO (Either String [String])
-queryTables acc = do
+queryTables :: TableStorage [String]
+queryTables = do
let resource = "/Tables"
- response <- authenticatedRequest acc methodGet [] resource resource ""
- return $ parseQueryTablesResponse response
+ response <- authenticatedRequest methodGet [] resource resource ""
+ fromEither $ parseQueryTablesResponse response
-- |
-- Construct the request body for the Create Table web method
@@ -62,29 +76,31 @@ createTableXml tableName = wrapContent Nothing $ propertyList [("TableName", Edm
-- |
-- Creates a new table with the specified name or returns an error message
--
-createTable :: Account -> String -> IO (Either String ())
-createTable acc tableName = do
+createTable :: String -> TableStorage ()
+createTable tableName = do
let resource = "/Tables"
- requestXml <- createTableXml tableName
- response <- authenticatedRequest acc methodPost [] resource resource $ showTopElement requestXml
- return $ parseEmptyResponse status201 response
+ requestXml <- liftIO $ createTableXml tableName
+ response <- authenticatedRequest methodPost [] resource resource $ showTopElement requestXml
+ fromEither $ parseEmptyResponse status201 response
-- |
-- Creates a new table with the specified name if it does not already exist, or returns an erro message
--
-createTableIfNecessary :: Account -> String -> IO (Either String ())
-createTableIfNecessary acc tableName = runErrorT $ do
- tables <- ErrorT $ queryTables acc
- unless (tableName `elem` tables) $ ErrorT $ createTable acc tableName
+createTableIfNecessary :: String -> TableStorage ()
+createTableIfNecessary tableName = do
+ tables <- queryTables
+ if (tableName `elem` tables)
+ then return ()
+ else createTable tableName
-- |
-- Deletes the table with the specified name or returns an error message
--
-deleteTable :: Account -> String -> IO (Either String ())
-deleteTable acc tableName = do
+deleteTable :: String -> TableStorage ()
+deleteTable tableName = do
let resource = "/Tables('" ++ tableName ++ "')"
- response <- authenticatedRequest acc methodDelete [] resource resource ""
- return $ parseEmptyResponse status204 response
+ response <- authenticatedRequest methodDelete [] resource resource ""
+ fromEither $ parseEmptyResponse status204 response
-- |
-- Construct the request body for the Insert Entity web method
@@ -101,47 +117,48 @@ createInsertEntityXml entity entityID = do
-- |
-- 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
+insertEntity :: String -> Entity -> TableStorage ()
+insertEntity tableName entity = do
let resource = '/' : tableName
- requestXml <- createInsertEntityXml entity Nothing
- response <- authenticatedRequest acc methodPost [] resource resource $ showTopElement requestXml
- return $ parseEmptyResponse status201 response
+ requestXml <- liftIO $ createInsertEntityXml entity Nothing
+ response <- authenticatedRequest methodPost [] resource resource $ showTopElement requestXml
+ fromEither $ parseEmptyResponse status201 response
-- |
-- Shared method to update or merge an existing entity. The only difference between the
-- two methods is the request method used.
--
-updateOrMergeEntity :: Method -> Account -> String -> Entity -> IO (Either String ())
-updateOrMergeEntity method acc tableName entity = do
+updateOrMergeEntity :: Method -> String -> Entity -> TableStorage ()
+updateOrMergeEntity method tableName entity = do
let resource = entityKeyResource tableName $ entityKey entity
let additionalHeaders = [ ("If-Match", "*") ]
- requestXml <- createInsertEntityXml entity (Just $
+ (TableConf _ acc) <- ask
+ requestXml <- liftIO $ createInsertEntityXml entity (Just $
accountScheme acc ++ "://" ++ accountHost acc ++ resource)
- response <- authenticatedRequest acc method additionalHeaders resource resource $ showTopElement requestXml
- return $ parseEmptyResponse status204 response
+ response <- authenticatedRequest method additionalHeaders resource resource $ showTopElement requestXml
+ fromEither $ parseEmptyResponse status204 response
-- |
-- Updates the specified entity (possibly removing columns) or returns an error message
--
-updateEntity :: Account -> String -> Entity -> IO (Either String ())
+updateEntity :: String -> Entity -> TableStorage ()
updateEntity = updateOrMergeEntity methodPut
-- |
-- Merges the specified entity (without removing columns) or returns an error message
--
-mergeEntity :: Account -> String -> Entity -> IO (Either String ())
+mergeEntity :: String -> Entity -> TableStorage ()
mergeEntity = updateOrMergeEntity ("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
+deleteEntity :: String -> EntityKey -> TableStorage ()
+deleteEntity tableName key = do
let resource = entityKeyResource tableName key
let additionalHeaders = [ ("If-Match", "*") ]
- response <- authenticatedRequest acc methodDelete additionalHeaders resource resource ""
- return $ parseEmptyResponse status204 response
+ response <- authenticatedRequest methodDelete additionalHeaders resource resource ""
+ fromEither $ parseEmptyResponse status204 response
-- |
-- Parse an Atom entry as an entity
@@ -171,22 +188,22 @@ readEntity entry = do
-- |
-- Parse the response body of the Query Entity web method
--
-parseQueryEntityResponse :: QueryResponse -> Either String Entity
-parseQueryEntityResponse = parseXmlResponseOrError status200 readEntity where
+parseQueryEntityResponse :: QueryResponse -> Either TableError Entity
+parseQueryEntityResponse = parseXmlResponseOrError status200 readEntity
-- |
-- 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
+queryEntity :: String -> EntityKey -> TableStorage Entity
+queryEntity tableName key = do
let resource = entityKeyResource tableName key
- response <- authenticatedRequest acc methodGet [] resource resource ""
- return $ parseQueryEntityResponse response
+ response <- authenticatedRequest methodGet [] resource resource ""
+ fromEither $ parseQueryEntityResponse response
-- |
-- Parse the response body of the Query Entities web method
--
-parseQueryEntitiesResponse :: QueryResponse -> Either String [Entity]
+parseQueryEntitiesResponse :: QueryResponse -> Either TableError [Entity]
parseQueryEntitiesResponse = parseXmlResponseOrError status200 readEntities where
readEntities :: Element -> Maybe [Entity]
readEntities feed = sequence $ do
@@ -196,13 +213,13 @@ parseQueryEntitiesResponse = parseXmlResponseOrError status200 readEntities wher
-- |
-- 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
+queryEntities :: String -> EntityQuery -> TableStorage [Entity]
+queryEntities tableName query = do
let canonicalizedResource = '/' : tableName ++ "()"
let queryString = buildQueryString query
let resource = canonicalizedResource ++ '?' : queryString
- response <- authenticatedRequest acc methodGet [] resource canonicalizedResource ""
- return $ parseQueryEntitiesResponse response
+ response <- authenticatedRequest methodGet [] resource canonicalizedResource ""
+ fromEither $ parseQueryEntitiesResponse response
-- |
-- An empty query with no filters and no specified page size
@@ -219,4 +236,7 @@ defaultAccount key name hostname = Account { accountScheme = "http:
accountPort = 80,
accountKey = key,
accountName = name,
- accountResourcePrefix = "" }
+ accountResourcePrefix = "" }
+
+defaultConf :: AccountKey -> String -> String -> TableConf
+defaultConf key name hostname = TableConf Nothing $ defaultAccount key name hostname
View
15 src/Network/TableStorage/Auth.hs
@@ -14,12 +14,12 @@ module Network.TableStorage.Auth (
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 as B ( ByteString, concat )
import qualified Data.ByteString.UTF8 as UTF8
( toString, fromString )
import qualified Data.ByteString.Lazy.UTF8 as UTF8L ( fromString, toString )
import qualified Data.ByteString.Lazy.Char8 as Char8L ( toChunks )
-import qualified Data.ByteString.Lazy as L ( ByteString(..), fromChunks )
+import qualified Data.ByteString.Lazy as L ( ByteString, fromChunks )
import qualified Crypto.Classes as Crypto ( encode )
import Crypto.Hash.MD5 as MD5 (hash)
import qualified Data.Digest.Pure.SHA as SHA
@@ -34,6 +34,9 @@ import Network.TableStorage.Types
import Network.TableStorage.Format ( rfc1123Date )
import Data.Monoid ((<>))
import Debug.Trace
+import Control.Monad.Reader
+import Control.Monad.Error
+import Control.Monad.IO.Class
authenticationType :: String
authenticationType = "SharedKey"
@@ -97,10 +100,18 @@ qualifyResource res acc =
-- resource, canonicalized resource and request body as parameters, and returns
-- an error message or the response object.
--
+<<<<<<< HEAD
authenticatedRequest :: Account -> Method -> [Header] -> String -> String -> String -> IO QueryResponse
authenticatedRequest acc method hdrs resource canonicalizedResource body = withSocketsDo $ do
time <- rfc1123Date
let contentMD5 = (Base64C.encode . hash . UTF8.fromString) body
+=======
+authenticatedRequest :: Method -> [Header] -> String -> String -> String -> TableStorage QueryResponse
+authenticatedRequest method hdrs resource canonicalizedResource body = do
+ time <- liftIO $ rfc1123Date
+ (TableConf mgr acc) <- ask
+ let contentMD5 = (Base64C.encode . Crypto.encode . md5 . UTF8L.fromString) body
+>>>>>>> API with ReaderT and ErrorT
let atomType = "application/atom+xml" :: B.ByteString
let auth = SharedKeyAuth { sharedKeyAuthVerb = method
, sharedKeyAuthContentMD5 = UTF8.toString contentMD5
View
9 src/Network/TableStorage/Development.hs
@@ -3,11 +3,11 @@
--
module Network.TableStorage.Development (
- developmentAccount
+ developmentAccount, developmentConf
) where
import Network.TableStorage.Types
- ( Account(..), AccountKey(AccountKey) )
+ ( Account(..), AccountKey(AccountKey), TableConf(..) )
-- |
-- An account for the storage emulator
@@ -18,4 +18,7 @@ developmentAccount = Account { accountScheme = "http:",
accountName = "devstoreaccount1",
accountPort = 10002,
accountResourcePrefix = "/devstoreaccount1",
- accountKey = AccountKey "Eby8vdM02xNOcqFlqUwJPLlmEtlCDXJ1OUzFT50uSRZ6IFsuFq2UVErCz4I6tq/K1SZFPTOtr/KBHBeksoGMGw=="}
+ accountKey = AccountKey "Eby8vdM02xNOcqFlqUwJPLlmEtlCDXJ1OUzFT50uSRZ6IFsuFq2UVErCz4I6tq/K1SZFPTOtr/KBHBeksoGMGw=="}
+
+developmentConf :: TableConf
+developmentConf = TableConf Nothing developmentAccount
View
20 src/Network/TableStorage/Response.hs
@@ -18,38 +18,44 @@ import Network.TableStorage.Atom
import Network.TableStorage.Types
import Network.TableStorage.Format
import Network.HTTP.Types
+import Control.Monad.Error
-- |
-- Extracts the error message from an error response
--
-parseError :: Element -> Maybe String
-parseError root = do
+parseErrorMaybe :: Element -> Maybe String
+parseErrorMaybe root = do
guard $ qualifyMetadata "error" == elName root
message <- findChild (qualifyMetadata "message") root
return $ strContent message
+parseError :: Maybe Element -> TableError
+parseError e = case e >>= parseErrorMaybe of
+ Nothing -> TableUnknownError
+ Just s -> TableOtherError s
+
-- |
-- Verifies a response status, parsing an error message if necessary.
--
-parseEmptyResponse :: Status -> QueryResponse -> Either String ()
+parseEmptyResponse :: Status -> QueryResponse -> Either TableError ()
parseEmptyResponse status (QueryResponse rspStatus rspBody) =
if rspStatus == status
then
Right ()
else
- Left $ fromMaybe "Unknown error" (parseXMLDoc (rspBody) >>= parseError)
+ Left $ parseError $ parseXMLDoc (rspBody)
-- |
-- Parse an XML response, or an error response as appropriate.
--
-parseXmlResponseOrError :: Status -> (Element -> Maybe a) -> QueryResponse -> Either String a
+parseXmlResponseOrError :: Status -> (Element -> Maybe a) -> QueryResponse -> Either TableError a
parseXmlResponseOrError status parse (QueryResponse rspStatus rspBody) =
let xmlDoc = parseXMLDoc rspBody in
if rspStatus == status
then
- maybe (Left "Unable to parse result") Right $ xmlDoc >>= parse
+ maybe (Left TableUnknownError) Right $ xmlDoc >>= parse
else
- Left $ fromMaybe "Unknown error" (xmlDoc >>= parseError)
+ Left $ parseError xmlDoc
-- |
-- Parses an entity column type and value
View
31 src/Network/TableStorage/Types.hs
@@ -13,11 +13,40 @@ module Network.TableStorage.Types (
EntityQuery(..),
ComparisonType(..),
EntityFilter(..),
- QueryResponse(..)
+ QueryResponse(..),
+ TableStorage,
+ TableConf(..),
+ TableError(..)
) where
import Data.Time ( UTCTime )
import Network.HTTP.Types
+import Network.HTTP.Conduit
+import Control.Monad.Reader
+import Control.Monad.Error
+
+type TableStorage = ErrorT TableError (ReaderT TableConf IO)
+
+data TableConf = TableConf
+ { manager :: Maybe Manager
+ , account :: Account
+ }
+
+-- |
+-- Error type
+--
+data TableError = TableParseError
+ | TableUnknownError
+ | TableOtherError String
+
+instance Error TableError where
+ noMsg = TableUnknownError
+ strMsg s = TableOtherError s
+
+instance Show TableError where
+ show TableParseError = "Unable to parse result"
+ show TableUnknownError = "Unknown table storage error"
+ show (TableOtherError msg) = msg
-- |
-- The Base-64 encoded account secret key
View
1  tablestorage.cabal
@@ -36,6 +36,7 @@ library
xml,
old-locale,
mtl,
+ transformers,
crypto-api,
cryptohash,
HTTP

0 comments on commit 01cc95e

Please sign in to comment.
Something went wrong with that request. Please try again.