Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Now that this is ported to tablestorage, no need to include

  • Loading branch information...
commit 53763e8af367eb674b6514f0f64d34fa6b86ac3a 1 parent 2c9c59c
Aaron Friel authored December 14, 2012
238  Network/AzureTables/API.hs
... ...
@@ -1,238 +0,0 @@
1  
--- |
2  
--- This module provides functions wrapping the Azure REST API web methods.
3  
-
4  
-module Network.AzureTables.API (
5  
-  queryTables, createTable, createTableIfNecessary, deleteTable,
6  
-  insertEntity, updateEntity, mergeEntity, deleteEntity,
7  
-  queryEntity, queryEntities, defaultEntityQuery,
8  
-  defaultAccount
9  
-) where
10  
-
11  
-import Network.HTTP
12  
-    ( HeaderName(HdrCustom),
13  
-      Header(Header),
14  
-      RequestMethod(Custom, DELETE, GET, POST, PUT),
15  
-      Response_String )
16  
-import Text.XML.Light
17  
-    ( Element(elName),
18  
-      QName(qName, qURI),
19  
-      showTopElement,
20  
-      filterChildren,
21  
-      findAttr,
22  
-      findChild,
23  
-      findChildren,
24  
-      strContent )
25  
-import Network.AzureTables.Types
26  
-    ( EntityQuery(..),
27  
-      Entity(..),
28  
-      EntityColumn(EdmDateTime, EdmString),
29  
-      EntityKey(..),
30  
-      Account(..),
31  
-      AccountKey )
32  
-import Network.AzureTables.Auth ( authenticatedRequest )
33  
-import Network.AzureTables.Request
34  
-    ( propertyList, entityKeyResource, buildQueryString )
35  
-import Network.AzureTables.Response
36  
-    ( parseEmptyResponse, parseXmlResponseOrError, parseEntityColumn )
37  
-import Network.AzureTables.Atom
38  
-    ( dataServicesNamespace,
39  
-      qualifyAtom,
40  
-      qualifyDataServices,
41  
-      qualifyMetadata,
42  
-      wrapContent )
43  
-import Control.Monad ( (>=>), unless )
44  
-import Control.Monad.Error ( ErrorT(..) )
45  
-import Data.Time.Clock ( getCurrentTime )
46  
-import Data.Maybe ( fromMaybe )
47  
-
48  
--- |
49  
--- Parse the response body of the Query Tables web method
50  
---
51  
-parseQueryTablesResponse :: Response_String -> Either String [String]
52  
-parseQueryTablesResponse = parseXmlResponseOrError (2, 0, 0) readTables where
53  
-  readTables :: Element -> Maybe [String]
54  
-  readTables feed = sequence $ do
55  
-    entry <- findChildren (qualifyAtom "entry") feed
56  
-    return $ readTableName entry
57  
-  readTableName =
58  
-    findChild (qualifyAtom "content")
59  
-    >=> findChild (qualifyMetadata "properties")
60  
-    >=> findChild (qualifyDataServices "TableName")
61  
-    >=> return . strContent
62  
-
63  
--- |
64  
--- List the names of tables for an account or returns an error message
65  
---
66  
-queryTables :: Account -> IO (Either String [String])
67  
-queryTables acc = do
68  
-  let resource = "/Tables"
69  
-  response <- authenticatedRequest acc GET [] resource resource ""
70  
-  return $ response >>= parseQueryTablesResponse
71  
-
72  
--- |
73  
--- Construct the request body for the Create Table web method
74  
---
75  
-createTableXml :: String -> IO Element
76  
-createTableXml tableName = wrapContent Nothing $ propertyList [("TableName", EdmString $ Just tableName)]
77  
-
78  
--- |
79  
--- Creates a new table with the specified name or returns an error message
80  
---
81  
-createTable :: Account -> String -> IO (Either String ())
82  
-createTable acc tableName = do
83  
-  let resource = "/Tables"
84  
-  requestXml <- createTableXml tableName
85  
-  response <- authenticatedRequest acc POST [] resource resource $ showTopElement requestXml
86  
-  return $ response >>= parseEmptyResponse (2, 0, 1)
87  
-
88  
--- |
89  
--- Creates a new table with the specified name if it does not already exist, or returns an erro message
90  
---
91  
-createTableIfNecessary :: Account -> String -> IO (Either String ())
92  
-createTableIfNecessary acc tableName = runErrorT $ do
93  
-  tables <- ErrorT $ queryTables acc
94  
-  unless (tableName `elem` tables) $ ErrorT $ createTable acc tableName
95  
-
96  
--- |
97  
--- Deletes the table with the specified name or returns an error message
98  
---
99  
-deleteTable :: Account -> String -> IO (Either String ())
100  
-deleteTable acc tableName = do
101  
-  let resource = "/Tables('" ++ tableName ++ "')"
102  
-  response <- authenticatedRequest acc DELETE [] resource resource ""
103  
-  return $ response >>= parseEmptyResponse (2, 0, 4)
104  
-
105  
--- |
106  
--- Construct the request body for the Insert Entity web method
107  
---
108  
-createInsertEntityXml :: Entity -> Maybe String -> IO Element
109  
-createInsertEntityXml entity entityID = do
110  
-  time <- getCurrentTime
111  
-  wrapContent entityID $ propertyList $ [
112  
-      ("PartitionKey", EdmString $ Just $ ekPartitionKey $ entityKey entity),
113  
-      ("RowKey",       EdmString $ Just $ ekRowKey $ entityKey entity),
114  
-      ("Timestamp",    EdmDateTime $ Just time)
115  
-    ] ++ entityColumns entity
116  
-
117  
--- |
118  
--- Inserts an entity into the table with the specified name or returns an error message
119  
---
120  
-insertEntity :: Account -> String -> Entity -> IO (Either String ())
121  
-insertEntity acc tableName entity = do
122  
-  let resource = '/' : tableName
123  
-  requestXml <- createInsertEntityXml entity Nothing
124  
-  response <- authenticatedRequest acc POST [] resource resource $ showTopElement requestXml
125  
-  return $ response >>= parseEmptyResponse (2, 0, 1)
126  
-
127  
--- |
128  
--- Shared method to update or merge an existing entity. The only difference between the
129  
--- two methods is the request method used.
130  
---
131  
-updateOrMergeEntity :: RequestMethod -> Account -> String -> Entity -> IO (Either String ())
132  
-updateOrMergeEntity method acc tableName entity = do
133  
-  let resource = entityKeyResource tableName $ entityKey entity
134  
-  let additionalHeaders = [ Header (HdrCustom "If-Match") "*" ]
135  
-  requestXml <- createInsertEntityXml entity (Just $
136  
-    accountScheme acc ++ "://" ++ accountHost acc ++ resource)
137  
-  response <- authenticatedRequest acc method additionalHeaders resource resource $ showTopElement requestXml
138  
-  return $ response >>= parseEmptyResponse (2, 0, 4)
139  
-
140  
--- |
141  
--- Updates the specified entity (possibly removing columns) or returns an error message
142  
---
143  
-updateEntity :: Account -> String -> Entity -> IO (Either String ())
144  
-updateEntity = updateOrMergeEntity PUT
145  
-
146  
--- |
147  
--- Merges the specified entity (without removing columns) or returns an error message
148  
---
149  
-mergeEntity :: Account -> String -> Entity -> IO (Either String ())
150  
-mergeEntity = updateOrMergeEntity (Custom "MERGE")
151  
-
152  
--- |
153  
--- Deletes the entity with the specified key or returns an error message
154  
---
155  
-deleteEntity :: Account -> String -> EntityKey -> IO (Either String ())
156  
-deleteEntity acc tableName key = do
157  
-  let resource = entityKeyResource tableName key
158  
-  let additionalHeaders = [ Header (HdrCustom "If-Match") "*" ]
159  
-  response <- authenticatedRequest acc DELETE additionalHeaders resource resource ""
160  
-  return $ response >>= parseEmptyResponse (2, 0, 4)
161  
-
162  
--- |
163  
--- Parse an Atom entry as an entity
164  
---
165  
-readEntity :: Element -> Maybe Entity
166  
-readEntity entry = do
167  
-    properties <-
168  
-      findChild (qualifyAtom "content")
169  
-      >=> findChild (qualifyMetadata "properties")
170  
-      $ entry
171  
-    partitionKey <- findChild (qualifyDataServices "PartitionKey") properties
172  
-    rowKey <- findChild (qualifyDataServices "RowKey") properties
173  
-    let columnData = filterChildren filterProperties properties
174  
-    columns <- mapM elementToColumn columnData
175  
-    return Entity { entityKey = EntityKey { ekPartitionKey = strContent partitionKey,
176  
-                                            ekRowKey = strContent rowKey },
177  
-                    entityColumns = columns } where
178  
-  filterProperties el | elName el == qualifyDataServices "PartitionKey" = False
179  
-                      | elName el == qualifyDataServices "RowKey" = False
180  
-                      | otherwise = qURI (elName el) == Just dataServicesNamespace
181  
-  elementToColumn el =
182  
-    let propertyName = qName $ elName el in
183  
-    let typeAttr = fromMaybe "Edm.String" $ findAttr (qualifyMetadata "type") el in
184  
-    let typeNull = maybe False ("true" ==) $ findAttr (qualifyMetadata "null") el in
185  
-    (\val -> (propertyName, val)) `fmap` parseEntityColumn typeNull typeAttr (strContent el)
186  
-
187  
--- |
188  
--- Parse the response body of the Query Entity web method
189  
---
190  
-parseQueryEntityResponse :: Response_String -> Either String Entity
191  
-parseQueryEntityResponse = parseXmlResponseOrError (2, 0, 0) readEntity where
192  
-
193  
--- |
194  
--- Returns the entity with the specified table name and key or an error message
195  
---
196  
-queryEntity :: Account -> String -> EntityKey -> IO (Either String Entity)
197  
-queryEntity acc tableName key = do
198  
-  let resource = entityKeyResource tableName key
199  
-  response <- authenticatedRequest acc GET [] resource resource ""
200  
-  return $ response >>= parseQueryEntityResponse
201  
-
202  
--- |
203  
--- Parse the response body of the Query Entities web method
204  
---
205  
-parseQueryEntitiesResponse :: Response_String -> Either String [Entity]
206  
-parseQueryEntitiesResponse = parseXmlResponseOrError (2, 0, 0) readEntities where
207  
-  readEntities :: Element -> Maybe [Entity]
208  
-  readEntities feed = sequence $ do
209  
-    entry <- findChildren (qualifyAtom "entry") feed
210  
-    return $ readEntity entry
211  
-
212  
--- |
213  
--- Returns a collection of entities by executing the specified query or returns an error message
214  
---
215  
-queryEntities :: Account -> String -> EntityQuery -> IO (Either String [Entity])
216  
-queryEntities acc tableName query = do
217  
-  let canonicalizedResource = '/' : tableName ++ "()"
218  
-  let queryString = buildQueryString query
219  
-  let resource = canonicalizedResource ++ '?' : queryString
220  
-  response <- authenticatedRequest acc GET [] resource canonicalizedResource ""
221  
-  return $ response >>= parseQueryEntitiesResponse
222  
-
223  
--- |
224  
--- An empty query with no filters and no specified page size
225  
---
226  
-defaultEntityQuery :: EntityQuery
227  
-defaultEntityQuery = EntityQuery { eqPageSize = Nothing,
228  
-                                   eqFilter = Nothing }
229  
-
230  
--- |
231  
--- Constructs an Account with the default values for Port and Resource Prefix
232  
-defaultAccount :: AccountKey -> String -> String -> Account
233  
-defaultAccount key name hostname = Account { accountScheme              = "http",
234  
-                                             accountHost                = hostname,
235  
-                                             accountPort                = 80,
236  
-                                             accountKey                 = key,
237  
-                                             accountName                = name,
238  
-                                             accountResourcePrefix      = "" }
87  Network/AzureTables/Atom.hs
... ...
@@ -1,87 +0,0 @@
1  
--- |
2  
--- Functions for constructing and parsing Atom feeds for use in the
3  
--- request and response bodies of the various web methods.
4  
---
5  
-
6  
-module Network.AzureTables.Atom (
7  
-  atomNamespace, dataServicesNamespace, metadataNamespace,
8  
-  qualifyAtom, qualifyDataServices, qualifyMetadata,
9  
-  atomElement, atomAttr, wrapContent
10  
-) where
11  
-
12  
-import Network.AzureTables.XML
13  
-    ( qualify, cDataText, namespaceAttr )
14  
-import Network.AzureTables.Format ( atomDate )
15  
-import Text.XML.Light
16  
-    ( Element(elAttribs, elContent, elName),
17  
-      Content(Elem),
18  
-      QName, CDataKind(..), Content(..), CData(..),
19  
-      Attr(..),
20  
-      blank_element,
21  
-      unqual )
22  
-import Data.Maybe (fromMaybe)
23  
-
24  
-atomNamespace :: String
25  
-atomNamespace = "http://www.w3.org/2005/Atom"
26  
-
27  
-dataServicesNamespace :: String
28  
-dataServicesNamespace = "http://schemas.microsoft.com/ado/2007/08/dataservices"
29  
-
30  
-metadataNamespace :: String
31  
-metadataNamespace = "http://schemas.microsoft.com/ado/2007/08/dataservices/metadata"
32  
-
33  
-qualifyAtom :: String -> QName
34  
-qualifyAtom = qualify (Just atomNamespace) Nothing
35  
-
36  
-qualifyDataServices :: String -> QName
37  
-qualifyDataServices = qualify (Just dataServicesNamespace) (Just "d")
38  
-
39  
-qualifyMetadata :: String -> QName
40  
-qualifyMetadata = qualify (Just metadataNamespace) (Just "m")
41  
-
42  
--- |
43  
--- An element in the Atom namespace with the provided attributes and child elements
44  
---
45  
-atomElement :: String -> Maybe String -> [Attr] -> [Element] -> Element
46  
-atomElement name content attrs els  =
47  
-  blank_element { elName = qualifyAtom name,
48  
-                  elAttribs = attrs,
49  
-                  elContent = map Elem els ++ maybe [] cDataText content }
50  
-
51  
--- |
52  
--- An attribute in the Atom namespace
53  
---
54  
-atomAttr :: String -> String -> Attr
55  
-atomAttr name value =
56  
-  Attr { attrKey = qualifyAtom name,
57  
-         attrVal = value }
58  
-
59  
--- |
60  
--- Create an Atom entry using the specified element as the content element
61  
---
62  
-wrapContent :: Maybe String -> Element -> IO Element
63  
-wrapContent entityID content = do
64  
-  date <- atomDate
65  
-  return $
66  
-    atomElement "entry" Nothing
67  
-      [ Attr { attrKey = unqual "xmlns", attrVal = atomNamespace }
68  
-      , namespaceAttr "d" dataServicesNamespace
69  
-      , namespaceAttr "m" metadataNamespace
70  
-      ]
71  
-      [ atomElement "category" Nothing
72  
-          [ atomAttr "scheme" "http://schemas.microsoft.com/ado/2007/08/dataservices/scheme"
73  
-          , atomAttr "term" "clio.cookies"
74  
-          ] []
75  
-      , atomElement "title" Nothing [] []
76  
-      , atomElement "author" Nothing []
77  
-          [ atomElement "name" Nothing [] [] ]
78  
-      , atomElement "updated" (Just date) [] []
79  
-      , blank_element
80  
-        { elName = qualifyAtom "id"
81  
-        , elAttribs = []
82  
-        , elContent = [Text CData { cdVerbatim = CDataRaw, cdData = fromMaybe "" entityID, cdLine = Nothing }]
83  
-        }
84  
-      , atomElement "content" Nothing
85  
-          [ atomAttr "type" "application/xml" ]
86  
-          [ content ]
87  
-      ]
140  Network/AzureTables/Auth.hs
... ...
@@ -1,140 +0,0 @@
1  
--- |
2  
--- This module provides functions to create authenticated requests to the Table
3  
--- Storage REST API.
4  
---
5  
--- Functions are provided to create Shared Key authorization tokens, and to add the
6  
--- required headers for the various requests.
7  
---
8  
-
9  
-module Network.AzureTables.Auth (
10  
-  authenticatedRequest
11  
-) where
12  
-
13  
-import qualified Data.ByteString.Base64 as Base64C
14  
-    ( encode, decode )
15  
-import qualified Codec.Binary.UTF8.String as UTF8C ( encodeString )
16  
-import qualified Data.ByteString as B ( ByteString, concat )
17  
-import qualified Data.ByteString.UTF8 as UTF8
18  
-    ( toString, fromString )
19  
-import qualified Data.ByteString.Lazy.UTF8 as UTF8L ( fromString )
20  
-import qualified Data.ByteString.Lazy.Char8 as Char8L ( toChunks )
21  
-import qualified Data.ByteString.Lazy as L ( fromChunks )
22  
-import qualified Crypto.Classes as Crypto ( encode )
23  
-import Data.Digest.Pure.MD5 as MD5 (md5)
24  
-import qualified Data.Digest.Pure.SHA as SHA
25  
-    ( bytestringDigest, hmacSha256 )
26  
-import Network.TCP ( HStream(close, openStream) )
27  
-import Network.URI
28  
-    ( URIAuth(URIAuth, uriPort, uriRegName, uriUserInfo), URI(..) )
29  
-import Network.HTTP
30  
-    ( HeaderName(HdrAccept, HdrAuthorization, HdrContentLength,
31  
-                 HdrContentType, HdrDate, HdrCustom, HdrUserAgent, HdrContentMD5),
32  
-      Header(..),
33  
-      Request(Request, rqBody, rqHeaders, rqMethod, rqURI),
34  
-      RequestMethod,
35  
-      Response_String,
36  
-      sendHTTP )
37  
-import Network.HTTP.Base ()
38  
-import Network.Stream ( Result )
39  
-import Network.AzureTables.Types
40  
-    ( SharedKeyAuth(..),
41  
-      Account(accountHost, accountKey, accountName, accountPort,
42  
-              accountResourcePrefix, accountScheme),
43  
-      AuthHeader(..),
44  
-      Signature(..),
45  
-      AccountKey(unAccountKey) )
46  
-import Network.AzureTables.Format ( rfc1123Date )
47  
-import Debug.Trace
48  
-
49  
-authenticationType :: String
50  
-authenticationType = "SharedKey"
51  
-
52  
--- |
53  
--- Constructs the unencrypted content of the Shared Key authentication token
54  
---
55  
-printSharedKeyAuth :: SharedKeyAuth -> String
56  
-printSharedKeyAuth auth = (id >>= trace) $
57  
-  show (sharedKeyAuthVerb auth)
58  
-  ++ "\n"
59  
-  ++ sharedKeyAuthContentMD5 auth
60  
-  ++ "\n"
61  
-  ++ sharedKeyAuthContentType auth
62  
-  ++ "\n"
63  
-  ++ sharedKeyAuthDate auth
64  
-  ++ "\n"
65  
-  ++ sharedKeyAuthCanonicalizedResource auth
66  
-
67  
-hmacSha256' :: AccountKey -> String -> B.ByteString
68  
-hmacSha256' base64Key =
69  
-  let (Right key) = Base64C.decode . UTF8.fromString . unAccountKey $ base64Key in
70  
-  B.concat . Char8L.toChunks . SHA.bytestringDigest . SHA.hmacSha256 (L.fromChunks $ return key) . UTF8L.fromString
71  
-
72  
--- |
73  
--- Constructs the authorization signature
74  
---
75  
-signature :: AccountKey -> SharedKeyAuth -> Signature
76  
-signature key = Signature . UTF8.toString . Base64C.encode . hmacSha256' key . UTF8C.encodeString . printSharedKeyAuth
77  
-
78  
--- |
79  
--- Constructs the authorization header including account name and signature
80  
---
81  
-authHeader :: Account -> SharedKeyAuth -> AuthHeader
82  
-authHeader acc auth = AuthHeader $
83  
-  authenticationType
84  
-  ++ " "
85  
-  ++ accountName acc
86  
-  ++ ":"
87  
-  ++ unSignature (signature (accountKey acc) auth)
88  
-
89  
--- |
90  
--- Constructs an absolute URI from an Account and relative URI
91  
---
92  
-qualifyResource :: String -> Account -> URI
93  
-qualifyResource res acc =
94  
-  URI { uriScheme = accountScheme acc
95  
-      , uriAuthority =
96  
-          Just URIAuth
97  
-          { uriRegName = accountHost acc
98  
-          , uriPort = ':' : show (accountPort acc)
99  
-          , uriUserInfo = "" }
100  
-      , uriQuery = ""
101  
-      , uriFragment = ""
102  
-      , uriPath = accountResourcePrefix acc ++ res }
103  
-
104  
--- |
105  
--- Creates and executes an authenticated request including the Authorization header.
106  
---
107  
--- The function takes the account information, request method, additional headers,
108  
--- resource, canonicalized resource and request body as parameters, and returns
109  
--- an error message or the response object.
110  
---
111  
-authenticatedRequest :: Account -> RequestMethod -> [Header] -> String -> String -> String -> IO (Either String Response_String)
112  
-authenticatedRequest acc method hdrs resource canonicalizedResource body = do
113  
-  time <- rfc1123Date
114  
-  connection <- openStream (accountHost acc) (accountPort acc)
115  
-  let contentMD5 =  (UTF8.toString . Base64C.encode . Crypto.encode . md5 . UTF8L.fromString) body
116  
-  let { auth = SharedKeyAuth
117  
-    { sharedKeyAuthVerb = method
118  
-    , sharedKeyAuthContentMD5 = contentMD5
119  
-    , sharedKeyAuthContentType = "application/atom+xml"
120  
-    , sharedKeyAuthDate = time
121  
-    , sharedKeyAuthCanonicalizedResource = "/" ++ accountName acc ++ accountResourcePrefix acc ++ canonicalizedResource } }
122  
-  let { basicHeaders =
123  
-    [ Header HdrAuthorization $ unAuthHeader $ authHeader acc auth
124  
-    , Header HdrContentType "application/atom+xml"
125  
-    , Header HdrContentMD5 contentMD5
126  
-    , Header HdrContentLength $ show $ length body
127  
-    , Header HdrAccept "application/atom+xml,application/xml"
128  
-    , Header HdrDate time
129  
-    , Header (HdrCustom "x-ms-date") time
130  
-    , Header (HdrCustom "x-ms-version") "2009-09-19"
131  
-    , Header (HdrCustom "DataServiceVersion") "1.0;NetFx"
132  
-    , Header (HdrCustom "MaxDataServiceVersion") "2.0;NetFx"] }
133  
-  let { request = Request
134  
-    { rqURI = qualifyResource resource acc
135  
-    , rqMethod = method
136  
-    , rqHeaders = basicHeaders ++ hdrs
137  
-    , rqBody = (id >>= trace) body } }
138  
-  result <- sendHTTP connection request :: IO (Result Response_String)
139  
-  _ <- close connection
140  
-  return $ either (Left . show) Right result
21  Network/AzureTables/Development.hs
... ...
@@ -1,21 +0,0 @@
1  
--- |
2  
--- This module contains constants for working with the storage emulator.
3  
---
4  
-
5  
-module Network.AzureTables.Development (
6  
-  developmentAccount
7  
-) where
8  
-
9  
-import Network.AzureTables.Types
10  
-    ( Account(..), AccountKey(AccountKey) )
11  
-
12  
--- |
13  
--- An account for the storage emulator
14  
---
15  
-developmentAccount :: Account
16  
-developmentAccount = Account { accountScheme            = "http",
17  
-                               accountHost              = "127.0.0.1" ,
18  
-                               accountName              = "devstoreaccount1",
19  
-                               accountPort              = 10002,
20  
-                               accountResourcePrefix    = "/devstoreaccount1",
21  
-                               accountKey               = AccountKey "Eby8vdM02xNOcqFlqUwJPLlmEtlCDXJ1OUzFT50uSRZ6IFsuFq2UVErCz4I6tq/K1SZFPTOtr/KBHBeksoGMGw=="}
26  Network/AzureTables/Format.hs
... ...
@@ -1,26 +0,0 @@
1  
--- |
2  
--- Helper methods for working with formatted dates
3  
---
4  
-
5  
-module Network.AzureTables.Format (
6  
-  getFormattedTime, rfc1123Date, atomDate,
7  
-  rfc1123Format, atomDateFormat
8  
-) where
9  
-
10  
-import Data.Time ( getCurrentTime, formatTime )
11  
-import System.Locale ( defaultTimeLocale )
12  
-
13  
-getFormattedTime :: String -> IO String
14  
-getFormattedTime formatString = fmap (formatTime defaultTimeLocale formatString) getCurrentTime
15  
-
16  
-rfc1123Date :: IO String
17  
-rfc1123Date = getFormattedTime rfc1123Format
18  
-
19  
-atomDate :: IO String
20  
-atomDate = getFormattedTime atomDateFormat
21  
-
22  
-rfc1123Format :: String
23  
-rfc1123Format = "%a, %d %b %Y %H:%M:%S GMT"
24  
-
25  
-atomDateFormat :: String
26  
-atomDateFormat = "%Y-%m-%dT%H:%M:%S%QZ"
85  Network/AzureTables/Query.hs
... ...
@@ -1,85 +0,0 @@
1  
--- |
2  
--- This module contains functions which help when unmarshalling query responses
3  
-
4  
-module Network.AzureTables.Query (
5  
-  edmBinary, edmBoolean, edmDateTime, edmDouble,
6  
-  edmGuid, edmInt32, edmInt64, edmString
7  
-) where
8  
-
9  
-import Data.Time ( UTCTime )
10  
-import Network.AzureTables.Types
11  
-    ( Entity(entityColumns),
12  
-      EntityColumn(EdmBinary, EdmBoolean, EdmDateTime, EdmDouble,
13  
-                   EdmGuid, EdmInt32, EdmInt64, EdmString) )
14  
-
15  
--- |
16  
--- Find the value in a binary-valued column or return Nothing if no such column exists
17  
-edmBinary :: String -> Entity -> Maybe String
18  
-edmBinary key en = do
19  
-  col <- lookup key $ entityColumns en
20  
-  case col of
21  
-    EdmBinary s -> s
22  
-    _ -> Nothing
23  
-
24  
--- |
25  
--- Find the value in a string-valued column or return Nothing if no such column exists
26  
-edmString :: String -> Entity -> Maybe String
27  
-edmString key en = do
28  
-  col <- lookup key $ entityColumns en
29  
-  case col of
30  
-    EdmString s -> s
31  
-    _ -> Nothing
32  
-
33  
--- |
34  
--- Find the value in a boolean-valued column or return Nothing if no such column exists
35  
-edmBoolean :: String -> Entity -> Maybe Bool
36  
-edmBoolean key en = do
37  
-  col <- lookup key $ entityColumns en
38  
-  case col of
39  
-    EdmBoolean s -> s
40  
-    _ -> Nothing
41  
-
42  
--- |
43  
--- Find the value in a date-valued column or return Nothing if no such column exists
44  
-edmDateTime :: String -> Entity -> Maybe UTCTime
45  
-edmDateTime key en = do
46  
-  col <- lookup key $ entityColumns en
47  
-  case col of
48  
-    EdmDateTime s -> s
49  
-    _ -> Nothing
50  
-
51  
--- |
52  
--- Find the value in a double-valued column or return Nothing if no such column exists
53  
-edmDouble :: String -> Entity -> Maybe Double
54  
-edmDouble key en = do
55  
-  col <- lookup key $ entityColumns en
56  
-  case col of
57  
-    EdmDouble s -> s
58  
-    _ -> Nothing
59  
-
60  
--- |
61  
--- Find the value in a Guid-valued column or return Nothing if no such column exists
62  
-edmGuid :: String -> Entity -> Maybe String
63  
-edmGuid key en = do
64  
-  col <- lookup key $ entityColumns en
65  
-  case col of
66  
-    EdmGuid s -> s
67  
-    _ -> Nothing
68  
-
69  
--- |
70  
--- Find the value in an integer-valued column or return Nothing if no such column exists
71  
-edmInt32 :: String -> Entity -> Maybe Int
72  
-edmInt32 key en = do
73  
-  col <- lookup key $ entityColumns en
74  
-  case col of
75  
-    EdmInt32 s -> s
76  
-    _ -> Nothing
77  
-
78  
--- |
79  
--- Find the value in an integer-valued column or return Nothing if no such column exists
80  
-edmInt64 :: String -> Entity -> Maybe Int
81  
-edmInt64 key en = do
82  
-  col <- lookup key $ entityColumns en
83  
-  case col of
84  
-    EdmInt64 s -> s
85  
-    _ -> Nothing
158  Network/AzureTables/Request.hs
... ...
@@ -1,158 +0,0 @@
1  
--- |
2  
--- Helper methods used to construct requests.
3  
---
4  
-
5  
-module Network.AzureTables.Request (
6  
-  propertyList,
7  
-  entityKeyResource,
8  
-  columnToTypeString,
9  
-  printEntityColumn,
10  
-  printComparisonType,
11  
-  buildFilterString,
12  
-  buildQueryString
13  
-) where
14  
-
15  
-import Data.Time ( formatTime )
16  
-import System.Locale ( defaultTimeLocale )
17  
-import Data.Maybe ( fromMaybe )
18  
-import Data.List ( intercalate )
19  
-import Text.XML.Light.Types ( elAttribs )
20  
-import Text.XML.Light
21  
-    ( Element(elAttribs, elContent, elName),
22  
-      Content(Elem),
23  
-      Attr(Attr),
24  
-      blank_element )
25  
-import Network.AzureTables.Types
26  
-    ( EntityFilter(..),
27  
-      ComparisonType(..),
28  
-      EntityQuery(eqFilter, eqPageSize),
29  
-      EntityColumn(..),
30  
-      EntityKey(ekPartitionKey, ekRowKey) )
31  
-import Network.AzureTables.XML ( cDataText )
32  
-import Network.AzureTables.Atom
33  
-    ( qualifyDataServices, qualifyMetadata )
34  
-import Network.AzureTables.Format ( atomDateFormat )
35  
-import Network.HTTP.Base ( urlEncode )
36  
-
37  
--- |
38  
--- Formats a list of entity properties for inclusion in an Atom entry.
39  
---
40  
-propertyList :: [(String, EntityColumn)] -> Element
41  
-propertyList props =
42  
-  blank_element { elName = qualifyMetadata "properties",
43  
-                  elContent = map property props } where
44  
-  property (key, value) =
45  
-    let stringValue = printEntityColumn value in
46  
-    Elem blank_element { elName = qualifyDataServices key,
47  
-                         elAttribs = [ Attr (qualifyMetadata "type") $ columnToTypeString value,
48  
-                                       Attr (qualifyMetadata "null") $ maybe "true" (const "false") stringValue ],
49  
-                         elContent = cDataText $ fromMaybe "" stringValue }
50  
-
51  
--- |
52  
--- Constructs relative URIs which refer to the entity with the specified table name
53  
--- and entity key.
54  
---
55  
-entityKeyResource :: String -> EntityKey -> String
56  
-entityKeyResource tableName key = "/" ++ tableName ++ "(PartitionKey='" ++ ekPartitionKey key ++ "',RowKey='" ++ ekRowKey key ++ "')"
57  
-
58  
--- |
59  
--- Converts an entity column into its type name
60  
---
61  
-columnToTypeString :: EntityColumn -> String
62  
-columnToTypeString (EdmBinary _)        = "Edm.Binary"
63  
-columnToTypeString (EdmBoolean _)       = "Edm.Boolean"
64  
-columnToTypeString (EdmDateTime _)      = "Edm.DateTime"
65  
-columnToTypeString (EdmDouble _)        = "Edm.Double"
66  
-columnToTypeString (EdmGuid _)          = "Edm.EdmGuid"
67  
-columnToTypeString (EdmInt32 _)         = "Edm.Int32"
68  
-columnToTypeString (EdmInt64 _)         = "Edm.Int64"
69  
-columnToTypeString (EdmString _)        = "Edm.String"
70  
-
71  
--- |
72  
--- Formats a column value to appear in the body of an Atom entry
73  
---
74  
-printEntityColumn :: EntityColumn -> Maybe String
75  
-printEntityColumn (EdmBinary (Just val))       = Just val
76  
-printEntityColumn (EdmBoolean (Just True))     = Just "true"
77  
-printEntityColumn (EdmBoolean (Just False))    = Just "false"
78  
-printEntityColumn (EdmDateTime (Just val))     = Just $ formatTime defaultTimeLocale atomDateFormat val
79  
-printEntityColumn (EdmDouble (Just val))       = Just $ show val
80  
-printEntityColumn (EdmGuid (Just val))         = Just val
81  
-printEntityColumn (EdmInt32 (Just val))        = Just $ show val
82  
-printEntityColumn (EdmInt64 (Just val))        = Just $ show val
83  
-printEntityColumn (EdmString (Just val))       = Just val
84  
-printEntityColumn _                            = Nothing
85  
-
86  
--- |
87  
--- Formats a comparison type to appear in the query string
88  
---
89  
-printComparisonType :: ComparisonType -> String
90  
-printComparisonType Equal               = "eq"
91  
-printComparisonType GreaterThan         = "gt"
92  
-printComparisonType GreaterThanOrEqual  = "ge"
93  
-printComparisonType LessThan            = "lt"
94  
-printComparisonType LessThanOrEqual     = "le"
95  
-printComparisonType NotEqual            = "ne"
96  
-
97  
--- |
98  
--- Converts entity filter values into strings to appear in the filter
99  
--- portion of the Query Entities URI.
100  
---
101  
-buildFilterString :: EntityFilter -> String
102  
-buildFilterString (And fs) = '(' : intercalate "%20and%20" (map buildFilterString fs) ++ ")"
103  
-buildFilterString (Or fs) = '(' : intercalate "%20or%20" (map buildFilterString fs) ++ ")"
104  
-buildFilterString (Not f) =
105  
-  "(not%20"
106  
-  ++ buildFilterString f
107  
-  ++ ")"
108  
-buildFilterString (CompareBoolean prop val) =
109  
-  urlEncode prop
110  
-  ++ "%20eq%20"
111  
-  ++ if val then "true" else "false"
112  
-buildFilterString (CompareDateTime prop cmp val) =
113  
-  urlEncode prop
114  
-  ++ "%20"
115  
-  ++ printComparisonType cmp
116  
-  ++ "%20datetime'"
117  
-  ++ formatTime defaultTimeLocale atomDateFormat val
118  
-  ++ "'"
119  
-buildFilterString (CompareDouble prop cmp val) =
120  
-  urlEncode prop
121  
-  ++ "%20"
122  
-  ++ printComparisonType cmp
123  
-  ++ "%20"
124  
-  ++ show val
125  
-buildFilterString (CompareGuid prop val) =
126  
-  urlEncode prop
127  
-  ++ "%20eq%20guid'"
128  
-  ++ val
129  
-  ++ "'"
130  
-buildFilterString (CompareInt32 prop cmp val) =
131  
-  urlEncode prop
132  
-  ++ "%20"
133  
-  ++ printComparisonType cmp
134  
-  ++ "%20"
135  
-  ++ show val
136  
-buildFilterString (CompareInt64 prop cmp val) =
137  
-  urlEncode prop
138  
-  ++ "%20"
139  
-  ++ printComparisonType cmp
140  
-  ++ "%20"
141  
-  ++ show val
142  
-buildFilterString (CompareString prop cmp val) =
143  
-  urlEncode prop
144  
-  ++ "%20"
145  
-  ++ printComparisonType cmp
146  
-  ++ "%20'"
147  
-  ++ urlEncode val
148  
-  ++ "'"
149  
-
150  
--- |
151  
--- Constructs the full query string for the Query Entities web method.
152  
---
153  
-buildQueryString :: EntityQuery -> String
154  
-buildQueryString query =
155  
-  "$filter="
156  
-  ++ maybe "" buildFilterString (eqFilter query)
157  
-  ++ "&$top="
158  
-  ++ maybe "" show (eqPageSize query)
82  Network/AzureTables/Response.hs
... ...
@@ -1,82 +0,0 @@
1  
--- |
2  
--- Helper methods for parsing web method response bodies.
3  
---
4  
-
5  
-module Network.AzureTables.Response (
6  
-  parseError, errorToString,
7  
-  parseEmptyResponse, parseXmlResponseOrError,
8  
-  parseEntityColumn
9  
-) where
10  
-
11  
-import Data.Time ( readTime )
12  
-import System.Locale ( defaultTimeLocale )
13  
-import Text.XML.Light
14  
-    ( Element(elName), parseXMLDoc, findChild, strContent )
15  
-import Control.Monad ( guard )
16  
-import Data.Maybe ( fromMaybe )
17  
-import Network.AzureTables.Atom ( qualifyMetadata )
18  
-import Network.AzureTables.Types ( EntityColumn(..) )
19  
-import Network.AzureTables.Format ( atomDateFormat )
20  
-import Network.HTTP.Base
21  
-    ( ResponseCode, Response(rspBody, rspCode), Response_String )
22  
-
23  
--- |
24  
--- Extracts the error message from an error response
25  
---
26  
-parseError :: Element -> Maybe String
27  
-parseError root = do
28  
-  guard $ qualifyMetadata "error" == elName root
29  
-  message <- findChild (qualifyMetadata "message") root
30  
-  return $ strContent message
31  
-
32  
--- |
33  
--- Summarize an error appearing in a response body or return "Unknown error" if the response cannot be parsed
34  
---
35  
-errorToString :: Response_String -> String
36  
-errorToString res = fromMaybe "Unknown error" (parseXMLDoc (rspBody res) >>= parseError)
37  
-
38  
--- |
39  
--- Verifies a response code, parsing an error message if necessary.
40  
---
41  
-parseEmptyResponse :: ResponseCode -> Response_String -> Either String ()
42  
-parseEmptyResponse code res =
43  
-  if rspCode res == code
44  
-  then
45  
-    Right ()
46  
-  else
47  
-    Left $ errorToString res
48  
-
49  
--- |
50  
--- Parse an XML response, or an error response as appropriate.
51  
---
52  
-parseXmlResponseOrError :: ResponseCode -> (Element -> Maybe a) -> Response_String -> Either String a
53  
-parseXmlResponseOrError code parse res =
54  
-  let xmlDoc = parseXMLDoc (rspBody res) in
55  
-  if rspCode res == code
56  
-  then
57  
-    maybe (Left "Unable to parse result") Right $ xmlDoc >>= parse
58  
-  else
59  
-    Left $ fromMaybe "Unknown error" (xmlDoc >>= parseError)
60  
-
61  
--- |
62  
--- Parses an entity column type and value
63  
---
64  
-parseEntityColumn :: Bool -> String -> String -> Maybe EntityColumn
65  
-parseEntityColumn True  "Edm.Binary"   _        = Just $ EdmBinary Nothing
66  
-parseEntityColumn False "Edm.Binary"   val      = Just $ EdmBinary $ Just val
67  
-parseEntityColumn True  "Edm.Boolean"  _        = Just $ EdmBoolean Nothing
68  
-parseEntityColumn False "Edm.Boolean"  "true"   = Just $ EdmBoolean $ Just True
69  
-parseEntityColumn False "Edm.Boolean"  "false"  = Just $ EdmBoolean $ Just False
70  
-parseEntityColumn True  "Edm.DateTime" _        = Just $ EdmDateTime Nothing
71  
-parseEntityColumn False "Edm.DateTime" val      = Just $ EdmDateTime $ Just $ readTime defaultTimeLocale atomDateFormat val
72  
-parseEntityColumn True  "Edm.Double"   _        = Just $ EdmDouble Nothing
73  
-parseEntityColumn False "Edm.Double"   val      = Just $ EdmDouble $ Just $ read val
74  
-parseEntityColumn True  "Edm.Guid"     _        = Just $ EdmGuid Nothing
75  
-parseEntityColumn False "Edm.Guid"     val      = Just $ EdmGuid $ Just val
76  
-parseEntityColumn True  "Edm.Int32"    _        = Just $ EdmInt32 Nothing
77  
-parseEntityColumn False "Edm.Int32"    val      = Just $ EdmInt32 $ Just $ read val
78  
-parseEntityColumn True  "Edm.Int64"    _        = Just $ EdmInt64 Nothing
79  
-parseEntityColumn False "Edm.Int64"    val      = Just $ EdmInt64 $ Just $ read val
80  
-parseEntityColumn True  "Edm.String"   _        = Just $ EdmString Nothing
81  
-parseEntityColumn False "Edm.String"   val      = Just $ EdmString $ Just val
82  
-parseEntityColumn _     _              _        = Nothing
127  Network/AzureTables/Types.hs
... ...
@@ -1,127 +0,0 @@
1  
--- |
2  
--- Data types used to construct the various web method requests.
3  
---
4  
-module Network.AzureTables.Types (
5  
-  AccountKey(..),
6  
-  Signature(..),
7  
-  AuthHeader(..),
8  
-  Account(..),
9  
-  SharedKeyAuth(..),
10  
-  EntityKey(..),
11  
-  EntityColumn(..),
12  
-  Entity(..),
13  
-  EntityQuery(..),
14  
-  ComparisonType(..),
15  
-  EntityFilter(..)
16  
-) where
17  
-
18  
-import Data.Time ( UTCTime )
19  
-import Network.HTTP.Base ( RequestMethod )
20  
-
21  
--- |
22  
--- The Base-64 encoded account secret key
23  
---
24  
-newtype AccountKey = AccountKey { unAccountKey :: String } deriving (Show, Eq)
25  
-
26  
--- |
27  
--- The type of authorization header signatures
28  
---
29  
-newtype Signature = Signature { unSignature :: String } deriving (Show, Eq)
30  
-
31  
--- |
32  
--- The type of authorization headers
33  
---
34  
-newtype AuthHeader = AuthHeader { unAuthHeader :: String } deriving (Show, Eq)
35  
-
36  
--- |
37  
--- Account information: host, port, secret key and account name
38  
---
39  
-data Account = Account
40  
-  { accountScheme         :: String
41  
-  , accountHost           :: String
42  
-  , accountPort           :: Int
43  
-  , accountKey            :: AccountKey
44  
-  , accountName           :: String
45  
-  , accountResourcePrefix :: String
46  
-  } deriving (Show, Eq)
47  
-
48  
--- |
49  
--- The unencrypted content of the Shared Key authorization header
50  
---
51  
-data SharedKeyAuth = SharedKeyAuth
52  
-  { sharedKeyAuthVerb                  :: RequestMethod
53  
-  , sharedKeyAuthContentMD5            :: String
54  
-  , sharedKeyAuthContentType           :: String
55  
-  , sharedKeyAuthDate                  :: String
56  
-  , sharedKeyAuthCanonicalizedResource :: String
57  
-  } deriving (Show, Eq)
58  
-
59  
--- |
60  
--- Uniquely identifies an entity in a table : a partition key and row key pair.
61  
---
62  
-data EntityKey = EntityKey
63  
-  { ekPartitionKey :: String
64  
-  , ekRowKey       :: String
65  
-  } deriving (Show, Eq)
66  
-
67  
--- |
68  
--- Represents a column in an entity.
69  
---
70  
--- The constructor used indicates the data type of the column represented.
71  
---
72  
--- For certain operations, the type must match the type of data stored in the table.
73  
---
74  
-data EntityColumn =
75  
-  EdmBinary (Maybe String) |
76  
-  EdmBoolean (Maybe Bool) |
77  
-  EdmDateTime (Maybe UTCTime) |
78  
-  EdmDouble (Maybe Double) |
79  
-  EdmGuid (Maybe String) |
80  
-  EdmInt32 (Maybe Int) |
81  
-  EdmInt64 (Maybe Int) |
82  
-  EdmString (Maybe String)
83  
-  deriving (Show, Eq)
84  
-
85  
--- |
86  
--- An entity consists of a key and zero or more additional columns.
87  
---
88  
-data Entity = Entity { entityKey     :: EntityKey,
89  
-                       entityColumns :: [(String, EntityColumn)] } deriving Show
90  
-
91  
--- |
92  
--- An entity query consists of an optional filter and an optional number of entities to return.
93  
---
94  
--- Projections are not currently supported.
95  
---
96  
-data EntityQuery = EntityQuery
97  
-  { eqPageSize :: Maybe Int
98  
-  , eqFilter   :: Maybe EntityFilter
99  
-  } deriving (Show, Eq)
100  
-
101  
--- |
102  
--- The various comparisons supported in entity queries.
103  
---
104  
-data ComparisonType =
105  
-  Equal |
106  
-  GreaterThan |
107  
-  GreaterThanOrEqual |
108  
-  LessThan |
109  
-  LessThanOrEqual |
110  
-  NotEqual
111  
-  deriving (Show, Eq)
112  
-
113  
--- |
114  
--- The data type of entity filters
115  
---
116  
-data EntityFilter =
117  
-  And [EntityFilter] |
118  
-  Or [EntityFilter] |
119  
-  Not EntityFilter |
120  
-  CompareBoolean String Bool |
121  
-  CompareDateTime String ComparisonType UTCTime |
122  
-  CompareDouble String ComparisonType Double |
123  
-  CompareGuid String String |
124  
-  CompareInt32 String ComparisonType Integer |
125  
-  CompareInt64 String ComparisonType Integer |
126  
-  CompareString String ComparisonType String
127  
-  deriving (Show, Eq)
37  Network/AzureTables/XML.hs
... ...
@@ -1,37 +0,0 @@
1  
--- |
2  
--- Helper methods for working with XML
3  
---
4  
-
5  
-module Network.AzureTables.XML (
6  
-  qualify, cDataText, namespaceAttr
7  
-) where
8  
-
9  
-import Text.XML.Light.Types
10  
-    ( Content(Text),
11  
-      CDataKind(CDataText),
12  
-      CData(CData, cdData, cdLine, cdVerbatim),
13  
-      QName(..),
14  
-      Attr(..) )
15  
-
16  
--- |
17  
--- Qualify a name for a specific namespace and/or prefix
18  
---
19  
-qualify :: Maybe String -> Maybe String -> String -> QName
20  
-qualify namespace prefix name =
21  
-  QName { qName = name,
22  
-          qURI = namespace,
23  
-          qPrefix = prefix }
24  
-
25  
--- |
26  
--- Constructs a piece of content consisting of a single string.
27  
---
28  
-cDataText :: String -> [Content]
29  
-cDataText content = [ Text CData { cdVerbatim = CDataText, cdData = content, cdLine = Nothing } ]
30  
-
31  
--- |
32  
--- Constructs an xmlns attribute to be added to the document root
33  
---
34  
-namespaceAttr :: String -> String -> Attr
35  
-namespaceAttr prefix uri =
36  
-  Attr { attrKey = qualify Nothing (Just "xmlns") prefix,
37  
-         attrVal = uri }
27  persistent-azuretables.cabal
@@ -24,16 +24,6 @@ cabal-version:       >=1.8
24 24
 
