hSimpleDB (empty) → 0.1
raw patch · 9 files changed
+894/−0 lines, 9 filesdep +Cryptodep +HTTPdep +basesetup-changed
Dependencies added: Crypto, HTTP, base, bytestring, dataenc, hxt, network, old-locale, old-time, utf8-string
Files
- LICENSE +31/−0
- Setup.lhs +3/−0
- hSimpleDB.cabal +22/−0
- src/Network/AWS/AWSConnection.hs +74/−0
- src/Network/AWS/AWSResult.hs +41/−0
- src/Network/AWS/Actions.hs +298/−0
- src/Network/AWS/ArrowUtils.hs +30/−0
- src/Network/AWS/Authentication.hs +387/−0
- src/Network/AWS/SimpleDB.hs +8/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2007, Greg Heartsfield, 2009 David Himmelstrup++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.++ * The names of contributors may not 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 THE COPYRIGHT+OWNER OR CONTRIBUTORS 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.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ hSimpleDB.cabal view
@@ -0,0 +1,22 @@+name: hSimpleDB+version: 0.1+synopsis: Interface to Amazon's SimpleDB service.+description: Interface to Amazon's SimpleDB service.+category: Database, Web, Network+license: BSD3+license-file: LICENSE+author: David Himmelstrup 2009, Greg Heartsfield 2007+maintainer: David Himmelstrup <lemmih@gmail.com>+build-Depends: base>=3 && <=4, hxt, old-locale, old-time, utf8-string, Crypto, dataenc,+ bytestring, network, HTTP+build-type: Simple+ghc-options: +hs-source-dirs: src+exposed-modules:+ Network.AWS.SimpleDB+other-modules:+ Network.AWS.Authentication+ Network.AWS.Actions+ Network.AWS.AWSConnection+ Network.AWS.AWSResult+ Network.AWS.ArrowUtils
+ src/Network/AWS/AWSConnection.hs view
@@ -0,0 +1,74 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.AWS.AWSConnection+-- Copyright : (c) Greg Heartsfield 2007+-- License : BSD3+--+-- Connection and authentication info for an Amazon AWS request.+-----------------------------------------------------------------------------+module Network.AWS.AWSConnection (+ -- * Constants+ defaultAmazonSimpleDBHost, defaultAmazonSimpleDBPort,+ -- * Function Types+ amazonSimpleDBConnection, -- amazonS3ConnectionFromEnv,+ -- * Data Types+ AWSConnection(..)+ ) where++import System.Environment++-- | An Amazon Web Services connection. Everything needed to connect+-- and authenticate requests.+data AWSConnection =+ AWSConnection { awsHost :: String, -- ^ Service provider hostname+ awsPort :: Int, -- ^ Service provider port number+ awsAccessKey :: String, -- ^ Access Key ID+ awsSecretKey :: String -- ^ Secret Access Key+ } deriving (Show)++-- | Hostname used for connecting to Amazon's production S3 service (@s3.amazonaws.com@).+defaultAmazonS3Host :: String+defaultAmazonS3Host = "s3.amazonaws.com"++-- | Hostname used for connecting to Amazon's production SimpleDB service (@sdb.amazonaws.com@).+defaultAmazonSimpleDBHost :: String+defaultAmazonSimpleDBHost = "sdb.amazonaws.com"++-- | Port number used for connecting to Amazon's production S3 service (@80@).+defaultAmazonS3Port :: Int+defaultAmazonS3Port = 80++-- | Port number used for connecting to Amazon's production SimpleDB service (@80@).+defaultAmazonSimpleDBPort :: Int+defaultAmazonSimpleDBPort = 80++-- | Create an AWSConnection to Amazon from credentials. Uses the+-- production service.+amazonS3Connection :: String -- ^ Access Key ID+ -> String -- ^ Secret Access Key+ -> AWSConnection -- ^ Connection to Amazon S3+amazonS3Connection = AWSConnection defaultAmazonS3Host defaultAmazonS3Port++-- | Create an AWSConnection to Amazon from credentials. Uses the+-- production service.+amazonSimpleDBConnection :: String -- ^ Access Key ID+ -> String -- ^ Secret Access Key+ -> AWSConnection -- ^ Connection to Amazon S3+amazonSimpleDBConnection = AWSConnection defaultAmazonSimpleDBHost defaultAmazonSimpleDBPort++-- | Retrieve Access and Secret keys from environment variables+-- AWS_ACCESS_KEY_ID and AWS_SECRET_ACCESS_KEY, respectively.+-- Either variable being undefined or empty will result in+-- 'Nothing'.+amazonS3ConnectionFromEnv :: IO (Maybe AWSConnection)+amazonS3ConnectionFromEnv =+ do ak <- getEnvKey "AWS_ACCESS_KEY_ID"+ sk0 <- getEnvKey "AWS_ACCESS_KEY_SECRET"+ sk1 <- getEnvKey "AWS_SECRET_ACCESS_KEY"+ return $ case (ak, sk0, sk1) of+ ("", _, _) -> Nothing+ ( _, "", "") -> Nothing+ ( _, "", _) -> Just (amazonS3Connection ak sk1)+ ( _, _, _) -> Just (amazonS3Connection ak sk0)+ where getEnvKey s = catch (getEnv s) (const $ return "")+
+ src/Network/AWS/AWSResult.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.AWS.AWSResult+-- Copyright : (c) Greg Heartsfield 2007+-- License : BSD3+--+-- Results from a query to Amazon Web Services.+-- API Version 2006-03-01+-- <http://docs.amazonwebservices.com/AmazonS3/2006-03-01/>+-----------------------------------------------------------------------------++module Network.AWS.AWSResult (+ -- * Data Types+ AWSResult,+ ReqError(..),+ prettyReqError+ ) where++import Network.Stream as Stream++-- | A result from processing a request to S3. Either some success+-- value, or a 'ReqError'.+type AWSResult a = Either ReqError a++-- | An error from an S3 request, either at the network layer, or from+-- S3 itself.+data ReqError =+ -- | Connection error at the network layer.+ NetworkError Stream.ConnError |+ -- | @AWSError code message@ constructs an error message from S3+ -- itself. See+ -- <http://docs.amazonwebservices.com/AmazonS3/2006-03-01/ErrorCodeList.html>+ -- for a detailed list of possible codes.+ AWSError String String+ deriving (Show, Eq)++-- | Pretty print an error message.+prettyReqError :: ReqError -> String+prettyReqError r = case r of+ AWSError a b -> b+ NetworkError c -> show c
+ src/Network/AWS/Actions.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE NoMonomorphismRestriction, Arrows #-}+module Network.AWS.Actions+ ( -- * Types+ DomainName+ , MaxNumberOfDomains+ , SelectExpression+ , ItemName+ , AttributeKey+ , AttributeValue+ , Attribute(..)+ , Item(..)+ -- * Actions+ , createDomain+ , deleteDomain+ , listDomains+-- , listDomains'+ , getAttributes+ , putAttributes+ , putAttributes'+ , batchPutAttributes+ , batchPutAttributes'+ , deleteAttributes+ , select+ ) where++import Network.AWS.Authentication+import Network.AWS.AWSConnection++import qualified Data.ByteString.Lazy.Char8 as L+import Network.HTTP++import Text.XML.HXT.Arrow+import qualified Data.Tree.NTree.TypeDefs+import Control.Arrow+import Data.List+++-- | Domain name limits: 3-255 characters (a-z, A-Z, 0-9, '_', '-', and '.')+type DomainName = String+type MaxNumberOfDomains = Int+type SelectExpression = String+type ItemName = String+type AttributeKey = String+type AttributeValue = String++data Attribute = AttributeKey := AttributeValue+ deriving (Read,Show,Eq,Ord)++data Item = Item { itemName :: ItemName+ , itemAttributes :: [Attribute] }+ deriving (Read,Show,Eq,Ord)++attributeKey :: Attribute -> AttributeKey+attributeKey (key := _) = key++attributeValue :: Attribute -> AttributeValue+attributeValue (_ := value) = value++-- | The @createDomain@ operation creates a new domain. The domain name must be unique+-- among the domains associated with the Access Key ID provided in the request. The+-- @createDomain@ operation might take 10 or more seconds to complete.+createDomain :: AWSConnection -> DomainName -> IO ()+createDomain conn domain+ = do let action = SimpleDBAction { sdbConnection = conn+ , sdbQuery = ["Action=CreateDomain","DomainName="++urlEncode domain,"Version=2009-04-15", "SignatureVersion=2","SignatureMethod=HmacSHA1"]+ , sdbMetaData = []+ , sdbBody = L.empty+ , sdbOperation = GET }+ result <- runAction action+ case result of+ Left err -> error (show err)+ Right _rsp -> return ()++-- | The @listDomains@ operation lists all domains associated with the Access Key ID.+listDomains :: AWSConnection -> IO [DomainName]+listDomains conn+ = do let action = SimpleDBAction { sdbConnection = conn+ , sdbQuery = ["Action=ListDomains","Version=2009-04-15", "SignatureVersion=2","SignatureMethod=HmacSHA1"]+ , sdbMetaData = []+ , sdbBody = L.empty+ , sdbOperation = GET }+ result <- runAction action+ case result of+ Left err -> error (show err)+ Right rsp -> parseDomainListXML (L.unpack $ rspBody rsp)++-- | The @listDomains@ operation lists all domains associated with the Access Key ID.+-- It returns domain names up to the limit set by `MaxNumberOfDomains`. A NextToken+-- is returned if there are more than `MaxNumberOfDomains` domains. Calling @listDomains'@+-- successive times with the @NextToken@ returns up to `MaxNumberOfDomains` more domain+-- names each time.+listDomains' :: AWSConnection -> MaxNumberOfDomains -> Maybe DomainName -> IO [DomainName]+listDomains' conn maxNumberOfDomains mbNextToken+ = do let action = SimpleDBAction { sdbConnection = conn+ , sdbQuery = [ "Action=ListDomains","Version=2009-04-15"+ , "SignatureVersion=2","SignatureMethod=HmacSHA1"] +++ [ "MaxNumberOfDomains="++show maxNumberOfDomains] +++ maybe [] (\nextToken -> ["NextToken="++urlEncode nextToken]) mbNextToken+ , sdbMetaData = []+ , sdbBody = L.empty+ , sdbOperation = GET }+ result <- runAction action+ case result of+ Left err -> error (show err)+ Right rsp -> parseDomainListXML (L.unpack $ rspBody rsp)+++parseDomainListXML :: String -> IO [DomainName]+parseDomainListXML x = runX (readString [(a_validate,v_0)] x >>> processDomains)++processDomains :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) DomainName+processDomains = deep (isElem >>> hasName "ListDomainsResult") >>>+ (text <<< atTag "DomainName")++-- | The @deleteDomain@ operation deletes a domain. Any items (and their attributes)+-- in the domain are deleted as well. The @deleteDomain@ operation might take 10 or+-- more seconds to complete.+deleteDomain :: AWSConnection -> DomainName -> IO ()+deleteDomain conn domain+ = do let action = SimpleDBAction { sdbConnection = conn+ , sdbQuery = [ "Action=DeleteDomain","DomainName="++urlEncode domain,"Version=2009-04-15"+ , "SignatureVersion=2","SignatureMethod=HmacSHA1"]+ , sdbMetaData = []+ , sdbBody = L.empty+ , sdbOperation = GET }+ result <- runAction action+ case result of+ Left err -> error (show err)+ Right _rsp -> return ()++-- | The @putAttributes@ operation creates or replaces attributes in an item.+-- Attributes are uniquely identified in an item by their name/value combination.+-- For example, a single item can have the attributes @[\"first_name\" := \"first_value\"]@+-- and @[\"first_name\" := \"second_value\"]@. However, it cannot have two attribute+-- instances where both the name and value are the same.+-- See also `putAttributes'`.+putAttributes :: AWSConnection -> DomainName -> Item -> IO ()+putAttributes conn domainName item+ = putAttributes' conn domainName item []++-- | The @putAttributes@ operation creates or replaces attributes in an item.+-- Attributes are uniquely identified in an item by their name/value combination.+-- For example, a single item can have the attributes @[\"first_name\" := \"first_value\"]@+-- and @[\"first_name\" := \"second_value\"]@. However, it cannot have two attribute+-- instances where both the name and value are the same.+-- +-- This command differs from `putAttributes` by taking a list of attribute keys that+-- are to be replaced instead of appended.+putAttributes' :: AWSConnection -> DomainName -> Item+ -> [AttributeKey] -- ^ Keys for the attributes that should be replaced.+ -> IO ()+putAttributes' conn domainName item toReplace+ | not (null (toReplace \\ map attributeKey (itemAttributes item)))+ = error "Network.AWS.Actions.putAttributes': Attributes to replace are not a subset of total attributes."+putAttributes' conn domainName item toReplace+ = do let action = SimpleDBAction { sdbConnection = conn+ , sdbQuery = [ "Action=PutAttributes","ItemName="++urlEncode (itemName item),"Version=2009-04-15"+ , "SignatureVersion=2","SignatureMethod=HmacSHA1", "DomainName="++urlEncode domainName] +++ concat [ ["Attribute."++show n++".Name="++urlEncode key+ ,"Attribute."++show n++".Value="++urlEncode val] +++ if replace then ["Attribute."++show n++".Replace=true"] else []+ | (key := val, n) <- zip (itemAttributes item) [0..]+ , let replace = key `elem` toReplace ]+ , sdbMetaData = []+ , sdbBody = L.empty+ , sdbOperation = GET }+ result <- runAction action+ case result of+ Left err -> error (show err)+ Right _rsp -> return ()++-- | With the @batchPutAttributes@ operation, you can perform multiple @putAttribute@+-- operations in a single call. This helps you yield savings in round trips and+-- latencies, and enables Amazon SimpleDB to optimize requests, which generally+-- yields better throughput.+--+-- See also `putAttributes`.+batchPutAttributes :: AWSConnection -> DomainName -> [Item] -> IO ()+batchPutAttributes conn domainName items+ = batchPutAttributes' conn domainName [ (item, []) | item <- items ]++-- | With the @batchPutAttributes@ operation, you can perform multiple @putAttribute@+-- operations in a single call. This helps you yield savings in round trips and+-- latencies, and enables Amazon SimpleDB to optimize requests, which generally+-- yields better throughput.+--+-- See also `putAttributes'`.+batchPutAttributes' :: AWSConnection -> DomainName -> [(Item, [AttributeKey])] -> IO ()+batchPutAttributes' conn domainName items+ = do let action = SimpleDBAction { sdbConnection = conn+ , sdbQuery = [ "Action=BatchPutAttributes","Version=2009-04-15"+ , "SignatureVersion=2","SignatureMethod=HmacSHA1", "DomainName="++urlEncode domainName] +++ concat [ ["Item."++show idx++".ItemName="++urlEncode (itemName item)] +++ concat [ ["Item."++show idx++".Attribute."++show n++".Name="++urlEncode key+ ,"Item."++show idx++".Attribute."++show n++".Value="++urlEncode val] +++ if replace then ["Item."++show idx++".Attribute."++show n++".Replace=true"] else []+ | (key := val, n) <- zip (itemAttributes item) [0..]+ , let replace = key `elem` toReplace ]+ | ((item, toReplace),idx) <- zip items [0..]]+ , sdbMetaData = []+ , sdbBody = L.empty+ , sdbOperation = GET }+ result <- runAction action+ case result of+ Left err -> error (show err)+ Right _rsp -> return ()+++++-- FIXME: Support NextToken.+-- | The @select@ operation returns a set of Attributes for ItemNames that match the+-- select expression. @select@ is similar to the standard SQL SELECT statement.+-- The total size of the response cannot exceed 1 MB in total size. Amazon SimpleDB+-- automatically adjusts the number of items returned per page to enforce this limit.+-- For example, even if you ask to retrieve 2500 items, but each individual item is+-- 10 kB in size, the system returns 100 items and an appropriate next token so you+-- can get the next page of results.+select :: AWSConnection -> SelectExpression -> IO [Item]+select conn expression+ = do let action = SimpleDBAction { sdbConnection = conn+ , sdbQuery = [ "Action=Select","Version=2009-04-15"+ , "SignatureVersion=2","SignatureMethod=HmacSHA1"+ , "SelectExpression="++urlEncode expression]+ , sdbMetaData = []+ , sdbBody = L.empty+ , sdbOperation = GET }+ result <- runAction action+ case result of+ Left err -> error (show err)+ Right rsp -> parseSelectResponseXML (L.unpack $ rspBody rsp)++parseSelectResponseXML :: String -> IO [Item]+parseSelectResponseXML x = runX (readString [(a_validate,v_0)] x >>> processSelectResponse)++processSelectResponse :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) Item+processSelectResponse+ = proc x -> do y <- deep (isElem >>> hasName "Item") -< x+ name <- (text <<< hasName "Name" <<< getChildren) -< y+ attrs <- listA (atTag "Attribute" >>> textAt "Name" &&& textAt "Value" >>> arr (uncurry (:=))) -< y+ returnA -< Item name attrs+++-- | Returns all of the attributes associated with the item. Optionally, the attributes+-- returned can be limited to one or more specified attribute name parameters. If the+-- item does not exist on the replica that was accessed for this operation, an empty+-- set is returned. The system does not return an error as it cannot guarantee the+-- item does not exist on other replicas.+getAttributes :: AWSConnection -> DomainName -> ItemName -> [AttributeKey] -> IO Item+getAttributes conn domain itemName attributes+ = do let action = SimpleDBAction { sdbConnection = conn+ , sdbQuery = [ "Action=GetAttributes","DomainName="++urlEncode domain,"Version=2009-04-15"+ , "SignatureVersion=2","SignatureMethod=HmacSHA1"+ , "ItemName="++urlEncode itemName] +++ [ "AttributeName."++show n ++ "=" ++ urlEncode key | (key, n) <- zip attributes [0..] ]+ , sdbMetaData = []+ , sdbBody = L.empty+ , sdbOperation = GET }+ result <- runAction action+ case result of+ Left err -> error (show err)+ Right rsp -> do attrs <- parseAttributesXML (L.unpack $ rspBody rsp)+ return $ Item itemName attrs++parseAttributesXML :: String -> IO [Attribute]+parseAttributesXML x = runX (readString [(a_validate,v_0)] x >>> processAttributesResponse)++processAttributesResponse :: ArrowXml a => a (Data.Tree.NTree.TypeDefs.NTree XNode) Attribute+processAttributesResponse+ = proc x -> do y <- deep (atTag "Attribute") -< x+ textAt "Name" &&& textAt "Value" >>> arr (uncurry (:=)) -< y+++-- | Deletes one or more attributes associated with the item. If all attributes of an item+-- are deleted, the item is deleted.+deleteAttributes :: AWSConnection -> DomainName -> Item -> IO ()+deleteAttributes conn domain item+ = do let action = SimpleDBAction { sdbConnection = conn+ , sdbQuery = [ "Action=DeleteAttributes","DomainName="++urlEncode domain,"Version=2009-04-15"+ , "SignatureVersion=2","SignatureMethod=HmacSHA1"+ , "ItemName="++urlEncode (itemName item)] +++ concat [ [ "Attribute."++show n++".Name="++urlEncode key ] +++ if null val then [] else+ ["Attribute."++show n++".Value="++urlEncode val ]+ | (key := val, n) <- zip (itemAttributes item) [0..] ]+ , sdbMetaData = []+ , sdbBody = L.empty+ , sdbOperation = GET }+ result <- runAction action+ case result of+ Left err -> error (show err)+ Right _rsp -> return ()+++-- Utilities+atTag tag = deep (isElem >>> hasName tag)+text = getChildren >>> getText+textAt tag = atTag tag >>> text
+ src/Network/AWS/ArrowUtils.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE NoMonomorphismRestriction#-}+-----------------------------------------------------------------------------+-- |+-- Module : Network.AWS.ArrowUtils+-- Copyright :+-- License :+--+-- Helper functions for working with HXT. Scraped from <haskell.org>.+-----------------------------------------------------------------------------++module Network.AWS.ArrowUtils (+ split, unsplit, atTag, text+)++where++import Control.Arrow+import Text.XML.HXT.Arrow++-- misc. functions for working with arrows (and HXT)++split :: (Arrow a) => a b (b, b)+split = arr (\x -> (x,x))++unsplit :: (Arrow a) => (b -> c -> d) -> a (b, c) d+unsplit = arr . uncurry++atTag tag = deep (isElem >>> hasName tag)++text = getChildren >>> getText
+ src/Network/AWS/Authentication.hs view
@@ -0,0 +1,387 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.AWS.Authentication+-- Copyright : (c) Greg Heartsfield 2007, David Himmelstrup 2009+-- License : BSD3+--+-- Implements authentication and low-level communication with Amazon+-- Web Services, such as S3, SimpleDB, EC2, and others.+-- API Version 2009-04-15+-- <http://docs.amazonwebservices.com/AmazonSimpleDB/2009-04-15/DeveloperGuide/>+-----------------------------------------------------------------------------++module Network.AWS.Authentication (+ -- * Function Types+ runAction, --isAmzHeader, -- preSignedURI,+ -- * Data Types+ SimpleDBAction(..),+ -- Misc functions+ -- mimeEncodeQP, mimeDecode+ ) where++import Network.AWS.AWSResult+import Network.AWS.AWSConnection+import Network.AWS.ArrowUtils+import Network.HTTP as HTTP hiding (simpleHTTP_)+import Network.HTTP.HandleStream (simpleHTTP_)+import Network.Stream (Result)+import Network.URI as URI+import qualified Data.ByteString.Lazy.Char8 as L++import Data.ByteString.Char8 (pack, unpack)++import Data.HMAC+import Codec.Binary.Base64 (encode, decode)+import Codec.Utils (Octet)++import Data.Char (intToDigit, digitToInt, ord, chr, toLower)+import Data.Bits ((.&.))+import qualified Codec.Binary.UTF8.String as US++import Data.List (sortBy, groupBy, intersperse, intercalate, sort)+import Data.Maybe++import System.Time+import System.Locale++import Text.XML.HXT.Arrow++-- | An action to be performed using SimpleDB+data SimpleDBAction =+ SimpleDBAction {+ -- | Connection and authentication information+ sdbConnection :: AWSConnection,+ -- | Query parameters (requires a prefix of @?@)+ sdbQuery :: [String],+ -- | Additional header fields to send+ sdbMetaData :: [(String, String)],+ -- | Body of action, if sending data+ sdbBody :: L.ByteString,+ -- | Type of action, 'PUT', 'GET', etc.+ sdbOperation :: RequestMethod+ } deriving (Show)++-- | Transform an 'SimpleDBAction' into an HTTP request. Does not add+-- authentication or date information, so it is not suitable for+-- sending directly to AWS.+requestFromAction :: SimpleDBAction -- ^ Action to transform+ -> HTTP.HTTPRequest L.ByteString -- ^ Action represented as an HTTP Request.+requestFromAction a =+ Request { rqURI = URI { uriScheme = "",+ uriAuthority = Nothing,+ uriPath = qpath,+ uriQuery = '?':intercalate "&" (sdbQuery a),+ uriFragment = "" },+ rqMethod = sdbOperation a,+ rqHeaders = Header HdrHost (sdbHostname a) :+ headersFromAction a,+ rqBody = (sdbBody a)+ }+ where qpath = ['/']++-- | Create 'Header' objects from an action.+headersFromAction :: SimpleDBAction+ -> [Header]+headersFromAction = map (\(k,v) -> case k of+ "Content-Type" -> Header HdrContentType v+ otherwise -> Header (HdrCustom k) (mimeEncodeQP v))+ . sdbMetaData++-- | Inspect HTTP body, and add a @Content-Length@ header with the+-- correct length.+addContentLengthHeader :: HTTP.HTTPRequest L.ByteString -> HTTP.HTTPRequest L.ByteString+addContentLengthHeader req = insertHeader HdrContentLength (show (L.length (rqBody req))) req++-- | Add AWS authentication header to an HTTP request.+addAuthenticationHeader :: SimpleDBAction -- ^ Action with authentication data+ -> HTTP.HTTPRequest L.ByteString -- ^ Request to transform+ -> HTTP.HTTPRequest L.ByteString -- ^ Authenticated request+addAuthenticationHeader act req+ = appendQuery ("&Signature="++ urlEncode signature) $+ req -- insertHeader HdrAuthorization auth_string req+ where auth_string = "AWS " ++ awsAccessKey conn ++ ":" ++ signature+ signature = makeSignature conn (stringToSign act req)+ conn = sdbConnection act++appendQuery :: String -> HTTP.HTTPRequest L.ByteString -> HTTP.HTTPRequest L.ByteString+appendQuery string req+ = req{ rqURI = uri{ uriQuery = uriQuery uri ++ string } }+ where uri = rqURI req++-- | Sign a string using the given authentication data+makeSignature :: AWSConnection -- ^ Action with authentication data+ -> String -- ^ String to sign+ -> String -- ^ Base-64 encoded signature+makeSignature c s =+ encode (hmac_sha1 keyOctets msgOctets)+ where keyOctets = string2words (awsSecretKey c)+ msgOctets = string2words s++-- | Generate text that will be signed and subsequently added to the+-- request.+stringToSign :: SimpleDBAction -> HTTP.HTTPRequest L.ByteString -> String+stringToSign a r =+ canonicalizeHeaders r +++ canonicalizeResource a ++ "\n" +++ intercalate "&" (sort (sdbQuery a))++-- | Extract header data needed for signing.+canonicalizeHeaders :: HTTP.HTTPRequest L.ByteString -> String+canonicalizeHeaders r =+ http_verb ++ "\n" +++ get_header HdrHost ++ "\n"+-- hdr_content_md5 ++ "\n" +++-- hdr_content_type ++ "\n" +++-- dateOrExpiration ++ "\n"+ where http_verb = show (rqMethod r)+ hdr_content_md5 = get_header HdrContentMD5+ hdr_date = get_header HdrDate+ hdr_content_type = get_header HdrContentType+ get_header h = fromMaybe "" (findHeader h r)+ dateOrExpiration = fromMaybe hdr_date (findHeader HdrExpires r)++-- | Combine same-named headers.+combineHeaders :: [[(String, String)]] -> [(String, String)]+combineHeaders = map mergeSameHeaders++-- | Headers with same name should have values merged.+mergeSameHeaders :: [(String, String)] -> (String, String)+mergeSameHeaders h@(x:_) = let values = map snd h+ in ((fst x), (concat $ intersperse "," values))++-- | Group headers with the same name.+groupHeaders :: [(String, String)] -> [[(String, String)]]+groupHeaders = groupBy (\a b -> fst a == fst b)++-- | Sort by key name.+sortHeaders :: [(String, String)] -> [(String, String)]+sortHeaders = sortBy (\a b -> fst a `compare` fst b)++-- | Make 'Header' easier to work with, and lowercase keys.+headerToLCKeyValue :: Header -> (String, String)+headerToLCKeyValue (Header k v) = (map toLower (show k), v)++-- | Determine if a header belongs in the StringToSign+isAmzHeader :: Header -> Bool+isAmzHeader h =+ case h of+ Header (HdrCustom k) _ -> isPrefix amzHeader k+ otherwise -> False++-- | is the first list a prefix of the second?+isPrefix :: Eq a => [a] -> [a] -> Bool+isPrefix a b = a == take (length a) b++-- | Prefix used by Amazon metadata headers+amzHeader :: String+amzHeader = "x-amz-"++-- | Extract resource name, as required for signing.+canonicalizeResource :: SimpleDBAction -> String+canonicalizeResource a = uri+ where uri = '/' : []+++-- | Add a date string to a request.+addDateToReq :: HTTP.HTTPRequest L.ByteString -- ^ Request to modify+ -> String -- ^ Date string, in RFC 2616 format+ -> String -- ^ Timestamp+ -> HTTP.HTTPRequest L.ByteString-- ^ Request with date header added+addDateToReq r d ts+ = -- appendQuery ("&Timestamp=" ++ urlEncode ts) $+ r {HTTP.rqHeaders =+ HTTP.Header HTTP.HdrDate d : HTTP.rqHeaders r}++-- | Add an expiration date to a request.+addExpirationToReq :: HTTP.HTTPRequest L.ByteString -> String -> HTTP.HTTPRequest L.ByteString+addExpirationToReq r = addHeaderToReq r . HTTP.Header HTTP.HdrExpires++-- | Attach an HTTP header to a request.+addHeaderToReq :: HTTP.HTTPRequest L.ByteString -> Header -> HTTP.HTTPRequest L.ByteString+addHeaderToReq r h = r {HTTP.rqHeaders = h : HTTP.rqHeaders r}++-- | Get hostname to connect to. Needed for european buckets+sdbHostname :: SimpleDBAction -> String+sdbHostname a = sdbhost+ where sdbhost = awsHost (sdbConnection a)++-- | Get current time in HTTP 1.1 format (RFC 2616)+-- Numeric time zones should be used, but I'd rather not subvert the+-- intent of ctTZName, so we stick with the name format. Otherwise,+-- we could send @+0000@ instead of @GMT@.+-- see:+-- <http://www.ietf.org/rfc/rfc2616.txt>+-- <http://www.ietf.org/rfc/rfc1123.txt>+-- <http://www.ietf.org/rfc/rfc822.txt>+httpCurrentDate :: IO String+httpCurrentDate =+ do c <- getClockTime+ let utc_time = (toUTCTime c) {ctTZName = "GMT"}+ return $ formatCalendarTime defaultTimeLocale rfc822DateFormat utc_time++httpCurrentTimestamp :: IO String+httpCurrentTimestamp =+ do c <- getClockTime+ let utc_time = (toUTCTime c) {ctTZName = "GMT"}+ return $ formatCalendarTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" utc_time+++-- | Convenience for dealing with HMAC-SHA1+string2words :: String -> [Octet]+string2words = US.encode++-- | Construct the request specified by an SimpleDBAction, send to Amazon,+-- and return the response. Todo: add MD5 signature.+runAction :: SimpleDBAction -> IO (AWSResult (HTTPResponse L.ByteString))+runAction a = runAction' a (sdbHostname a)++runAction' :: SimpleDBAction -> String -> IO (AWSResult (HTTPResponse L.ByteString))+runAction' a hostname = do+ c <- (openTCPConnection hostname (awsPort (sdbConnection a)))+--bufferOps = lazyBufferOp+ cd <- httpCurrentDate+ ts <- httpCurrentTimestamp+ let a' = a{sdbQuery = ("Timestamp="++urlEncode ts) : ("AWSAccessKeyId="++awsAccessKey (sdbConnection a)) : sdbQuery a}+ let aReq = addAuthenticationHeader a' $+ addContentLengthHeader $+ addDateToReq (requestFromAction a') cd ts+ --putStrLn (stringToSign a' aReq)+ --print aReq+ result <- simpleHTTP_ c aReq+ --print result+ close c+ createAWSResult a result++-- | Construct a pre-signed URI, but don't act on it. This is useful+-- for when an expiration date has been set, and the URI needs to be+-- passed on to a client.+preSignedURI :: SimpleDBAction -- ^ Action with resource+ -> Integer -- ^ Expiration time, in seconds since+ -- 00:00:00 UTC on January 1, 1970+ -> URI -- ^ URI of resource+preSignedURI a e =+ let c = (sdbConnection a)+ srv = (awsHost c)+ pt = (show (awsPort c))+ accessKeyQuery = "AWSAccessKeyId=" ++ awsAccessKey c+ beginQuery = case (sdbQuery a) of+ [] -> "?"+ x -> intercalate "&" x ++ "&"+ expireQuery = "Expires=" ++ show e+ toSign = "GET\n\n\n" ++ show e ++ "\n/"+ sigQuery = "Signature=" ++ urlEncode (makeSignature c toSign)+ q = beginQuery ++ accessKeyQuery ++ "&" +++ expireQuery ++ "&" ++ sigQuery+ in URI { uriScheme = "http:",+ uriAuthority = Just (URIAuth "" srv (':' : pt)),+ uriPath = "/",+ uriQuery = q,+ uriFragment = ""+ }+++-- | Inspect a response for network errors, HTTP error codes, and+-- Amazon error messages.+-- We need the original action in case we get a 307 (temporary redirect)+createAWSResult :: SimpleDBAction -> Result (HTTPResponse L.ByteString) -> IO (AWSResult (HTTPResponse L.ByteString))+createAWSResult a b = either handleError handleSuccess b+ where handleError = return . Left . NetworkError+ handleSuccess s = case (rspCode s) of+ (2,_,_) -> return (Right s)+ -- temporary redirect+ (3,0,7) -> case (findHeader HdrLocation s) of+ Just l -> runAction' a (getHostname l)+ Nothing -> return (Left $ AWSError "Temporary Redirect" "Redirect without location header") -- not good+ (4,0,4) -> return (Left $ AWSError "NotFound" "404 Not Found") -- no body, so no XML to parse+ otherwise -> do e <- parseRestErrorXML (L.unpack (rspBody s))+ return (Left e)+ -- Get hostname part from http url.+ getHostname :: String -> String+ getHostname h = case parseURI h of+ Just u -> case (uriAuthority u) of+ Just auth -> (uriRegName auth)+ Nothing -> ""+ Nothing -> ""+-- | Find the errors embedded in an XML message body from Amazon.+parseRestErrorXML :: String -> IO ReqError+parseRestErrorXML x =+ do e <- runX (readString [(a_validate,v_0)] x+ >>> processRestError)+ case e of+ [] -> return (AWSError "NoErrorInMsg"+ ("HTTP Error condition, but message body"+ ++ "did not contain error code."))+ x:xs -> return x+++-- | Find children of @Error@ entity, use their @Code@ and @Message@+-- entities to create an 'AWSError'.+processRestError = deep (isElem >>> hasName "Error") >>>+ split >>> first (text <<< atTag "Code") >>>+ second (text <<< atTag "Message") >>>+ unsplit (\x y -> AWSError x y)+{-+processRestError = proc n -> do deep (isElem >>> hasName "Error") -< n+ x <- text <<< atTag "Code" -< n+ y <- text <<< atTag "Message" -< n+ returnA -< (AWSError x y)+-}++--- mime header encoding+mimeEncodeQP, mimeDecode :: String -> String+-- | Decode a mime string, we know about quoted printable and base64 encoded UTF-8+-- S3 may convert quoted printable to base64+mimeDecode a+ | isPrefix utf8qp a =+ mimeDecodeQP $ encoded_payload utf8qp a+ | isPrefix utf8b64 a =+ mimeDecodeB64 $ encoded_payload utf8b64 a+ | otherwise =+ a+ where+ utf8qp = "=?UTF-8?Q?"+ utf8b64 = "=?UTF-8?B?"+ -- '=?UTF-8?Q?foobar?=' -> 'foobar'+ encoded_payload prefix = reverse . drop 2 . reverse . drop (length prefix)++mimeDecodeQP :: String -> String+mimeDecodeQP =+ US.decodeString . mimeDecodeQP'++mimeDecodeQP' :: String -> String+mimeDecodeQP' ('=':a:b:rest) =+ chr (16 * digitToInt a + digitToInt b)+ : mimeDecodeQP' rest+mimeDecodeQP' (h:t) =h : mimeDecodeQP' t+mimeDecodeQP' [] = []++mimeDecodeB64 :: String -> String+mimeDecodeB64 s =+ case decode s of+ Nothing -> ""+ Just a -> US.decode a++ -- Encode a String into quoted printable, if needed.+ -- eq: =?UTF-8?Q?=aa?=+mimeEncodeQP s =+ if any reservedChar s+ then "=?UTF-8?Q?" ++ (mimeEncodeQP' $ US.encodeString s) ++ "?="+ else s++mimeEncodeQP' :: String -> String+mimeEncodeQP' [] = []+mimeEncodeQP' (h:t) =+ let str = if reservedChar h then escape h else [h]+ in str ++ mimeEncodeQP' t+ where+ escape x =+ let y = ord x in+ [ '=', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ]++-- Char needs escaping?+reservedChar :: Char -> Bool+reservedChar x+ -- from space (0x20) till '~' everything is fine. The rest are control chars, or high bit.+ | xi >= 0x20 && xi <= 0x7e = False+ | otherwise = True+ where xi = ord x
+ src/Network/AWS/SimpleDB.hs view
@@ -0,0 +1,8 @@+module Network.AWS.SimpleDB+ ( module Network.AWS.Actions+ , module Network.AWS.AWSConnection+ ) where+++import Network.AWS.AWSConnection+import Network.AWS.Actions