diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/hSimpleDB.cabal b/hSimpleDB.cabal new file mode 100644 --- /dev/null +++ b/hSimpleDB.cabal @@ -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 +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 diff --git a/src/Network/AWS/AWSConnection.hs b/src/Network/AWS/AWSConnection.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/AWSConnection.hs @@ -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 "") + diff --git a/src/Network/AWS/AWSResult.hs b/src/Network/AWS/AWSResult.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/AWSResult.hs @@ -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 +-- +----------------------------------------------------------------------------- + +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 + -- + -- 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 diff --git a/src/Network/AWS/Actions.hs b/src/Network/AWS/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Actions.hs @@ -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 diff --git a/src/Network/AWS/ArrowUtils.hs b/src/Network/AWS/ArrowUtils.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/ArrowUtils.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE NoMonomorphismRestriction#-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.AWS.ArrowUtils +-- Copyright : +-- License : +-- +-- Helper functions for working with HXT. Scraped from . +----------------------------------------------------------------------------- + +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 diff --git a/src/Network/AWS/Authentication.hs b/src/Network/AWS/Authentication.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Authentication.hs @@ -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 +-- +----------------------------------------------------------------------------- + +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: +-- +-- +-- +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 diff --git a/src/Network/AWS/SimpleDB.hs b/src/Network/AWS/SimpleDB.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/SimpleDB.hs @@ -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