25 25
 library
26 26
   exposed-modules: Database.Persist.AzureTables
27  
-                  , Network.AzureTables.API
28  
-                  , Network.AzureTables.Atom
29  
-                  , Network.AzureTables.Auth
30  
-                  , Network.AzureTables.Development
31  
-                  , Network.AzureTables.Format
32  
-                  , Network.AzureTables.Query
33  
-                  , Network.AzureTables.Request
34  
-                  , Network.AzureTables.Response
35  
-                  , Network.AzureTables.Types
36  
-                  , Network.AzureTables.XML
37 27
 
38 28
   -- Modules included in this library but not exported.
39 29
   -- other-modules:
@@ -41,20 +31,9 @@ library
41 31
   -- Other library packages from which modules are imported.
42 32
   build-depends: base ==4.5.*
43 33
                , template-haskell
44  
-               , persistent               >= 1.1      && < 1.2
45  
-               , monad-control            >= 0.2       && < 0.4
46  
-               , text                     >= 0.5       && < 1.0
47  
-               , transformers             >= 0.2       && < 0.4
48  
-               , containers
  34
+               , persistent               >= 1.1
49 35
                , aeson
50  
-               , SHA
51 36
                , bytestring
52  
-               , utf8-string
53  
-               , base64-bytestring
54  
-               , HTTP
55  
-               , network
56  
-               , time
57  
-               , xml
58  
-               , old-locale
  37
+               , http-conduit             >= 1.6.0.3
59 38
                , mtl
60  
-               , pureMD5
  39
+               , tablestorage             >= 0.1.2

0 notes on commit 53763e8

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